/* Subroutine */ int clals0_(integer *icompq, integer *nl, integer *nr,
integer *sqre, integer *nrhs, complex *b, integer *ldb, complex *bx,
integer *ldbx, integer *perm, integer *givptr, integer *givcol,
integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real *
difl, real *difr, real *z__, integer *k, real *c__, real *s, real *
rwork, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 1, 1999
Purpose
=======
CLALS0 applies back the multiplying factors of either the left or the
right singular vector matrix of a diagonal matrix appended by a row
to the right hand side matrix B in solving the least squares problem
using the divide-and-conquer SVD approach.
For the left singular vector matrix, three types of orthogonal
matrices are involved:
(1L) Givens rotations: the number of such rotations is GIVPTR; the
pairs of columns/rows they were applied to are stored in GIVCOL;
and the C- and S-values of these rotations are stored in GIVNUM.
(2L) Permutation. The (NL+1)-st row of B is to be moved to the first
row, and for J=2:N, PERM(J)-th row of B is to be moved to the
J-th row.
(3L) The left singular vector matrix of the remaining matrix.
For the right singular vector matrix, four types of orthogonal
matrices are involved:
(1R) The right singular vector matrix of the remaining matrix.
(2R) If SQRE = 1, one extra Givens rotation to generate the right
null space.
(3R) The inverse transformation of (2L).
(4R) The inverse transformation of (1L).
Arguments
=========
ICOMPQ (input) INTEGER
Specifies whether singular vectors are to be computed in
factored form:
= 0: Left singular vector matrix.
= 1: Right singular vector matrix.
NL (input) INTEGER
The row dimension of the upper block. NL >= 1.
NR (input) INTEGER
The row dimension of the lower block. NR >= 1.
SQRE (input) INTEGER
= 0: the lower block is an NR-by-NR square matrix.
= 1: the lower block is an NR-by-(NR+1) rectangular matrix.
The bidiagonal matrix has row dimension N = NL + NR + 1,
and column dimension M = N + SQRE.
NRHS (input) INTEGER
The number of columns of B and BX. NRHS must be at least 1.
B (input/output) COMPLEX array, dimension ( LDB, NRHS )
On input, B contains the right hand sides of the least
squares problem in rows 1 through M. On output, B contains
the solution X in rows 1 through N.
LDB (input) INTEGER
The leading dimension of B. LDB must be at least
max(1,MAX( M, N ) ).
BX (workspace) COMPLEX array, dimension ( LDBX, NRHS )
LDBX (input) INTEGER
The leading dimension of BX.
PERM (input) INTEGER array, dimension ( N )
The permutations (from deflation and sorting) applied
to the two blocks.
GIVPTR (input) INTEGER
The number of Givens rotations which took place in this
subproblem.
GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
Each pair of numbers indicates a pair of rows/columns
involved in a Givens rotation.
LDGCOL (input) INTEGER
The leading dimension of GIVCOL, must be at least N.
GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )
Each number indicates the C or S value used in the
corresponding Givens rotation.
LDGNUM (input) INTEGER
The leading dimension of arrays DIFR, POLES and
GIVNUM, must be at least K.
POLES (input) REAL array, dimension ( LDGNUM, 2 )
On entry, POLES(1:K, 1) contains the new singular
values obtained from solving the secular equation, and
POLES(1:K, 2) is an array containing the poles in the secular
equation.
DIFL (input) REAL array, dimension ( K ).
On entry, DIFL(I) is the distance between I-th updated
(undeflated) singular value and the I-th (undeflated) old
singular value.
DIFR (input) REAL array, dimension ( LDGNUM, 2 ).
On entry, DIFR(I, 1) contains the distances between I-th
updated (undeflated) singular value and the I+1-th
(undeflated) old singular value. And DIFR(I, 2) is the
normalizing factor for the I-th right singular vector.
Z (input) REAL array, dimension ( K )
Contain the components of the deflation-adjusted updating row
vector.
K (input) INTEGER
Contains the dimension of the non-deflated matrix,
This is the order of the related secular equation. 1 <= K <=N.
C (input) REAL
C contains garbage if SQRE =0 and the C-value of a Givens
rotation related to the right null space if SQRE = 1.
S (input) REAL
S contains garbage if SQRE =0 and the S-value of a Givens
rotation related to the right null space if SQRE = 1.
RWORK (workspace) REAL array, dimension
( K*(1+NRHS) + 2*NRHS )
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
Further Details
===============
Based on contributions by
Ming Gu and Ren-Cang Li, Computer Science Division, University of
California at Berkeley, USA
Osni Marques, LBNL/NERSC, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static real c_b5 = -1.f;
static integer c__1 = 1;
static real c_b13 = 1.f;
static real c_b15 = 0.f;
static integer c__0 = 0;
/* System generated locals */
integer givcol_dim1, givcol_offset, difr_dim1, difr_offset, givnum_dim1,
givnum_offset, poles_dim1, poles_offset, b_dim1, b_offset,
bx_dim1, bx_offset, i__1, i__2, i__3, i__4, i__5;
real r__1;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer jcol;
static real temp;
static integer jrow;
extern doublereal snrm2_(integer *, real *, integer *);
static integer i__, j, m, n;
static real diflj, difrj, dsigj;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), sgemv_(char *, integer *, integer *, real *
, real *, integer *, real *, integer *, real *, real *, integer *), csrot_(integer *, complex *, integer *, complex *,
integer *, real *, real *);
extern doublereal slamc3_(real *, real *);
static real dj;
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *), csscal_(integer *, real *, complex *, integer *),
clacpy_(char *, integer *, integer *, complex *, integer *,
complex *, integer *), xerbla_(char *, integer *);
static real dsigjp;
static integer nlp1;
#define difr_ref(a_1,a_2) difr[(a_2)*difr_dim1 + a_1]
#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 poles_ref(a_1,a_2) poles[(a_2)*poles_dim1 + a_1]
#define bx_subscr(a_1,a_2) (a_2)*bx_dim1 + a_1
#define bx_ref(a_1,a_2) bx[bx_subscr(a_1,a_2)]
#define givcol_ref(a_1,a_2) givcol[(a_2)*givcol_dim1 + a_1]
#define givnum_ref(a_1,a_2) givnum[(a_2)*givnum_dim1 + a_1]
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
bx_dim1 = *ldbx;
bx_offset = 1 + bx_dim1 * 1;
bx -= bx_offset;
--perm;
givcol_dim1 = *ldgcol;
givcol_offset = 1 + givcol_dim1 * 1;
givcol -= givcol_offset;
difr_dim1 = *ldgnum;
difr_offset = 1 + difr_dim1 * 1;
difr -= difr_offset;
poles_dim1 = *ldgnum;
poles_offset = 1 + poles_dim1 * 1;
poles -= poles_offset;
givnum_dim1 = *ldgnum;
givnum_offset = 1 + givnum_dim1 * 1;
givnum -= givnum_offset;
--difl;
--z__;
--rwork;
/* Function Body */
*info = 0;
if (*icompq < 0 || *icompq > 1) {
*info = -1;
} else if (*nl < 1) {
*info = -2;
} else if (*nr < 1) {
*info = -3;
} else if (*sqre < 0 || *sqre > 1) {
*info = -4;
}
n = *nl + *nr + 1;
if (*nrhs < 1) {
*info = -5;
} else if (*ldb < n) {
*info = -7;
} else if (*ldbx < n) {
*info = -9;
} else if (*givptr < 0) {
*info = -11;
} else if (*ldgcol < n) {
*info = -13;
} else if (*ldgnum < n) {
*info = -15;
} else if (*k < 1) {
*info = -20;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLALS0", &i__1);
return 0;
}
m = n + *sqre;
nlp1 = *nl + 1;
if (*icompq == 0) {
/* Apply back orthogonal transformations from the left.
Step (1L): apply back the Givens rotations performed. */
i__1 = *givptr;
for (i__ = 1; i__ <= i__1; ++i__) {
csrot_(nrhs, &b_ref(givcol_ref(i__, 2), 1), ldb, &b_ref(
givcol_ref(i__, 1), 1), ldb, &givnum_ref(i__, 2), &
givnum_ref(i__, 1));
/* L10: */
}
/* Step (2L): permute rows of B. */
ccopy_(nrhs, &b_ref(nlp1, 1), ldb, &bx_ref(1, 1), ldbx);
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
ccopy_(nrhs, &b_ref(perm[i__], 1), ldb, &bx_ref(i__, 1), ldbx);
/* L20: */
}
/* Step (3L): apply the inverse of the left singular vector
matrix to BX. */
if (*k == 1) {
ccopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb);
if (z__[1] < 0.f) {
csscal_(nrhs, &c_b5, &b[b_offset], ldb);
}
} else {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
diflj = difl[j];
dj = poles_ref(j, 1);
dsigj = -poles_ref(j, 2);
if (j < *k) {
difrj = -difr_ref(j, 1);
dsigjp = -poles_ref(j + 1, 2);
}
if (z__[j] == 0.f || poles_ref(j, 2) == 0.f) {
rwork[j] = 0.f;
} else {
rwork[j] = -poles_ref(j, 2) * z__[j] / diflj / (poles_ref(
j, 2) + dj);
}
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0.f || poles_ref(i__, 2) == 0.f) {
rwork[i__] = 0.f;
} else {
rwork[i__] = poles_ref(i__, 2) * z__[i__] / (slamc3_(&
poles_ref(i__, 2), &dsigj) - diflj) / (
poles_ref(i__, 2) + dj);
}
/* L30: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[i__] == 0.f || poles_ref(i__, 2) == 0.f) {
rwork[i__] = 0.f;
} else {
rwork[i__] = poles_ref(i__, 2) * z__[i__] / (slamc3_(&
poles_ref(i__, 2), &dsigjp) + difrj) / (
poles_ref(i__, 2) + dj);
}
/* L40: */
}
rwork[1] = -1.f;
temp = snrm2_(k, &rwork[1], &c__1);
/* Since B and BX are complex, the following call to SGEMV
is performed in two steps (real and imaginary parts).
CALL SGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
$ B( J, 1 ), LDB ) */
i__ = *k + (*nrhs << 1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = *k;
for (jrow = 1; jrow <= i__3; ++jrow) {
++i__;
i__4 = bx_subscr(jrow, jcol);
rwork[i__] = bx[i__4].r;
/* L50: */
}
/* L60: */
}
sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
&rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1);
i__ = *k + (*nrhs << 1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = *k;
for (jrow = 1; jrow <= i__3; ++jrow) {
++i__;
rwork[i__] = r_imag(&bx_ref(jrow, jcol));
/* L70: */
}
/* L80: */
}
sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
&rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], &
c__1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = b_subscr(j, jcol);
i__4 = jcol + *k;
i__5 = jcol + *k + *nrhs;
q__1.r = rwork[i__4], q__1.i = rwork[i__5];
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L90: */
}
clascl_("G", &c__0, &c__0, &temp, &c_b13, &c__1, nrhs, &b_ref(
j, 1), ldb, info);
/* L100: */
}
}
/* Move the deflated rows of BX to B also. */
if (*k < max(m,n)) {
i__1 = n - *k;
clacpy_("A", &i__1, nrhs, &bx_ref(*k + 1, 1), ldbx, &b_ref(*k + 1,
1), ldb);
}
} else {
/* Apply back the right orthogonal transformations.
Step (1R): apply back the new right singular vector matrix
to B. */
if (*k == 1) {
ccopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx);
} else {
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
dsigj = poles_ref(j, 2);
if (z__[j] == 0.f) {
rwork[j] = 0.f;
} else {
rwork[j] = -z__[j] / difl[j] / (dsigj + poles_ref(j, 1)) /
difr_ref(j, 2);
}
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.f) {
rwork[i__] = 0.f;
} else {
r__1 = -poles_ref(i__ + 1, 2);
rwork[i__] = z__[j] / (slamc3_(&dsigj, &r__1) -
difr_ref(i__, 1)) / (dsigj + poles_ref(i__, 1)
) / difr_ref(i__, 2);
}
/* L110: */
}
i__2 = *k;
for (i__ = j + 1; i__ <= i__2; ++i__) {
if (z__[j] == 0.f) {
rwork[i__] = 0.f;
} else {
r__1 = -poles_ref(i__, 2);
rwork[i__] = z__[j] / (slamc3_(&dsigj, &r__1) - difl[
i__]) / (dsigj + poles_ref(i__, 1)) /
difr_ref(i__, 2);
}
/* L120: */
}
/* Since B and BX are complex, the following call to SGEMV
is performed in two steps (real and imaginary parts).
CALL SGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
$ BX( J, 1 ), LDBX ) */
i__ = *k + (*nrhs << 1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = *k;
for (jrow = 1; jrow <= i__3; ++jrow) {
++i__;
i__4 = b_subscr(jrow, jcol);
rwork[i__] = b[i__4].r;
/* L130: */
}
/* L140: */
}
sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
&rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1);
i__ = *k + (*nrhs << 1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = *k;
for (jrow = 1; jrow <= i__3; ++jrow) {
++i__;
rwork[i__] = r_imag(&b_ref(jrow, jcol));
/* L150: */
}
/* L160: */
}
sgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k,
&rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], &
c__1);
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = bx_subscr(j, jcol);
i__4 = jcol + *k;
i__5 = jcol + *k + *nrhs;
q__1.r = rwork[i__4], q__1.i = rwork[i__5];
bx[i__3].r = q__1.r, bx[i__3].i = q__1.i;
/* L170: */
}
/* L180: */
}
}
/* Step (2R): if SQRE = 1, apply back the rotation that is
related to the right null space of the subproblem. */
if (*sqre == 1) {
ccopy_(nrhs, &b_ref(m, 1), ldb, &bx_ref(m, 1), ldbx);
csrot_(nrhs, &bx_ref(1, 1), ldbx, &bx_ref(m, 1), ldbx, c__, s);
}
if (*k < max(m,n)) {
i__1 = n - *k;
clacpy_("A", &i__1, nrhs, &b_ref(*k + 1, 1), ldb, &bx_ref(*k + 1,
1), ldbx);
}
/* Step (3R): permute rows of B. */
ccopy_(nrhs, &bx_ref(1, 1), ldbx, &b_ref(nlp1, 1), ldb);
if (*sqre == 1) {
ccopy_(nrhs, &bx_ref(m, 1), ldbx, &b_ref(m, 1), ldb);
}
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
ccopy_(nrhs, &bx_ref(i__, 1), ldbx, &b_ref(perm[i__], 1), ldb);
/* L190: */
}
/* Step (4R): apply back the Givens rotations performed. */
for (i__ = *givptr; i__ >= 1; --i__) {
r__1 = -givnum_ref(i__, 1);
csrot_(nrhs, &b_ref(givcol_ref(i__, 2), 1), ldb, &b_ref(
givcol_ref(i__, 1), 1), ldb, &givnum_ref(i__, 2), &r__1);
/* L200: */
}
}
return 0;
/* End of CLALS0 */
} /* clals0_ */
/* Subroutine */ int clalsd_(char *uplo, integer *smlsiz, integer *n, integer
*nrhs, real *d__, real *e, complex *b, integer *ldb, real *rcond,
integer *rank, complex *work, real *rwork, integer *iwork, integer *
info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1;
complex q__1;
/* Builtin functions */
double r_imag(complex *), log(doublereal), r_sign(real *, real *);
/* Local variables */
integer c__, i__, j, k;
real r__;
integer s, u, z__;
real cs;
integer bx;
real sn;
integer st, vt, nm1, st1;
real eps;
integer iwk;
real tol;
integer difl, difr;
real rcnd;
integer jcol, irwb, perm, nsub, nlvl, sqre, bxst, jrow, irwu, jimag,
jreal;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
integer irwib;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
integer poles, sizei, irwrb, nsize;
extern /* Subroutine */ int csrot_(integer *, complex *, integer *,
complex *, integer *, real *, real *);
integer irwvt, icmpq1, icmpq2;
extern /* Subroutine */ int clalsa_(integer *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, real *,
integer *, real *, integer *, real *, real *, real *, real *,
integer *, integer *, integer *, integer *, real *, real *, real *
, real *, integer *, integer *), clascl_(char *, integer *,
integer *, real *, real *, integer *, integer *, complex *,
integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int slasda_(integer *, integer *, integer *,
integer *, real *, real *, real *, integer *, real *, integer *,
real *, real *, real *, real *, integer *, integer *, integer *,
integer *, real *, real *, real *, real *, integer *, integer *),
clacpy_(char *, integer *, integer *, complex *, integer *,
complex *, integer *), claset_(char *, integer *, integer
*, complex *, complex *, complex *, integer *), xerbla_(
char *, integer *), slascl_(char *, integer *, integer *,
real *, real *, integer *, integer *, real *, integer *, integer *
);
extern integer isamax_(integer *, real *, integer *);
integer givcol;
extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *), slartg_(real *, real *, real *, real *, real *
);
real orgnrm;
integer givnum;
extern doublereal slanst_(char *, integer *, real *, real *);
extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
integer givptr, nrwork, irwwrk, smlszp;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLALSD uses the singular value decomposition of A to solve the least */
/* squares problem of finding X to minimize the Euclidean norm of each */
/* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */
/* are N-by-NRHS. The solution X overwrites B. */
/* The singular values of A smaller than RCOND times the largest */
/* singular value are treated as zero in solving the least squares */
/* problem; in this case a minimum norm solution is returned. */
/* The actual singular values are returned in D in ascending order. */
/* This code makes very mild assumptions about floating point */
/* arithmetic. It will work on machines with a guard digit in */
/* add/subtract, or on those binary machines without guard digits */
/* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */
/* It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': D and E define an upper bidiagonal matrix. */
/* = 'L': D and E define a lower bidiagonal matrix. */
/* SMLSIZ (input) INTEGER */
/* The maximum size of the subproblems at the bottom of the */
/* computation tree. */
/* N (input) INTEGER */
/* The dimension of the bidiagonal matrix. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of B. NRHS must be at least 1. */
/* D (input/output) REAL array, dimension (N) */
/* On entry D contains the main diagonal of the bidiagonal */
/* matrix. On exit, if INFO = 0, D contains its singular values. */
/* E (input/output) REAL array, dimension (N-1) */
/* Contains the super-diagonal entries of the bidiagonal matrix. */
/* On exit, E has been destroyed. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On input, B contains the right hand sides of the least */
/* squares problem. On output, B contains the solution X. */
/* LDB (input) INTEGER */
/* The leading dimension of B in the calling subprogram. */
/* LDB must be at least max(1,N). */
/* RCOND (input) REAL */
/* The singular values of A less than or equal to RCOND times */
/* the largest singular value are treated as zero in solving */
/* the least squares problem. If RCOND is negative, */
/* machine precision is used instead. */
/* For example, if diag(S)*X=B were the least squares problem, */
/* where diag(S) is a diagonal matrix of singular values, the */
/* solution would be X(i) = B(i) / S(i) if S(i) is greater than */
/* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to */
/* RCOND*max(S). */
/* RANK (output) INTEGER */
/* The number of singular values of A greater than RCOND times */
/* the largest singular value. */
/* WORK (workspace) COMPLEX array, dimension (N * NRHS). */
/* RWORK (workspace) REAL array, dimension at least */
/* (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + (SMLSIZ+1)**2), */
/* where */
/* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */
/* IWORK (workspace) INTEGER array, dimension (3*N*NLVL + 11*N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: The algorithm failed to compute an singular value while */
/* working on the submatrix lying in rows and columns */
/* INFO/(N+1) through MOD(INFO,N+1). */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Ming Gu and Ren-Cang Li, Computer Science Division, University of */
/* California at Berkeley, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--d__;
--e;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
--rwork;
--iwork;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -3;
} else if (*nrhs < 1) {
*info = -4;
} else if (*ldb < 1 || *ldb < *n) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLALSD", &i__1);
return 0;
}
eps = slamch_("Epsilon");
/* Set up the tolerance. */
if (*rcond <= 0.f || *rcond >= 1.f) {
rcnd = eps;
} else {
rcnd = *rcond;
}
*rank = 0;
/* Quick return if possible. */
if (*n == 0) {
return 0;
} else if (*n == 1) {
if (d__[1] == 0.f) {
claset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
} else {
*rank = 1;
clascl_("G", &c__0, &c__0, &d__[1], &c_b10, &c__1, nrhs, &b[
b_offset], ldb, info);
d__[1] = dabs(d__[1]);
}
return 0;
}
/* Rotate the matrix if it is lower bidiagonal. */
if (*(unsigned char *)uplo == 'L') {
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
slartg_(&d__[i__], &e[i__], &cs, &sn, &r__);
d__[i__] = r__;
e[i__] = sn * d__[i__ + 1];
d__[i__ + 1] = cs * d__[i__ + 1];
if (*nrhs == 1) {
csrot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], &
c__1, &cs, &sn);
} else {
rwork[(i__ << 1) - 1] = cs;
rwork[i__ * 2] = sn;
}
/* L10: */
}
if (*nrhs > 1) {
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n - 1;
for (j = 1; j <= i__2; ++j) {
cs = rwork[(j << 1) - 1];
sn = rwork[j * 2];
csrot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__
* b_dim1], &c__1, &cs, &sn);
/* L20: */
}
/* L30: */
}
}
}
/* Scale. */
nm1 = *n - 1;
orgnrm = slanst_("M", n, &d__[1], &e[1]);
if (orgnrm == 0.f) {
claset_("A", n, nrhs, &c_b1, &c_b1, &b[b_offset], ldb);
return 0;
}
slascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, &c__1, &d__[1], n, info);
slascl_("G", &c__0, &c__0, &orgnrm, &c_b10, &nm1, &c__1, &e[1], &nm1,
info);
/* If N is smaller than the minimum divide size SMLSIZ, then solve */
/* the problem with another solver. */
if (*n <= *smlsiz) {
irwu = 1;
irwvt = irwu + *n * *n;
irwwrk = irwvt + *n * *n;
irwrb = irwwrk;
irwib = irwrb + *n * *nrhs;
irwb = irwib + *n * *nrhs;
slaset_("A", n, n, &c_b35, &c_b10, &rwork[irwu], n);
slaset_("A", n, n, &c_b35, &c_b10, &rwork[irwvt], n);
slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &rwork[irwvt], n,
&rwork[irwu], n, &rwork[irwwrk], &c__1, &rwork[irwwrk], info);
if (*info != 0) {
return 0;
}
/* In the real version, B is passed to SLASDQ and multiplied */
/* internally by Q'. Here B is complex and that product is */
/* computed below in two steps (real and imaginary parts). */
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
i__3 = jrow + jcol * b_dim1;
rwork[j] = b[i__3].r;
/* L40: */
}
/* L50: */
}
sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n,
&c_b35, &rwork[irwrb], n);
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
/* L60: */
}
/* L70: */
}
sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n,
&c_b35, &rwork[irwib], n);
jreal = irwrb - 1;
jimag = irwib - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++jreal;
++jimag;
i__3 = jrow + jcol * b_dim1;
i__4 = jreal;
i__5 = jimag;
q__1.r = rwork[i__4], q__1.i = rwork[i__5];
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L80: */
}
/* L90: */
}
tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (d__[i__] <= tol) {
claset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb);
} else {
clascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &b[
i__ + b_dim1], ldb, info);
++(*rank);
}
/* L100: */
}
/* Since B is complex, the following call to SGEMM is performed */
/* in two steps (real and imaginary parts). That is for V * B */
/* (in the real version of the code V' is stored in WORK). */
/* CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, */
/* $ WORK( NWORK ), N ) */
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
i__3 = jrow + jcol * b_dim1;
rwork[j] = b[i__3].r;
/* L110: */
}
/* L120: */
}
sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb],
n, &c_b35, &rwork[irwrb], n);
j = irwb - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++j;
rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
/* L130: */
}
/* L140: */
}
sgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb],
n, &c_b35, &rwork[irwib], n);
jreal = irwrb - 1;
jimag = irwib - 1;
i__1 = *nrhs;
for (jcol = 1; jcol <= i__1; ++jcol) {
i__2 = *n;
for (jrow = 1; jrow <= i__2; ++jrow) {
++jreal;
++jimag;
i__3 = jrow + jcol * b_dim1;
i__4 = jreal;
i__5 = jimag;
q__1.r = rwork[i__4], q__1.i = rwork[i__5];
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L150: */
}
/* L160: */
}
/* Unscale. */
slascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n,
info);
slasrt_("D", n, &d__[1], info);
clascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset],
ldb, info);
return 0;
}
/* Book-keeping and setting up some constants. */
nlvl = (integer) (log((real) (*n) / (real) (*smlsiz + 1)) / log(2.f)) + 1;
smlszp = *smlsiz + 1;
u = 1;
vt = *smlsiz * *n + 1;
difl = vt + smlszp * *n;
difr = difl + nlvl * *n;
z__ = difr + (nlvl * *n << 1);
c__ = z__ + nlvl * *n;
s = c__ + *n;
poles = s + *n;
givnum = poles + (nlvl << 1) * *n;
nrwork = givnum + (nlvl << 1) * *n;
bx = 1;
irwrb = nrwork;
irwib = irwrb + *smlsiz * *nrhs;
irwb = irwib + *smlsiz * *nrhs;
sizei = *n + 1;
k = sizei + *n;
givptr = k + *n;
perm = givptr + *n;
givcol = perm + nlvl * *n;
iwk = givcol + (nlvl * *n << 1);
st = 1;
sqre = 0;
icmpq1 = 1;
icmpq2 = 0;
nsub = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = d__[i__], dabs(r__1)) < eps) {
d__[i__] = r_sign(&eps, &d__[i__]);
}
/* L170: */
}
i__1 = nm1;
for (i__ = 1; i__ <= i__1; ++i__) {
if ((r__1 = e[i__], dabs(r__1)) < eps || i__ == nm1) {
++nsub;
iwork[nsub] = st;
/* Subproblem found. First determine its size and then */
/* apply divide and conquer on it. */
if (i__ < nm1) {
/* A subproblem with E(I) small for I < NM1. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else if ((r__1 = e[i__], dabs(r__1)) >= eps) {
/* A subproblem with E(NM1) not too small but I = NM1. */
nsize = *n - st + 1;
iwork[sizei + nsub - 1] = nsize;
} else {
/* A subproblem with E(NM1) small. This implies an */
/* 1-by-1 subproblem at D(N), which is not solved */
/* explicitly. */
nsize = i__ - st + 1;
iwork[sizei + nsub - 1] = nsize;
++nsub;
iwork[nsub] = *n;
iwork[sizei + nsub - 1] = 1;
ccopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n);
}
st1 = st - 1;
if (nsize == 1) {
/* This is a 1-by-1 subproblem and is not solved */
/* explicitly. */
ccopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n);
} else if (nsize <= *smlsiz) {
/* This is a small subproblem and is solved by SLASDQ. */
slaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[vt + st1],
n);
slaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[u + st1],
n);
slasdq_("U", &c__0, &nsize, &nsize, &nsize, &c__0, &d__[st], &
e[st], &rwork[vt + st1], n, &rwork[u + st1], n, &
rwork[nrwork], &c__1, &rwork[nrwork], info)
;
if (*info != 0) {
return 0;
}
/* In the real version, B is passed to SLASDQ and multiplied */
/* internally by Q'. Here B is complex and that product is */
/* computed below in two steps (real and imaginary parts). */
j = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++j;
i__4 = jrow + jcol * b_dim1;
rwork[j] = b[i__4].r;
/* L180: */
}
/* L190: */
}
sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1]
, n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &
nsize);
j = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++j;
rwork[j] = r_imag(&b[jrow + jcol * b_dim1]);
/* L200: */
}
/* L210: */
}
sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1]
, n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &
nsize);
jreal = irwrb - 1;
jimag = irwib - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++jreal;
++jimag;
i__4 = jrow + jcol * b_dim1;
i__5 = jreal;
i__6 = jimag;
q__1.r = rwork[i__5], q__1.i = rwork[i__6];
b[i__4].r = q__1.r, b[i__4].i = q__1.i;
/* L220: */
}
/* L230: */
}
clacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx +
st1], n);
} else {
/* A large problem. Solve it using divide and conquer. */
slasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], &
rwork[u + st1], n, &rwork[vt + st1], &iwork[k + st1],
&rwork[difl + st1], &rwork[difr + st1], &rwork[z__ +
st1], &rwork[poles + st1], &iwork[givptr + st1], &
iwork[givcol + st1], n, &iwork[perm + st1], &rwork[
givnum + st1], &rwork[c__ + st1], &rwork[s + st1], &
rwork[nrwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
bxst = bx + st1;
clalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, &
work[bxst], n, &rwork[u + st1], n, &rwork[vt + st1], &
iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1]
, &rwork[z__ + st1], &rwork[poles + st1], &iwork[
givptr + st1], &iwork[givcol + st1], n, &iwork[perm +
st1], &rwork[givnum + st1], &rwork[c__ + st1], &rwork[
s + st1], &rwork[nrwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
st = i__ + 1;
}
/* L240: */
}
/* Apply the singular values and treat the tiny ones as zero. */
tol = rcnd * (r__1 = d__[isamax_(n, &d__[1], &c__1)], dabs(r__1));
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Some of the elements in D can be negative because 1-by-1 */
/* subproblems were not solved explicitly. */
if ((r__1 = d__[i__], dabs(r__1)) <= tol) {
claset_("A", &c__1, nrhs, &c_b1, &c_b1, &work[bx + i__ - 1], n);
} else {
++(*rank);
clascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &work[
bx + i__ - 1], n, info);
}
d__[i__] = (r__1 = d__[i__], dabs(r__1));
/* L250: */
}
/* Now apply back the right singular vectors. */
icmpq2 = 1;
i__1 = nsub;
for (i__ = 1; i__ <= i__1; ++i__) {
st = iwork[i__];
st1 = st - 1;
nsize = iwork[sizei + i__ - 1];
bxst = bx + st1;
if (nsize == 1) {
ccopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb);
} else if (nsize <= *smlsiz) {
/* Since B and BX are complex, the following call to SGEMM */
/* is performed in two steps (real and imaginary parts). */
/* CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, */
/* $ RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO, */
/* $ B( ST, 1 ), LDB ) */
j = bxst - *n - 1;
jreal = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
j += *n;
i__3 = nsize;
for (jrow = 1; jrow <= i__3; ++jrow) {
++jreal;
i__4 = j + jrow;
rwork[jreal] = work[i__4].r;
/* L260: */
}
/* L270: */
}
sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1],
n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &nsize);
j = bxst - *n - 1;
jimag = irwb - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
j += *n;
i__3 = nsize;
for (jrow = 1; jrow <= i__3; ++jrow) {
++jimag;
rwork[jimag] = r_imag(&work[j + jrow]);
/* L280: */
}
/* L290: */
}
sgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1],
n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &nsize);
jreal = irwrb - 1;
jimag = irwib - 1;
i__2 = *nrhs;
for (jcol = 1; jcol <= i__2; ++jcol) {
i__3 = st + nsize - 1;
for (jrow = st; jrow <= i__3; ++jrow) {
++jreal;
++jimag;
i__4 = jrow + jcol * b_dim1;
i__5 = jreal;
i__6 = jimag;
q__1.r = rwork[i__5], q__1.i = rwork[i__6];
b[i__4].r = q__1.r, b[i__4].i = q__1.i;
/* L300: */
}
/* L310: */
}
} else {
clalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st +
b_dim1], ldb, &rwork[u + st1], n, &rwork[vt + st1], &
iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1], &
rwork[z__ + st1], &rwork[poles + st1], &iwork[givptr +
st1], &iwork[givcol + st1], n, &iwork[perm + st1], &rwork[
givnum + st1], &rwork[c__ + st1], &rwork[s + st1], &rwork[
nrwork], &iwork[iwk], info);
if (*info != 0) {
return 0;
}
}
/* L320: */
}
/* Unscale and sort the singular values. */
slascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n, info);
slasrt_("D", n, &d__[1], info);
clascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset], ldb,
info);
return 0;
/* End of CLALSD */
} /* clalsd_ */
/* Subroutine */ int chpsvx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *ap, complex *afp, integer *ipiv, complex *b, integer *
ldb, complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
complex *work, real *rwork, integer *info, ftnlen fact_len, ftnlen
uplo_len)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Local variables */
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static real anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
extern doublereal clanhp_(char *, char *, integer *, complex *, real *,
ftnlen, ftnlen), slamch_(char *, ftnlen);
static logical nofact;
extern /* Subroutine */ int chpcon_(char *, integer *, complex *, integer
*, real *, real *, complex *, integer *, ftnlen), clacpy_(char *,
integer *, integer *, complex *, integer *, complex *, integer *,
ftnlen), xerbla_(char *, integer *, ftnlen), chprfs_(char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *, complex *, integer *, real *, real *, complex *, real *
, integer *, ftnlen), chptrf_(char *, integer *, complex *,
integer *, integer *, ftnlen), chptrs_(char *, integer *, integer
*, complex *, integer *, complex *, integer *, integer *, ftnlen);
/* -- LAPACK driver routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPSVX uses the diagonal pivoting factorization A = U*D*U**H or */
/* A = L*D*L**H to compute the solution to a complex system of linear */
/* equations A * X = B, where A is an N-by-N Hermitian matrix stored */
/* in packed format and X and B are N-by-NRHS matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */
/* A = U * D * U**H, if UPLO = 'U', or */
/* A = L * D * L**H, if UPLO = 'L', */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices and D is Hermitian and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
/* returns with INFO = i. Otherwise, the factored form of A is used */
/* to estimate the condition number of the matrix A. If the */
/* reciprocal of the condition number is less than machine precision, */
/* INFO = N+1 is returned as a warning, but the routine still goes on */
/* to solve for X and compute error bounds as described below. */
/* 3. The system of equations is solved for X using the factored form */
/* of A. */
/* 4. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of A has been */
/* supplied on entry. */
/* = 'F': On entry, AFP and IPIV contain the factored form of */
/* A. AFP and IPIV will not be modified. */
/* = 'N': The matrix A will be copied to AFP and factored. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The upper or lower triangle of the Hermitian matrix A, packed */
/* columnwise in a linear array. The j-th column of A is stored */
/* in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* See below for further details. */
/* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2) */
/* If FACT = 'F', then AFP is an input argument and on entry */
/* contains the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L from the factorization */
/* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as */
/* a packed triangular matrix in the same storage format as A. */
/* If FACT = 'N', then AFP is an output argument and on exit */
/* contains the block diagonal matrix D and the multipliers used */
/* to obtain the factor U or L from the factorization */
/* A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as */
/* a packed triangular matrix in the same storage format as A. */
/* IPIV (input or output) INTEGER array, dimension (N) */
/* If FACT = 'F', then IPIV is an input argument and on entry */
/* contains details of the interchanges and the block structure */
/* of D, as determined by CHPTRF. */
/* If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
/* interchanged and D(k,k) is a 1-by-1 diagonal block. */
/* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
/* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
/* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */
/* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
/* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* If FACT = 'N', then IPIV is an output argument and on exit */
/* contains details of the interchanges and the block structure */
/* of D, as determined by CHPTRF. */
/* B (input) COMPLEX array, dimension (LDB,NRHS) */
/* The N-by-NRHS right hand side matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) COMPLEX array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* The estimate of the reciprocal condition number of the matrix */
/* A. If RCOND is less than the machine precision (in */
/* particular, if RCOND = 0), the matrix is singular to working */
/* precision. This condition is indicated by a return code of */
/* INFO > 0. */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: D(i,i) is exactly zero. The factorization */
/* has been completed but the factor D is exactly */
/* singular, so the solution and error bounds could */
/* not be computed. RCOND = 0 is returned. */
/* = N+1: D is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* Further Details */
/* =============== */
/* The packed storage scheme is illustrated by the following example */
/* when N = 4, UPLO = 'U': */
/* Two-dimensional storage of the Hermitian matrix A: */
/* a11 a12 a13 a14 */
/* a22 a23 a24 */
/* a33 a34 (aij = conjg(aji)) */
/* a44 */
/* Packed storage of the upper triangle of A: */
/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--afp;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N", (ftnlen)1, (ftnlen)1);
if (! nofact && ! lsame_(fact, "F", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo,
"L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPSVX", &i__1, (ftnlen)6);
return 0;
}
if (nofact) {
/* Compute the factorization A = U*D*U' or A = L*D*L'. */
i__1 = *n * (*n + 1) / 2;
ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
chptrf_(uplo, n, &afp[1], &ipiv[1], info, (ftnlen)1);
/* Return if INFO is non-zero. */
if (*info != 0) {
if (*info > 0) {
*rcond = 0.f;
}
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = clanhp_("I", uplo, n, &ap[1], &rwork[1], (ftnlen)1, (ftnlen)1);
/* Compute the reciprocal of the condition number of A. */
chpcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], info, (
ftnlen)1);
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon", (ftnlen)7)) {
*info = *n + 1;
}
/* Compute the solution vectors X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx, (ftnlen)4);
chptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info, (
ftnlen)1);
/* Use iterative refinement to improve the computed solutions and */
/* compute error bounds and backward error estimates for them. */
chprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[
x_offset], ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info, (
ftnlen)1);
return 0;
/* End of CHPSVX */
} /* chpsvx_ */
/* Subroutine */ int cqlt02_(integer *m, integer *n, integer *k, complex *a,
complex *af, complex *q, complex *l, integer *lda, complex *tau,
complex *work, integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, l_dim1, l_offset, q_dim1,
q_offset, i__1, i__2;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer info;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
static real resid, anorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
extern doublereal clansy_(char *, char *, integer *, complex *, integer *,
real *);
extern /* Subroutine */ int cungql_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static real eps;
#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 l_subscr(a_1,a_2) (a_2)*l_dim1 + a_1
#define l_ref(a_1,a_2) l[l_subscr(a_1,a_2)]
#define q_subscr(a_1,a_2) (a_2)*q_dim1 + a_1
#define q_ref(a_1,a_2) q[q_subscr(a_1,a_2)]
#define af_subscr(a_1,a_2) (a_2)*af_dim1 + a_1
#define af_ref(a_1,a_2) af[af_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CQLT02 tests CUNGQL, which generates an m-by-n matrix Q with
orthonornmal columns that is defined as the product of k elementary
reflectors.
Given the QL factorization of an m-by-n matrix A, CQLT02 generates
the orthogonal matrix Q defined by the factorization of the last k
columns of A; it compares L(m-n+1:m,n-k+1:n) with
Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are
orthonormal.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix Q to be generated. M >= 0.
N (input) INTEGER
The number of columns of the matrix Q to be generated.
M >= N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines the
matrix Q. N >= K >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The m-by-n matrix A which was factorized by CQLT01.
AF (input) COMPLEX array, dimension (LDA,N)
Details of the QL factorization of A, as returned by CGEQLF.
See CGEQLF for further details.
Q (workspace) COMPLEX array, dimension (LDA,N)
L (workspace) COMPLEX array, dimension (LDA,N)
LDA (input) INTEGER
The leading dimension of the arrays A, AF, Q and L. LDA >= M.
TAU (input) COMPLEX array, dimension (N)
The scalar factors of the elementary reflectors corresponding
to the QL factorization in AF.
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
RWORK (workspace) REAL array, dimension (M)
RESULT (output) REAL array, dimension (2)
The test ratios:
RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
=====================================================================
Quick return if possible
Parameter adjustments */
l_dim1 = *lda;
l_offset = 1 + l_dim1 * 1;
l -= l_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.f;
result[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
/* Copy the last k columns of the factorization to the array Q */
claset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*k < *m) {
i__1 = *m - *k;
clacpy_("Full", &i__1, k, &af_ref(1, *n - *k + 1), lda, &q_ref(1, *n
- *k + 1), lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
clacpy_("Upper", &i__1, &i__2, &af_ref(*m - *k + 1, *n - *k + 2), lda,
&q_ref(*m - *k + 1, *n - *k + 2), lda);
}
/* Generate the last n columns of the matrix Q */
s_copy(srnamc_1.srnamt, "CUNGQL", (ftnlen)6, (ftnlen)6);
cungql_(m, n, k, &q[q_offset], lda, &tau[*n - *k + 1], &work[1], lwork, &
info);
/* Copy L(m-n+1:m,n-k+1:n) */
claset_("Full", n, k, &c_b9, &c_b9, &l_ref(*m - *n + 1, *n - *k + 1), lda);
clacpy_("Lower", k, k, &af_ref(*m - *k + 1, *n - *k + 1), lda, &l_ref(*m
- *k + 1, *n - *k + 1), lda);
/* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n) */
cgemm_("Conjugate transpose", "No transpose", n, k, m, &c_b14, &q[
q_offset], lda, &a_ref(1, *n - *k + 1), lda, &c_b15, &l_ref(*m - *
n + 1, *n - *k + 1), lda);
/* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) . */
anorm = clange_("1", m, k, &a_ref(1, *n - *k + 1), lda, &rwork[1]);
resid = clange_("1", n, k, &l_ref(*m - *n + 1, *n - *k + 1), lda, &rwork[
1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*m) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q'*Q */
claset_("Full", n, n, &c_b9, &c_b15, &l[l_offset], lda);
cherk_("Upper", "Conjugate transpose", n, m, &c_b23, &q[q_offset], lda, &
c_b24, &l[l_offset], lda);
/* Compute norm( I - Q'*Q ) / ( M * EPS ) . */
resid = clansy_("1", "Upper", n, &l[l_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*m) / eps;
return 0;
/* End of CQLT02 */
} /* cqlt02_ */
/* Subroutine */ int crqt03_(integer *m, integer *n, integer *k, complex *af,
complex *c__, complex *cc, complex *q, integer *lda, complex *tau,
complex *work, integer *lwork, real *rwork, real *result)
{
/* Initialized data */
static integer iseed[4] = { 1988,1989,1990,1991 };
/* System generated locals */
integer af_dim1, af_offset, c_dim1, c_offset, cc_dim1, cc_offset, q_dim1,
q_offset, i__1, i__2;
/* Local variables */
integer j, mc, nc;
real eps;
char side[1];
integer info;
integer iside;
real resid;
integer minmn;
real cnorm;
char trans[1];
integer itrans;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CRQT03 tests CUNMRQ, which computes Q*C, Q'*C, C*Q or C*Q'. */
/* CRQT03 compares the results of a call to CUNMRQ with the results of */
/* forming Q explicitly by a call to CUNGRQ and then performing matrix */
/* multiplication by a call to CGEMM. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows or columns of the matrix C; C is n-by-m if */
/* Q is applied from the left, or m-by-n if Q is applied from */
/* the right. M >= 0. */
/* N (input) INTEGER */
/* The order of the orthogonal matrix Q. N >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* orthogonal matrix Q. N >= K >= 0. */
/* AF (input) COMPLEX array, dimension (LDA,N) */
/* Details of the RQ factorization of an m-by-n matrix, as */
/* returned by CGERQF. See CGERQF for further details. */
/* C (workspace) COMPLEX array, dimension (LDA,N) */
/* CC (workspace) COMPLEX array, dimension (LDA,N) */
/* Q (workspace) COMPLEX array, dimension (LDA,N) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays AF, C, CC, and Q. */
/* TAU (input) COMPLEX array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the RQ factorization in AF. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The length of WORK. LWORK must be at least M, and should be */
/* M*NB, where NB is the blocksize for this environment. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL array, dimension (4) */
/* The test ratios compare two techniques for multiplying a */
/* random matrix C by an n-by-n orthogonal matrix Q. */
/* RESULT(1) = norm( Q*C - Q*C ) / ( N * norm(C) * EPS ) */
/* RESULT(2) = norm( C*Q - C*Q ) / ( N * norm(C) * EPS ) */
/* RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS ) */
/* RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
cc_dim1 = *lda;
cc_offset = 1 + cc_dim1;
cc -= cc_offset;
c_dim1 = *lda;
c_offset = 1 + c_dim1;
c__ -= c_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
eps = slamch_("Epsilon");
minmn = min(*m,*n);
/* Quick return if possible */
if (minmn == 0) {
result[1] = 0.f;
result[2] = 0.f;
result[3] = 0.f;
result[4] = 0.f;
return 0;
}
/* Copy the last k rows of the factorization to the array Q */
claset_("Full", n, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*k > 0 && *n > *k) {
i__1 = *n - *k;
clacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*n - *k
+ 1 + q_dim1], lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
clacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
af_dim1], lda, &q[*n - *k + 2 + (*n - *k + 1) * q_dim1], lda);
}
/* Generate the n-by-n matrix Q */
s_copy(srnamc_1.srnamt, "CUNGRQ", (ftnlen)32, (ftnlen)6);
cungrq_(n, n, k, &q[q_offset], lda, &tau[minmn - *k + 1], &work[1], lwork,
&info);
for (iside = 1; iside <= 2; ++iside) {
if (iside == 1) {
*(unsigned char *)side = 'L';
mc = *n;
nc = *m;
} else {
*(unsigned char *)side = 'R';
mc = *m;
nc = *n;
}
/* Generate MC by NC matrix C */
i__1 = nc;
for (j = 1; j <= i__1; ++j) {
clarnv_(&c__2, iseed, &mc, &c__[j * c_dim1 + 1]);
/* L10: */
}
cnorm = clange_("1", &mc, &nc, &c__[c_offset], lda, &rwork[1]);
if (cnorm == 0.f) {
cnorm = 1.f;
}
for (itrans = 1; itrans <= 2; ++itrans) {
if (itrans == 1) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
/* Copy C */
clacpy_("Full", &mc, &nc, &c__[c_offset], lda, &cc[cc_offset],
lda);
/* Apply Q or Q' to C */
s_copy(srnamc_1.srnamt, "CUNMRQ", (ftnlen)32, (ftnlen)6);
if (*k > 0) {
cunmrq_(side, trans, &mc, &nc, k, &af[*m - *k + 1 + af_dim1],
lda, &tau[minmn - *k + 1], &cc[cc_offset], lda, &work[
1], lwork, &info);
}
/* Form explicit product and subtract */
if (lsame_(side, "L")) {
cgemm_(trans, "No transpose", &mc, &nc, &mc, &c_b21, &q[
q_offset], lda, &c__[c_offset], lda, &c_b22, &cc[
cc_offset], lda);
} else {
cgemm_("No transpose", trans, &mc, &nc, &nc, &c_b21, &c__[
c_offset], lda, &q[q_offset], lda, &c_b22, &cc[
cc_offset], lda);
}
/* Compute error in the difference */
resid = clange_("1", &mc, &nc, &cc[cc_offset], lda, &rwork[1]);
result[(iside - 1 << 1) + itrans] = resid / ((real) max(1,*n) *
cnorm * eps);
/* L20: */
}
/* L30: */
}
return 0;
/* End of CRQT03 */
} /* crqt03_ */
/* Subroutine */ int cppsvx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *ap, complex *afp, char *equed, real *s, complex *b,
integer *ldb, complex *x, integer *ldx, real *rcond, real *ferr, real
*berr, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
complex q__1;
/* Local variables */
integer i__, j;
real amax, smin, smax;
extern logical lsame_(char *, char *);
real scond, anorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
logical equil, rcequ;
extern doublereal clanhp_(char *, char *, integer *, complex *, real *), slamch_(char *);
extern /* Subroutine */ int claqhp_(char *, integer *, complex *, real *,
real *, real *, char *);
logical nofact;
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
real bignum;
extern /* Subroutine */ int cppcon_(char *, integer *, complex *, real *,
real *, complex *, real *, integer *);
integer infequ;
extern /* Subroutine */ int cppequ_(char *, integer *, complex *, real *,
real *, real *, integer *), cpprfs_(char *, integer *,
integer *, complex *, complex *, complex *, integer *, complex *,
integer *, real *, real *, complex *, real *, integer *),
cpptrf_(char *, integer *, complex *, integer *);
real smlnum;
extern /* Subroutine */ int cpptrs_(char *, integer *, integer *, complex
*, complex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to */
/* compute the solution to a complex system of linear equations */
/* A * X = B, */
/* where A is an N-by-N Hermitian positive definite matrix stored in */
/* packed format and X and B are N-by-NRHS matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
/* the system: */
/* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
/* factor the matrix A (after equilibration if FACT = 'E') as */
/* A = U'* U , if UPLO = 'U', or */
/* A = L * L', if UPLO = 'L', */
/* where U is an upper triangular matrix, L is a lower triangular */
/* matrix, and ' indicates conjugate transpose. */
/* 3. If the leading i-by-i principal minor is not positive definite, */
/* then the routine returns with INFO = i. Otherwise, the factored */
/* form of A is used to estimate the condition number of the matrix */
/* A. If the reciprocal of the condition number is less than machine */
/* precision, INFO = N+1 is returned as a warning, but the routine */
/* still goes on to solve for X and compute error bounds as */
/* described below. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(S) so that it solves the original system before */
/* equilibration. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AFP contains the factored form of A. */
/* If EQUED = 'Y', the matrix A has been equilibrated */
/* with scaling factors given by S. AP and AFP will not */
/* be modified. */
/* = 'N': The matrix A will be copied to AFP and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AFP and factored. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array, except if FACT = 'F' */
/* and EQUED = 'Y', then A must contain the equilibrated matrix */
/* diag(S)*A*diag(S). The j-th column of A is stored in the */
/* array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* See below for further details. A is not modified if */
/* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
/* diag(S)*A*diag(S). */
/* AFP (input or output) COMPLEX array, dimension (N*(N+1)/2) */
/* If FACT = 'F', then AFP is an input argument and on entry */
/* contains the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H, in the same storage */
/* format as A. If EQUED .ne. 'N', then AFP is the factored */
/* form of the equilibrated matrix A. */
/* If FACT = 'N', then AFP is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H of the original */
/* matrix A. */
/* If FACT = 'E', then AFP is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**H*U or A = L*L**H of the equilibrated */
/* matrix A (see the description of AP for the form of the */
/* equilibrated matrix). */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'Y': Equilibration was done, i.e., A has been replaced by */
/* diag(S) * A * diag(S). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* S (input or output) REAL array, dimension (N) */
/* The scale factors for A; not accessed if EQUED = 'N'. S is */
/* an input argument if FACT = 'F'; otherwise, S is an output */
/* argument. If FACT = 'F' and EQUED = 'Y', each element of S */
/* must be positive. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', */
/* B is overwritten by diag(S) * B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) COMPLEX array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to */
/* the original system of equations. Note that if EQUED = 'Y', */
/* A and B are modified on exit, and the solution to the */
/* equilibrated system is inv(diag(S))*X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* The estimate of the reciprocal condition number of the matrix */
/* A after equilibration (if done). If RCOND is less than the */
/* machine precision (in particular, if RCOND = 0), the matrix */
/* is singular to working precision. This condition is */
/* indicated by a return code of INFO > 0. */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace) REAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: the leading minor of order i of A is */
/* not positive definite, so the factorization */
/* could not be completed, and the solution has not */
/* been computed. RCOND = 0 is returned. */
/* = N+1: U is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* Further Details */
/* =============== */
/* The packed storage scheme is illustrated by the following example */
/* when N = 4, UPLO = 'U': */
/* Two-dimensional storage of the Hermitian matrix A: */
/* a11 a12 a13 a14 */
/* a22 a23 a24 */
/* a33 a34 (aij = conjg(aji)) */
/* a44 */
/* Packed storage of the upper triangle of A: */
/* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ap;
--afp;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -7;
} else {
if (rcequ) {
smin = bignum;
smax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = smin, r__2 = s[j];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[j];
smax = dmax(r__1,r__2);
/* L10: */
}
if (smin <= 0.f) {
*info = -8;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPPSVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
cppequ_(uplo, n, &ap[1], &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
claqhp_(uplo, n, &ap[1], &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__;
i__5 = i__ + j * b_dim1;
q__1.r = s[i__4] * b[i__5].r, q__1.i = s[i__4] * b[i__5].i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L20: */
}
/* L30: */
}
}
if (nofact || equil) {
/* Compute the Cholesky factorization A = U'*U or A = L*L'. */
i__1 = *n * (*n + 1) / 2;
ccopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
cpptrf_(uplo, n, &afp[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A. */
anorm = clanhp_("I", uplo, n, &ap[1], &rwork[1]);
/* Compute the reciprocal of the condition number of A. */
cppcon_(uplo, n, &afp[1], &anorm, rcond, &work[1], &rwork[1], info);
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cpptrs_(uplo, n, nrhs, &afp[1], &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
cpprfs_(uplo, n, nrhs, &ap[1], &afp[1], &b[b_offset], ldb, &x[x_offset],
ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info);
/* Transform the solution matrix X to a solution of the original */
/* system. */
if (rcequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__;
i__5 = i__ + j * x_dim1;
q__1.r = s[i__4] * x[i__5].r, q__1.i = s[i__4] * x[i__5].i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L40: */
}
/* L50: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= scond;
/* L60: */
}
}
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
return 0;
/* End of CPPSVX */
} /* cppsvx_ */
/* Subroutine */ int cgegs_(char *jobvsl, char *jobvsr, integer *n, complex *
a, integer *lda, complex *b, integer *ldb, complex *alpha, complex *
beta, complex *vsl, integer *ldvsl, complex *vsr, integer *ldvsr,
complex *work, integer *lwork, real *rwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SGEGS computes for a pair of N-by-N complex nonsymmetric matrices A,
B: the generalized eigenvalues (alpha, beta), the complex Schur
form (A, B), and optionally left and/or right Schur vectors
(VSL and VSR).
(If only the generalized eigenvalues are needed, use the driver CGEGV
instead.)
A generalized eigenvalue for a pair of matrices (A,B) is, roughly
speaking, a scalar w or a ratio alpha/beta = w, such that A - w*B
is singular. It is usually represented as the pair (alpha,beta),
as there is a reasonable interpretation for beta=0, and even for
both being zero. A good beginning reference is the book, "VISMatrix
Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press)
The (generalized) Schur form of a pair of matrices is the result of
multiplying both matrices on the left by one unitary matrix and
both on the right by another unitary matrix, these two unitary
matrices being chosen so as to bring the pair of matrices into
upper triangular form with the diagonal elements of B being
non-negative real numbers (this is also called complex Schur form.)
The left and right Schur vectors are the columns of VSL and VSR,
respectively, where VSL and VSR are the unitary matrices
which reduce A and B to Schur form:
Schur form of (A,B) = ( (VSL)**H A (VSR), (VSL)**H B (VSR) )
Arguments
=========
JOBVSL (input) CHARACTER*1
= 'N': do not compute the left Schur vectors;
= 'V': compute the left Schur vectors.
JOBVSR (input) CHARACTER*1
= 'N': do not compute the right Schur vectors;
= 'V': compute the right Schur vectors.
N (input) INTEGER
The order of the matrices A, B, VSL, and VSR. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the first of the pair of matrices whose generalized
eigenvalues and (optionally) Schur vectors are to be
computed.
On exit, the generalized Schur form of A.
LDA (input) INTEGER
The leading dimension of A. LDA >= max(1,N).
B (input/output) COMPLEX array, dimension (LDB, N)
On entry, the second of the pair of matrices whose
generalized eigenvalues and (optionally) Schur vectors are
to be computed.
On exit, the generalized Schur form of B.
LDB (input) INTEGER
The leading dimension of B. LDB >= max(1,N).
ALPHA (output) COMPLEX array, dimension (N)
BETA (output) COMPLEX array, dimension (N)
On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the
generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),
j=1,...,N are the diagonals of the complex Schur form (A,B)
output by CGEGS. The BETA(j) will be non-negative real.
Note: the quotients ALPHA(j)/BETA(j) may easily over- or
underflow, and BETA(j) may even be zero. Thus, the user
should avoid naively computing the ratio alpha/beta.
However, ALPHA will be always less than and usually
comparable with norm(A) in magnitude, and BETA always less
than and usually comparable with norm(B).
VSL (output) COMPLEX array, dimension (LDVSL,N)
If JOBVSL = 'V', VSL will contain the left Schur vectors.
(See "Purpose", above.)
Not referenced if JOBVSL = 'N'.
LDVSL (input) INTEGER
The leading dimension of the matrix VSL. LDVSL >= 1, and
if JOBVSL = 'V', LDVSL >= N.
VSR (output) COMPLEX array, dimension (LDVSR,N)
If JOBVSR = 'V', VSR will contain the right Schur vectors.
(See "Purpose", above.)
Not referenced if JOBVSR = 'N'.
LDVSR (input) INTEGER
The leading dimension of the matrix VSR. LDVSR >= 1, and
if JOBVSR = 'V', LDVSR >= N.
WORK (workspace/output) COMPLEX array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,2*N).
For good performance, LWORK must generally be larger.
To compute the optimal value of LWORK, call ILAENV to get
blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute:
NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;
the optimal LWORK is N*(NB+1).
RWORK (workspace) REAL array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
=1,...,N:
The QZ iteration failed. (A,B) are not in Schur
form, but ALPHA(j) and BETA(j) should be correct for
j=INFO+1,...,N.
> N: errors that usually indicate LAPACK problems:
=N+1: error return from CGGBAL
=N+2: error return from CGEQRF
=N+3: error return from CUNMQR
=N+4: error return from CUNGQR
=N+5: error return from CGGHRD
=N+6: error return from CHGEQZ (other than failed
iteration)
=N+7: error return from CGGBAK (computing VSL)
=N+8: error return from CGGBAK (computing VSR)
=N+9: error return from CLASCL (various places)
=====================================================================
Decode the input arguments
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c_n1 = -1;
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, vsl_dim1, vsl_offset,
vsr_dim1, vsr_offset, i__1, i__2, i__3;
/* Local variables */
static real anrm, bnrm;
static integer itau;
extern logical lsame_(char *, char *);
static integer ileft, iinfo, icols;
static logical ilvsl;
static integer iwork;
static logical ilvsr;
static integer irows;
extern /* Subroutine */ int cggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, complex *, integer *,
integer *), cggbal_(char *, integer *, complex *,
integer *, complex *, integer *, integer *, integer *, real *,
real *, real *, integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int cgghrd_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, integer *),
clascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, complex *, integer *, integer *);
static logical ilascl, ilbscl;
extern /* Subroutine */ int cgeqrf_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
extern /* Subroutine */ int chgeqz_(char *, char *, char *, integer *,
integer *, integer *, complex *, integer *, complex *, integer *,
complex *, complex *, complex *, integer *, complex *, integer *,
complex *, integer *, real *, integer *);
static integer ijobvl, iright, ijobvr;
static real anrmto;
static integer lwkmin;
static real bnrmto;
extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *),
cunmqr_(char *, char *, integer *, integer *, integer *, complex
*, integer *, complex *, complex *, integer *, complex *, integer
*, integer *);
static real smlnum;
static integer irwork, lwkopt, ihi, ilo;
static real eps;
#define ALPHA(I) alpha[(I)-1]
#define BETA(I) beta[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
#define VSL(I,J) vsl[(I)-1 + ((J)-1)* ( *ldvsl)]
#define VSR(I,J) vsr[(I)-1 + ((J)-1)* ( *ldvsr)]
if (lsame_(jobvsl, "N")) {
ijobvl = 1;
ilvsl = FALSE_;
} else if (lsame_(jobvsl, "V")) {
ijobvl = 2;
ilvsl = TRUE_;
} else {
ijobvl = -1;
ilvsl = FALSE_;
}
if (lsame_(jobvsr, "N")) {
ijobvr = 1;
ilvsr = FALSE_;
} else if (lsame_(jobvsr, "V")) {
ijobvr = 2;
ilvsr = TRUE_;
} else {
ijobvr = -1;
ilvsr = FALSE_;
}
/* Test the input arguments
Computing MAX */
i__1 = *n << 1;
lwkmin = max(i__1,1);
lwkopt = lwkmin;
*info = 0;
if (ijobvl <= 0) {
*info = -1;
} else if (ijobvr <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
} else if (*ldvsl < 1 || ilvsl && *ldvsl < *n) {
*info = -11;
} else if (*ldvsr < 1 || ilvsr && *ldvsr < *n) {
*info = -13;
} else if (*lwork < lwkmin) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEGS ", &i__1);
return 0;
}
/* Quick return if possible */
WORK(1).r = (real) lwkopt, WORK(1).i = 0.f;
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("E") * slamch_("B");
safmin = slamch_("S");
smlnum = *n * safmin / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &A(1,1), lda, &RWORK(1));
ilascl = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
anrmto = smlnum;
ilascl = TRUE_;
} else if (anrm > bignum) {
anrmto = bignum;
ilascl = TRUE_;
}
if (ilascl) {
clascl_("G", &c_n1, &c_n1, &anrm, &anrmto, n, n, &A(1,1), lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Scale B if max element outside range [SMLNUM,BIGNUM] */
bnrm = clange_("M", n, n, &B(1,1), ldb, &RWORK(1));
ilbscl = FALSE_;
if (bnrm > 0.f && bnrm < smlnum) {
bnrmto = smlnum;
ilbscl = TRUE_;
} else if (bnrm > bignum) {
bnrmto = bignum;
ilbscl = TRUE_;
}
if (ilbscl) {
clascl_("G", &c_n1, &c_n1, &bnrm, &bnrmto, n, n, &B(1,1), ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
/* Permute the matrix to make it more nearly triangular */
ileft = 1;
iright = *n + 1;
irwork = iright + *n;
iwork = 1;
cggbal_("P", n, &A(1,1), lda, &B(1,1), ldb, &ilo, &ihi, &RWORK(
ileft), &RWORK(iright), &RWORK(irwork), &iinfo);
if (iinfo != 0) {
*info = *n + 1;
goto L10;
}
/* Reduce B to triangular form, and initialize VSL and/or VSR */
irows = ihi + 1 - ilo;
icols = *n + 1 - ilo;
itau = iwork;
iwork = itau + irows;
i__1 = *lwork + 1 - iwork;
cgeqrf_(&irows, &icols, &B(ilo,ilo), ldb, &WORK(itau), &WORK(
iwork), &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 2;
goto L10;
}
i__1 = *lwork + 1 - iwork;
cunmqr_("L", "C", &irows, &icols, &irows, &B(ilo,ilo), ldb, &
WORK(itau), &A(ilo,ilo), lda, &WORK(iwork), &i__1, &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 3;
goto L10;
}
if (ilvsl) {
claset_("Full", n, n, &c_b1, &c_b2, &VSL(1,1), ldvsl);
i__1 = irows - 1;
i__2 = irows - 1;
clacpy_("L", &i__1, &i__2, &B(ilo+1,ilo), ldb, &VSL(ilo+1,ilo), ldvsl);
i__1 = *lwork + 1 - iwork;
cungqr_(&irows, &irows, &irows, &VSL(ilo,ilo), ldvsl, &
WORK(itau), &WORK(iwork), &i__1, &iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
*info = *n + 4;
goto L10;
}
}
if (ilvsr) {
claset_("Full", n, n, &c_b1, &c_b2, &VSR(1,1), ldvsr);
}
/* Reduce to generalized Hessenberg form */
cgghrd_(jobvsl, jobvsr, n, &ilo, &ihi, &A(1,1), lda, &B(1,1),
ldb, &VSL(1,1), ldvsl, &VSR(1,1), ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 5;
goto L10;
}
/* Perform QZ algorithm, computing Schur vectors if desired */
iwork = itau;
i__1 = *lwork + 1 - iwork;
chgeqz_("S", jobvsl, jobvsr, n, &ilo, &ihi, &A(1,1), lda, &B(1,1), ldb, &ALPHA(1), &BETA(1), &VSL(1,1), ldvsl, &
VSR(1,1), ldvsr, &WORK(iwork), &i__1, &RWORK(irwork), &
iinfo);
if (iinfo >= 0) {
/* Computing MAX */
i__3 = iwork;
i__1 = lwkopt, i__2 = (integer) WORK(iwork).r + iwork - 1;
lwkopt = max(i__1,i__2);
}
if (iinfo != 0) {
if (iinfo > 0 && iinfo <= *n) {
*info = iinfo;
} else if (iinfo > *n && iinfo <= *n << 1) {
*info = iinfo - *n;
} else {
*info = *n + 6;
}
goto L10;
}
/* Apply permutation to VSL and VSR */
if (ilvsl) {
cggbak_("P", "L", n, &ilo, &ihi, &RWORK(ileft), &RWORK(iright), n, &
VSL(1,1), ldvsl, &iinfo);
if (iinfo != 0) {
*info = *n + 7;
goto L10;
}
}
if (ilvsr) {
cggbak_("P", "R", n, &ilo, &ihi, &RWORK(ileft), &RWORK(iright), n, &
VSR(1,1), ldvsr, &iinfo);
if (iinfo != 0) {
*info = *n + 8;
goto L10;
}
}
/* Undo scaling */
if (ilascl) {
clascl_("U", &c_n1, &c_n1, &anrmto, &anrm, n, n, &A(1,1), lda, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
clascl_("G", &c_n1, &c_n1, &anrmto, &anrm, n, &c__1, &ALPHA(1), n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
if (ilbscl) {
clascl_("U", &c_n1, &c_n1, &bnrmto, &bnrm, n, n, &B(1,1), ldb, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
clascl_("G", &c_n1, &c_n1, &bnrmto, &bnrm, n, &c__1, &BETA(1), n, &
iinfo);
if (iinfo != 0) {
*info = *n + 9;
return 0;
}
}
L10:
WORK(1).r = (real) lwkopt, WORK(1).i = 0.f;
return 0;
/* End of CGEGS */
} /* cgegs_ */
/* Subroutine */ int cgeev_(char *jobvl, char *jobvr, integer *n, complex *a,
integer *lda, complex *w, complex *vl, integer *ldvl, complex *vr,
integer *ldvr, complex *work, integer *lwork, real *rwork, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1,
i__2, i__3;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal), r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, k, ihi;
real scl;
integer ilo;
real dum[1], eps;
complex tmp;
integer ibal;
char side[1];
real anrm;
integer ierr, itau, iwrk, nout;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
extern doublereal scnrm2_(integer *, complex *, integer *);
extern /* Subroutine */ int cgebak_(char *, char *, integer *, integer *,
integer *, real *, integer *, complex *, integer *, integer *), cgebal_(char *, integer *, complex *, integer *,
integer *, integer *, real *, integer *), slabad_(real *,
real *);
logical scalea;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
real cscale;
extern /* Subroutine */ int cgehrd_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *),
clascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, complex *, integer *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), clacpy_(char *, integer *, integer *, complex *, integer *,
complex *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
logical select[1];
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern /* Subroutine */ int chseqr_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *), ctrevc_(char *,
char *, logical *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, integer *, integer *, complex *,
real *, integer *), cunghr_(integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
integer *);
integer minwrk, maxwrk;
logical wantvl;
real smlnum;
integer hswork, irwork;
logical lquery, wantvr;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGEEV computes for an N-by-N complex nonsymmetric matrix A, the */
/* eigenvalues and, optionally, the left and/or right eigenvectors. */
/* The right eigenvector v(j) of A satisfies */
/* A * v(j) = lambda(j) * v(j) */
/* where lambda(j) is its eigenvalue. */
/* The left eigenvector u(j) of A satisfies */
/* u(j)**H * A = lambda(j) * u(j)**H */
/* where u(j)**H denotes the conjugate transpose of u(j). */
/* The computed eigenvectors are normalized to have Euclidean norm */
/* equal to 1 and largest component real. */
/* Arguments */
/* ========= */
/* JOBVL (input) CHARACTER*1 */
/* = 'N': left eigenvectors of A are not computed; */
/* = 'V': left eigenvectors of are computed. */
/* JOBVR (input) CHARACTER*1 */
/* = 'N': right eigenvectors of A are not computed; */
/* = 'V': right eigenvectors of A are computed. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A has been overwritten. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* W (output) COMPLEX array, dimension (N) */
/* W contains the computed eigenvalues. */
/* VL (output) COMPLEX array, dimension (LDVL,N) */
/* If JOBVL = 'V', the left eigenvectors u(j) are stored one */
/* after another in the columns of VL, in the same order */
/* as their eigenvalues. */
/* If JOBVL = 'N', VL is not referenced. */
/* u(j) = VL(:,j), the j-th column of VL. */
/* LDVL (input) INTEGER */
/* The leading dimension of the array VL. LDVL >= 1; if */
/* JOBVL = 'V', LDVL >= N. */
/* VR (output) COMPLEX array, dimension (LDVR,N) */
/* If JOBVR = 'V', the right eigenvectors v(j) are stored one */
/* after another in the columns of VR, in the same order */
/* as their eigenvalues. */
/* If JOBVR = 'N', VR is not referenced. */
/* v(j) = VR(:,j), the j-th column of VR. */
/* LDVR (input) INTEGER */
/* The leading dimension of the array VR. LDVR >= 1; if */
/* JOBVR = 'V', LDVR >= N. */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,2*N). */
/* For good performance, LWORK must generally be larger. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the QR algorithm failed to compute all the */
/* eigenvalues, and no eigenvectors have been computed; */
/* elements and i+1:N of W contain eigenvalues which have */
/* converged. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
vl_dim1 = *ldvl;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
vr_dim1 = *ldvr;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
lquery = *lwork == -1;
wantvl = lsame_(jobvl, "V");
wantvr = lsame_(jobvr, "V");
if (! wantvl && ! lsame_(jobvl, "N")) {
*info = -1;
} else if (! wantvr && ! lsame_(jobvr, "N")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldvl < 1 || wantvl && *ldvl < *n) {
*info = -8;
} else if (*ldvr < 1 || wantvr && *ldvr < *n) {
*info = -10;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* CWorkspace refers to complex workspace, and RWorkspace to real */
/* workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by CHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case.) */
if (*info == 0) {
if (*n == 0) {
minwrk = 1;
maxwrk = 1;
} else {
maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &
c__0);
minwrk = *n << 1;
if (wantvl) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[1], &c_n1, info);
} else if (wantvr) {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1);
maxwrk = max(i__1,i__2);
chseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
} else {
chseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[1], &c_n1, info);
}
hswork = work[1].r;
/* Computing MAX */
i__1 = max(maxwrk,hswork);
maxwrk = max(i__1,minwrk);
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
if (*lwork < minwrk && ! lquery) {
*info = -12;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEEV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Get machine constants */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &a[a_offset], lda, dum);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr);
}
/* Balance the matrix */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
ibal = 1;
cgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr);
/* Reduce to upper Hessenberg form */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: none) */
itau = 1;
iwrk = itau + *n;
i__1 = *lwork - iwrk + 1;
cgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvl) {
/* Want left eigenvectors */
/* Copy Householder vectors to VL */
*(unsigned char *)side = 'L';
clacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl)
;
/* Generate unitary matrix in VL */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VL */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vl[
vl_offset], ldvl, &work[iwrk], &i__1, info);
if (wantvr) {
/* Want left and right eigenvectors */
/* Copy Schur vectors to VR */
*(unsigned char *)side = 'B';
clacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr);
}
} else if (wantvr) {
/* Want right eigenvectors */
/* Copy Householder vectors to VR */
*(unsigned char *)side = 'R';
clacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr)
;
/* Generate unitary matrix in VR */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk],
&i__1, &ierr);
/* Perform QR iteration, accumulating Schur vectors in VR */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
} else {
/* Compute eigenvalues only */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[
vr_offset], ldvr, &work[iwrk], &i__1, info);
}
/* If INFO > 0 from CHSEQR, then quit */
if (*info > 0) {
goto L50;
}
if (wantvl || wantvr) {
/* Compute left and/or right eigenvectors */
/* (CWorkspace: need 2*N) */
/* (RWorkspace: need 2*N) */
irwork = ibal + *n;
ctrevc_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], ldvl,
&vr[vr_offset], ldvr, n, &nout, &work[iwrk], &rwork[irwork],
&ierr);
}
if (wantvl) {
/* Undo balancing of left eigenvectors */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
cgebak_("B", "L", n, &ilo, &ihi, &rwork[ibal], n, &vl[vl_offset],
ldvl, &ierr);
/* Normalize left eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1);
csscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vl_dim1;
/* Computing 2nd power */
r__1 = vl[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vl[k + i__ * vl_dim1]);
rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L10: */
}
k = isamax_(n, &rwork[irwork], &c__1);
r_cnjg(&q__2, &vl[k + i__ * vl_dim1]);
r__1 = sqrt(rwork[irwork + k - 1]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1);
i__2 = k + i__ * vl_dim1;
i__3 = k + i__ * vl_dim1;
r__1 = vl[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vl[i__2].r = q__1.r, vl[i__2].i = q__1.i;
/* L20: */
}
}
if (wantvr) {
/* Undo balancing of right eigenvectors */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
cgebak_("B", "R", n, &ilo, &ihi, &rwork[ibal], n, &vr[vr_offset],
ldvr, &ierr);
/* Normalize right eigenvectors and make largest component real */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
scl = 1.f / scnrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1);
csscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = k + i__ * vr_dim1;
/* Computing 2nd power */
r__1 = vr[i__3].r;
/* Computing 2nd power */
r__2 = r_imag(&vr[k + i__ * vr_dim1]);
rwork[irwork + k - 1] = r__1 * r__1 + r__2 * r__2;
/* L30: */
}
k = isamax_(n, &rwork[irwork], &c__1);
r_cnjg(&q__2, &vr[k + i__ * vr_dim1]);
r__1 = sqrt(rwork[irwork + k - 1]);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
tmp.r = q__1.r, tmp.i = q__1.i;
cscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1);
i__2 = k + i__ * vr_dim1;
i__3 = k + i__ * vr_dim1;
r__1 = vr[i__3].r;
q__1.r = r__1, q__1.i = 0.f;
vr[i__2].r = q__1.r, vr[i__2].i = q__1.i;
/* L40: */
}
}
/* Undo scaling if necessary */
L50:
if (scalea) {
i__1 = *n - *info;
/* Computing MAX */
i__3 = *n - *info;
i__2 = max(i__3,1);
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1]
, &i__2, &ierr);
if (*info > 0) {
i__1 = ilo - 1;
clascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n,
&ierr);
}
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
return 0;
/* End of CGEEV */
} /* cgeev_ */
/* Subroutine */ int chesvxx_(char *fact, char *uplo, integer *n, integer *
nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
ipiv, char *equed, real *s, complex *b, integer *ldb, complex *x,
integer *ldx, real *rcond, real *rpvgrw, real *berr, integer *
n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer *
nparams, real *params, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real amax, smin, smax;
extern doublereal cla_herpvgrw__(char *, integer *, integer *, complex *,
integer *, complex *, integer *, integer *, real *, ftnlen);
extern logical lsame_(char *, char *);
real scond;
logical equil, rcequ;
extern /* Subroutine */ int claqhe_(char *, integer *, complex *, integer
*, real *, real *, real *, char *);
extern doublereal slamch_(char *);
logical nofact;
extern /* Subroutine */ int chetrf_(char *, integer *, complex *, integer
*, integer *, complex *, integer *, integer *), clacpy_(
char *, integer *, integer *, complex *, integer *, complex *,
integer *), xerbla_(char *, integer *);
real bignum;
integer infequ;
extern /* Subroutine */ int chetrs_(char *, integer *, integer *, complex
*, integer *, integer *, complex *, integer *, integer *);
real smlnum;
extern /* Subroutine */ int clascl2_(integer *, integer *, real *,
complex *, integer *), cheequb_(char *, integer *, complex *,
integer *, real *, real *, real *, complex *, integer *),
cherfsx_(char *, char *, integer *, integer *, complex *, integer
*, complex *, integer *, integer *, real *, complex *, integer *,
complex *, integer *, real *, real *, integer *, real *, real *,
integer *, real *, complex *, real *, integer *);
/* -- LAPACK driver routine (version 3.2.1) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- April 2009 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHESVXX uses the diagonal pivoting factorization to compute the */
/* solution to a complex system of linear equations A * X = B, where */
/* A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
/* matrices. */
/* If requested, both normwise and maximum componentwise error bounds */
/* are returned. CHESVXX will return a solution with a tiny */
/* guaranteed error (O(eps) where eps is the working machine */
/* precision) unless the matrix is very ill-conditioned, in which */
/* case a warning is returned. Relevant condition numbers also are */
/* calculated and returned. */
/* CHESVXX accepts user-provided factorizations and equilibration */
/* factors; see the definitions of the FACT and EQUED options. */
/* Solving with refinement and using a factorization from a previous */
/* CHESVXX call will also produce a solution with either O(eps) */
/* errors or warnings, but we cannot make that claim for general */
/* user-provided factorizations and equilibration factors if they */
/* differ from what CHESVXX would itself produce. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
/* the system: */
/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */
/* the matrix A (after equilibration if FACT = 'E') as */
/* A = U * D * U**T, if UPLO = 'U', or */
/* A = L * D * L**T, if UPLO = 'L', */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, and D is symmetric and block diagonal with */
/* 1-by-1 and 2-by-2 diagonal blocks. */
/* 3. If some D(i,i)=0, so that D is exactly singular, then the */
/* routine returns with INFO = i. Otherwise, the factored form of A */
/* is used to estimate the condition number of the matrix A (see */
/* argument RCOND). If the reciprocal of the condition number is */
/* less than machine precision, the routine still goes on to solve */
/* for X and compute error bounds as described below. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
/* the routine will use iterative refinement to try to get a small */
/* error and error bounds. Refinement calculates the residual to at */
/* least twice the working precision. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(R) so that it solves the original system before */
/* equilibration. */
/* Arguments */
/* ========= */
/* Some optional parameters are bundled in the PARAMS array. These */
/* settings determine how refinement is performed, but often the */
/* defaults are acceptable. If the defaults are acceptable, users */
/* can pass NPARAMS = 0 which prevents the source code from accessing */
/* the PARAMS argument. */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AF and IPIV contain the factored form of A. */
/* If EQUED is not 'N', the matrix A has been */
/* equilibrated with scaling factors given by S. */
/* A, AF, and IPIV are not modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AF and factored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* The symmetric matrix A. If UPLO = 'U', the leading N-by-N */
/* upper triangular part of A contains the upper triangular */
/* part of the matrix A, and the strictly lower triangular */
/* part of A is not referenced. If UPLO = 'L', the leading */
/* N-by-N lower triangular part of A contains the lower */
/* triangular part of the matrix A, and the strictly upper */
/* triangular part of A is not referenced. */
/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
/* diag(S)*A*diag(S). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L from the factorization A = */
/* U*D*U**T or A = L*D*L**T as computed by SSYTRF. */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L from the factorization A = */
/* U*D*U**T or A = L*D*L**T. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input or output) INTEGER array, dimension (N) */
/* If FACT = 'F', then IPIV is an input argument and on entry */
/* contains details of the interchanges and the block */
/* structure of D, as determined by CHETRF. If IPIV(k) > 0, */
/* then rows and columns k and IPIV(k) were interchanged and */
/* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and */
/* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and */
/* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 */
/* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, */
/* then rows and columns k+1 and -IPIV(k) were interchanged */
/* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
/* If FACT = 'N', then IPIV is an output argument and on exit */
/* contains details of the interchanges and the block */
/* structure of D, as determined by CHETRF. */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'Y': Both row and column equilibration, i.e., A has been */
/* replaced by diag(S) * A * diag(S). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* S (input or output) REAL array, dimension (N) */
/* The scale factors for A. If EQUED = 'Y', A is multiplied on */
/* the left and right by diag(S). S is an input argument if FACT = */
/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
/* = 'Y', each element of S must be positive. If S is output, each */
/* element of S is a power of the radix. If S is input, each element */
/* of S should be a power of the radix to ensure a reliable solution */
/* and error estimates. Scaling by powers of the radix does not cause */
/* rounding errors unless the result underflows or overflows. */
/* Rounding errors during scaling lead to refining with a matrix that */
/* is not equivalent to the input matrix, producing error estimates */
/* that may not be reliable. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, */
/* if EQUED = 'N', B is not modified; */
/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) COMPLEX array, dimension (LDX,NRHS) */
/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
/* system of equations. Note that A and B are modified on exit if */
/* EQUED .ne. 'N', and the solution to the equilibrated system is */
/* inv(diag(S))*X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* RPVGRW (output) REAL */
/* Reciprocal pivot growth. On exit, this contains the reciprocal */
/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
/* norm is used. If this is much less than 1, then the stability of */
/* the LU factorization of the (equilibrated) matrix A could be poor. */
/* This also means that the solution X, estimated condition numbers, */
/* and error bounds could be unreliable. If factorization fails with */
/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
/* for the leading INFO columns of A. */
/* BERR (output) REAL array, dimension (NRHS) */
/* Componentwise relative backward error. This is the */
/* componentwise relative backward error of each solution vector X(j) */
/* (i.e., the smallest relative change in any element of A or B that */
/* makes X(j) an exact solution). */
/* N_ERR_BNDS (input) INTEGER */
/* Number of error bounds to return for each right hand side */
/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
/* ERR_BNDS_COMP below. */
/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* NPARAMS (input) INTEGER */
/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
/* PARAMS array is never referenced and default values are used. */
/* PARAMS (input / output) REAL array, dimension NPARAMS */
/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
/* that entry will be filled with default value used for that */
/* parameter. Only positions up to NPARAMS are accessed; defaults */
/* are used for higher-numbered parameters. */
/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
/* refinement or not. */
/* Default: 1.0 */
/* = 0.0 : No refinement is performed, and no error bounds are */
/* computed. */
/* = 1.0 : Use the double-precision refinement algorithm, */
/* possibly with doubled-single computations if the */
/* compilation environment does not support DOUBLE */
/* PRECISION. */
/* (other values are reserved for future use) */
/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
/* computations allowed for refinement. */
/* Default: 10 */
/* Aggressive: Set to 100 to permit convergence using approximate */
/* factorizations or factorizations other than LU. If */
/* the factorization uses a technique other than */
/* Gaussian elimination, the guarantees in */
/* err_bnds_norm and err_bnds_comp may no longer be */
/* trustworthy. */
/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
/* will attempt to find a solution with small componentwise */
/* relative error in the double-precision algorithm. Positive */
/* is true, 0.0 is false. */
/* Default: 1.0 (attempt componentwise convergence) */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace) REAL array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: Successful exit. The solution to every right-hand side is */
/* guaranteed. */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly singular, so */
/* the solution and error bounds could not be computed. RCOND = 0 */
/* is returned. */
/* = N+J: The solution corresponding to the Jth right-hand side is */
/* not guaranteed. The solutions corresponding to other right- */
/* hand sides K with K > J may not be guaranteed as well, but */
/* only the first such right-hand side is reported. If a small */
/* componentwise error is not requested (PARAMS(3) = 0.0) then */
/* the Jth right-hand side is the first with a normwise error */
/* bound that is not guaranteed (the smallest J such */
/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
/* the Jth right-hand side is the first with either a normwise or */
/* componentwise error bound that is not guaranteed (the smallest */
/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
/* about all of the right-hand sides check ERR_BNDS_NORM or */
/* ERR_BNDS_COMP. */
/* ================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
}
/* Default is failure. If an input parameter is wrong or */
/* factorization fails, make everything look horrible. Only the */
/* pivot growth is set here, the rest is initialized in CHERFSX. */
*rpvgrw = 0.f;
/* Test the input parameters. PARAMS is not tested until CHERFSX. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -9;
} else {
if (rcequ) {
smin = bignum;
smax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = smin, r__2 = s[j];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[j];
smax = dmax(r__1,r__2);
/* L10: */
}
if (smin <= 0.f) {
*info = -10;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHESVXX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
cheequb_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, &work[1], &
infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
claqhe_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ) {
clascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
}
if (nofact || equil) {
/* Compute the LU factorization of A. */
clacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
i__1 = max(1,*n) * 5;
chetrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], &i__1,
info);
/* Return if INFO is non-zero. */
if (*info > 0) {
/* Pivot in column INFO is exactly 0 */
/* Compute the reciprocal pivot growth factor of the */
/* leading rank-deficient INFO columns of A. */
if (*n > 0) {
*rpvgrw = cla_herpvgrw__(uplo, n, info, &a[a_offset], lda, &
af[af_offset], ldaf, &ipiv[1], &rwork[1], (ftnlen)1);
}
return 0;
}
}
/* Compute the reciprocal pivot growth factor RPVGRW. */
if (*n > 0) {
*rpvgrw = cla_herpvgrw__(uplo, n, info, &a[a_offset], lda, &af[
af_offset], ldaf, &ipiv[1], &rwork[1], (ftnlen)1);
}
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
chetrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
cherfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
ipiv[1], &s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &
berr[1], n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
1], &rwork[1], info);
/* Scale solutions. */
if (rcequ) {
clascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
}
return 0;
/* End of CHESVXX */
} /* chesvxx_ */
/* Subroutine */ int cgeesx_(char *jobvs, char *sort, L_fp select, char *
sense, integer *n, complex *a, integer *lda, integer *sdim, complex *
w, complex *vs, integer *ldvs, real *rconde, real *rcondv, complex *
work, integer *lwork, real *rwork, logical *bwork, integer *info,
ftnlen jobvs_len, ftnlen sort_len, ftnlen sense_len)
{
/* System generated locals */
integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, k, ihi, ilo;
static real dum[1], eps;
static integer ibal, maxb;
static real anrm;
static integer ierr, itau, iwrk, icond, ieval;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), cgebak_(char *, char *, integer *, integer
*, integer *, real *, integer *, complex *, integer *, integer *,
ftnlen, ftnlen), cgebal_(char *, integer *, complex *, integer *,
integer *, integer *, real *, integer *, ftnlen), slabad_(real *,
real *);
static logical scalea;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *, ftnlen);
static real cscale;
extern /* Subroutine */ int cgehrd_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *),
clascl_(char *, integer *, integer *, real *, real *, integer *,
integer *, complex *, integer *, integer *, ftnlen);
extern doublereal slamch_(char *, ftnlen);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, ftnlen), xerbla_(char *,
integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static real bignum;
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
ftnlen), chseqr_(char *, char *, integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, complex *,
integer *, integer *, ftnlen, ftnlen), cunghr_(integer *, integer
*, integer *, complex *, integer *, complex *, complex *, integer
*, integer *);
static logical wantsb;
extern /* Subroutine */ int ctrsen_(char *, char *, logical *, integer *,
complex *, integer *, complex *, integer *, complex *, integer *,
real *, real *, complex *, integer *, integer *, ftnlen, ftnlen);
static logical wantse;
static integer minwrk, maxwrk;
static logical wantsn;
static real smlnum;
static integer hswork;
static logical wantst, wantsv, wantvs;
/* -- LAPACK driver routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* .. Function Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGEESX computes for an N-by-N complex nonsymmetric matrix A, the */
/* eigenvalues, the Schur form T, and, optionally, the matrix of Schur */
/* vectors Z. This gives the Schur factorization A = Z*T*(Z**H). */
/* Optionally, it also orders the eigenvalues on the diagonal of the */
/* Schur form so that selected eigenvalues are at the top left; */
/* computes a reciprocal condition number for the average of the */
/* selected eigenvalues (RCONDE); and computes a reciprocal condition */
/* number for the right invariant subspace corresponding to the */
/* selected eigenvalues (RCONDV). The leading columns of Z form an */
/* orthonormal basis for this invariant subspace. */
/* For further explanation of the reciprocal condition numbers RCONDE */
/* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */
/* these quantities are called s and sep respectively). */
/* A complex matrix is in Schur form if it is upper triangular. */
/* Arguments */
/* ========= */
/* JOBVS (input) CHARACTER*1 */
/* = 'N': Schur vectors are not computed; */
/* = 'V': Schur vectors are computed. */
/* SORT (input) CHARACTER*1 */
/* Specifies whether or not to order the eigenvalues on the */
/* diagonal of the Schur form. */
/* = 'N': Eigenvalues are not ordered; */
/* = 'S': Eigenvalues are ordered (see SELECT). */
/* SELECT (input) LOGICAL FUNCTION of one COMPLEX argument */
/* SELECT must be declared EXTERNAL in the calling subroutine. */
/* If SORT = 'S', SELECT is used to select eigenvalues to order */
/* to the top left of the Schur form. */
/* If SORT = 'N', SELECT is not referenced. */
/* An eigenvalue W(j) is selected if SELECT(W(j)) is true. */
/* SENSE (input) CHARACTER*1 */
/* Determines which reciprocal condition numbers are computed. */
/* = 'N': None are computed; */
/* = 'E': Computed for average of selected eigenvalues only; */
/* = 'V': Computed for selected right invariant subspace only; */
/* = 'B': Computed for both. */
/* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA, N) */
/* On entry, the N-by-N matrix A. */
/* On exit, A is overwritten by its Schur form T. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* SDIM (output) INTEGER */
/* If SORT = 'N', SDIM = 0. */
/* If SORT = 'S', SDIM = number of eigenvalues for which */
/* SELECT is true. */
/* W (output) COMPLEX array, dimension (N) */
/* W contains the computed eigenvalues, in the same order */
/* that they appear on the diagonal of the output Schur form T. */
/* VS (output) COMPLEX array, dimension (LDVS,N) */
/* If JOBVS = 'V', VS contains the unitary matrix Z of Schur */
/* vectors. */
/* If JOBVS = 'N', VS is not referenced. */
/* LDVS (input) INTEGER */
/* The leading dimension of the array VS. LDVS >= 1, and if */
/* JOBVS = 'V', LDVS >= N. */
/* RCONDE (output) REAL */
/* If SENSE = 'E' or 'B', RCONDE contains the reciprocal */
/* condition number for the average of the selected eigenvalues. */
/* Not referenced if SENSE = 'N' or 'V'. */
/* RCONDV (output) REAL */
/* If SENSE = 'V' or 'B', RCONDV contains the reciprocal */
/* condition number for the selected right invariant subspace. */
/* Not referenced if SENSE = 'N' or 'E'. */
/* WORK (workspace/output) COMPLEX array, dimension (LWORK) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. LWORK >= max(1,2*N). */
/* Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM), */
/* where SDIM is the number of selected eigenvalues computed by */
/* this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. */
/* For good performance, LWORK must generally be larger. */
/* RWORK (workspace) REAL array, dimension (N) */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* Not referenced if SORT = 'N'. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, and i is */
/* <= N: the QR algorithm failed to compute all the */
/* eigenvalues; elements 1:ILO-1 and i+1:N of W */
/* contain those eigenvalues which have converged; if */
/* JOBVS = 'V', VS contains the transformation which */
/* reduces A to its partially converged Schur form. */
/* = N+1: the eigenvalues could not be reordered because some */
/* eigenvalues were too close to separate (the problem */
/* is very ill-conditioned); */
/* = N+2: after reordering, roundoff changed values of some */
/* complex eigenvalues so that leading eigenvalues in */
/* the Schur form no longer satisfy SELECT=.TRUE. This */
/* could also be caused by underflow due to scaling. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--work;
--rwork;
--bwork;
/* Function Body */
*info = 0;
wantvs = lsame_(jobvs, "V", (ftnlen)1, (ftnlen)1);
wantst = lsame_(sort, "S", (ftnlen)1, (ftnlen)1);
wantsn = lsame_(sense, "N", (ftnlen)1, (ftnlen)1);
wantse = lsame_(sense, "E", (ftnlen)1, (ftnlen)1);
wantsv = lsame_(sense, "V", (ftnlen)1, (ftnlen)1);
wantsb = lsame_(sense, "B", (ftnlen)1, (ftnlen)1);
if (! wantvs && ! lsame_(jobvs, "N", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (! wantst && ! lsame_(sort, "N", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && !
wantsn) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldvs < 1 || wantvs && *ldvs < *n) {
*info = -11;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of real workspace needed at that point in the */
/* code, as well as the preferred amount for good performance. */
/* CWorkspace refers to complex workspace, and RWorkspace to real */
/* workspace. NB refers to the optimal block size for the */
/* immediately following subroutine, as returned by ILAENV. */
/* HSWORK refers to the workspace preferred by CHSEQR, as */
/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */
/* the worst case. */
/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */
/* depends on SDIM, which is computed by the routine CTRSEN later */
/* in the code.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
maxwrk = *n + *n * ilaenv_(&c__1, "CGEHRD", " ", n, &c__1, n, &c__0, (
ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = 1, i__2 = *n << 1;
minwrk = max(i__1,i__2);
if (! wantvs) {
/* Computing MAX */
i__1 = ilaenv_(&c__8, "CHSEQR", "SN", n, &c__1, n, &c_n1, (ftnlen)
6, (ftnlen)2);
maxb = max(i__1,2);
/* Computing MIN */
/* Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "CHSEQR", "SN", n, &c__1, n, &
c_n1, (ftnlen)6, (ftnlen)2);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = max(maxwrk,hswork);
maxwrk = max(i__1,1);
} else {
/* Computing MAX */
i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "CUNGHR",
" ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
/* Computing MAX */
i__1 = ilaenv_(&c__8, "CHSEQR", "SV", n, &c__1, n, &c_n1, (ftnlen)
6, (ftnlen)2);
maxb = max(i__1,2);
/* Computing MIN */
/* Computing MAX */
i__3 = 2, i__4 = ilaenv_(&c__4, "CHSEQR", "SV", n, &c__1, n, &
c_n1, (ftnlen)6, (ftnlen)2);
i__1 = min(maxb,*n), i__2 = max(i__3,i__4);
k = min(i__1,i__2);
/* Computing MAX */
i__1 = k * (k + 2), i__2 = *n << 1;
hswork = max(i__1,i__2);
/* Computing MAX */
i__1 = max(maxwrk,hswork);
maxwrk = max(i__1,1);
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
}
if (*lwork < minwrk) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGEESX", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*sdim = 0;
return 0;
}
/* Get machine constants */
eps = slamch_("P", (ftnlen)1);
smlnum = slamch_("S", (ftnlen)1);
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = sqrt(smlnum) / eps;
bignum = 1.f / smlnum;
/* Scale A if max element outside range [SMLNUM,BIGNUM] */
anrm = clange_("M", n, n, &a[a_offset], lda, dum, (ftnlen)1);
scalea = FALSE_;
if (anrm > 0.f && anrm < smlnum) {
scalea = TRUE_;
cscale = smlnum;
} else if (anrm > bignum) {
scalea = TRUE_;
cscale = bignum;
}
if (scalea) {
clascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, &
ierr, (ftnlen)1);
}
/* Permute the matrix to make it more nearly triangular */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
ibal = 1;
cgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr, (
ftnlen)1);
/* Reduce to upper Hessenberg form */
/* (CWorkspace: need 2*N, prefer N+N*NB) */
/* (RWorkspace: none) */
itau = 1;
iwrk = *n + itau;
i__1 = *lwork - iwrk + 1;
cgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1,
&ierr);
if (wantvs) {
/* Copy Householder vectors to VS */
clacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs, (ftnlen)1)
;
/* Generate unitary matrix in VS */
/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
cunghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk],
&i__1, &ierr);
}
*sdim = 0;
/* Perform QR iteration, accumulating Schur vectors in VS if desired */
/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */
/* (RWorkspace: none) */
iwrk = itau;
i__1 = *lwork - iwrk + 1;
chseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vs[
vs_offset], ldvs, &work[iwrk], &i__1, &ieval, (ftnlen)1, (ftnlen)
1);
if (ieval > 0) {
*info = ieval;
}
/* Sort eigenvalues if desired */
if (wantst && *info == 0) {
if (scalea) {
clascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &w[1], n, &
ierr, (ftnlen)1);
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bwork[i__] = (*select)(&w[i__]);
/* L10: */
}
/* Reorder eigenvalues, transform Schur vectors, and compute */
/* reciprocal condition numbers */
/* (CWorkspace: if SENSE is not 'N', need 2*SDIM*(N-SDIM) */
/* otherwise, need none ) */
/* (RWorkspace: none) */
i__1 = *lwork - iwrk + 1;
ctrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset],
ldvs, &w[1], sdim, rconde, rcondv, &work[iwrk], &i__1, &
icond, (ftnlen)1, (ftnlen)1);
if (! wantsn) {
/* Computing MAX */
i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim);
maxwrk = max(i__1,i__2);
}
if (icond == -14) {
/* Not enough complex workspace */
*info = -15;
}
}
if (wantvs) {
/* Undo balancing */
/* (CWorkspace: none) */
/* (RWorkspace: need N) */
cgebak_("P", "R", n, &ilo, &ihi, &rwork[ibal], n, &vs[vs_offset],
ldvs, &ierr, (ftnlen)1, (ftnlen)1);
}
if (scalea) {
/* Undo scaling for the Schur form of A */
clascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, &
ierr, (ftnlen)1);
i__1 = *lda + 1;
ccopy_(n, &a[a_offset], &i__1, &w[1], &c__1);
if ((wantsv || wantsb) && *info == 0) {
dum[0] = *rcondv;
slascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &
c__1, &ierr, (ftnlen)1);
*rcondv = dum[0];
}
}
work[1].r = (real) maxwrk, work[1].i = 0.f;
return 0;
/* End of CGEESX */
} /* cgeesx_ */
/* Subroutine */ int cgrqts_(integer *m, integer *p, integer *n, complex *a,
complex *af, complex *q, complex *r__, integer *lda, complex *taua,
complex *b, complex *bf, complex *z__, complex *t, complex *bwk,
integer *ldb, complex *taub, complex *work, integer *lwork, real *
rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, r_dim1, r_offset, q_dim1,
q_offset, b_dim1, b_offset, bf_dim1, bf_offset, t_dim1, t_offset,
z_dim1, z_offset, bwk_dim1, bwk_offset, i__1, i__2;
real r__1;
complex q__1;
/* Local variables */
real ulp;
integer info;
real unfl;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), cherk_(char *,
char *, integer *, integer *, real *, complex *, integer *, real *
, complex *, integer *);
real resid, anorm, bnorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhe_(char *, char *, integer *,
complex *, integer *, real *), slamch_(char *);
extern /* Subroutine */ int cggrqf_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, complex *,
complex *, integer *, integer *), clacpy_(char *, integer *,
integer *, complex *, integer *, complex *, integer *),
claset_(char *, integer *, integer *, complex *, complex *,
complex *, integer *), cungqr_(integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
integer *), cungrq_(integer *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGRQTS tests CGGRQF, which computes the GRQ factorization of an */
/* M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* P (input) INTEGER */
/* The number of rows of the matrix B. P >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrices A and B. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The M-by-N matrix A. */
/* AF (output) COMPLEX array, dimension (LDA,N) */
/* Details of the GRQ factorization of A and B, as returned */
/* by CGGRQF, see CGGRQF for further details. */
/* Q (output) COMPLEX array, dimension (LDA,N) */
/* The N-by-N unitary matrix Q. */
/* R (workspace) COMPLEX array, dimension (LDA,MAX(M,N)) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, R and Q. */
/* LDA >= max(M,N). */
/* TAUA (output) COMPLEX array, dimension (min(M,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by SGGQRC. */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* On entry, the P-by-N matrix A. */
/* BF (output) COMPLEX array, dimension (LDB,N) */
/* Details of the GQR factorization of A and B, as returned */
/* by CGGRQF, see CGGRQF for further details. */
/* Z (output) REAL array, dimension (LDB,P) */
/* The P-by-P unitary matrix Z. */
/* T (workspace) COMPLEX array, dimension (LDB,max(P,N)) */
/* BWK (workspace) COMPLEX array, dimension (LDB,N) */
/* LDB (input) INTEGER */
/* The leading dimension of the arrays B, BF, Z and T. */
/* LDB >= max(P,N). */
/* TAUB (output) COMPLEX array, dimension (min(P,N)) */
/* The scalar factors of the elementary reflectors, as returned */
/* by SGGRQF. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK, LWORK >= max(M,P,N)**2. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL array, dimension (4) */
/* The test ratios: */
/* RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP) */
/* RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP) */
/* RESULT(3) = norm( I - Q'*Q ) / ( N*ULP ) */
/* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--taua;
bwk_dim1 = *ldb;
bwk_offset = 1 + bwk_dim1;
bwk -= bwk_offset;
t_dim1 = *ldb;
t_offset = 1 + t_dim1;
t -= t_offset;
z_dim1 = *ldb;
z_offset = 1 + z_dim1;
z__ -= z_offset;
bf_dim1 = *ldb;
bf_offset = 1 + bf_dim1;
bf -= bf_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--taub;
--work;
--rwork;
--result;
/* Function Body */
ulp = slamch_("Precision");
unfl = slamch_("Safe minimum");
/* Copy the matrix A to the array AF. */
clacpy_("Full", m, n, &a[a_offset], lda, &af[af_offset], lda);
clacpy_("Full", p, n, &b[b_offset], ldb, &bf[bf_offset], ldb);
/* Computing MAX */
r__1 = clange_("1", m, n, &a[a_offset], lda, &rwork[1]);
anorm = dmax(r__1,unfl);
/* Computing MAX */
r__1 = clange_("1", p, n, &b[b_offset], ldb, &rwork[1]);
bnorm = dmax(r__1,unfl);
/* Factorize the matrices A and B in the arrays AF and BF. */
cggrqf_(m, p, n, &af[af_offset], lda, &taua[1], &bf[bf_offset], ldb, &
taub[1], &work[1], lwork, &info);
/* Generate the N-by-N matrix Q */
claset_("Full", n, n, &c_b3, &c_b3, &q[q_offset], lda);
if (*m <= *n) {
if (*m > 0 && *m < *n) {
i__1 = *n - *m;
clacpy_("Full", m, &i__1, &af[af_offset], lda, &q[*n - *m + 1 +
q_dim1], lda);
}
if (*m > 1) {
i__1 = *m - 1;
i__2 = *m - 1;
clacpy_("Lower", &i__1, &i__2, &af[(*n - *m + 1) * af_dim1 + 2],
lda, &q[*n - *m + 2 + (*n - *m + 1) * q_dim1], lda);
}
} else {
if (*n > 1) {
i__1 = *n - 1;
i__2 = *n - 1;
clacpy_("Lower", &i__1, &i__2, &af[*m - *n + 2 + af_dim1], lda, &
q[q_dim1 + 2], lda);
}
}
i__1 = min(*m,*n);
cungrq_(n, n, &i__1, &q[q_offset], lda, &taua[1], &work[1], lwork, &info);
/* Generate the P-by-P matrix Z */
claset_("Full", p, p, &c_b3, &c_b3, &z__[z_offset], ldb);
if (*p > 1) {
i__1 = *p - 1;
clacpy_("Lower", &i__1, n, &bf[bf_dim1 + 2], ldb, &z__[z_dim1 + 2],
ldb);
}
i__1 = min(*p,*n);
cungqr_(p, p, &i__1, &z__[z_offset], ldb, &taub[1], &work[1], lwork, &
info);
/* Copy R */
claset_("Full", m, n, &c_b1, &c_b1, &r__[r_offset], lda);
if (*m <= *n) {
clacpy_("Upper", m, m, &af[(*n - *m + 1) * af_dim1 + 1], lda, &r__[(*
n - *m + 1) * r_dim1 + 1], lda);
} else {
i__1 = *m - *n;
clacpy_("Full", &i__1, n, &af[af_offset], lda, &r__[r_offset], lda);
clacpy_("Upper", n, n, &af[*m - *n + 1 + af_dim1], lda, &r__[*m - *n
+ 1 + r_dim1], lda);
}
/* Copy T */
claset_("Full", p, n, &c_b1, &c_b1, &t[t_offset], ldb);
clacpy_("Upper", p, n, &bf[bf_offset], ldb, &t[t_offset], ldb);
/* Compute R - A*Q' */
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("No transpose", "Conjugate transpose", m, n, n, &q__1, &a[a_offset]
, lda, &q[q_offset], lda, &c_b2, &r__[r_offset], lda);
/* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) . */
resid = clange_("1", m, n, &r__[r_offset], lda, &rwork[1]);
if (anorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*m);
result[1] = resid / (real) max(i__1,*n) / anorm / ulp;
} else {
result[1] = 0.f;
}
/* Compute T*Q - Z'*B */
cgemm_("Conjugate transpose", "No transpose", p, n, p, &c_b2, &z__[
z_offset], ldb, &b[b_offset], ldb, &c_b1, &bwk[bwk_offset], ldb);
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("No transpose", "No transpose", p, n, n, &c_b2, &t[t_offset], ldb,
&q[q_offset], lda, &q__1, &bwk[bwk_offset], ldb);
/* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) . */
resid = clange_("1", p, n, &bwk[bwk_offset], ldb, &rwork[1]);
if (bnorm > 0.f) {
/* Computing MAX */
i__1 = max(1,*p);
result[2] = resid / (real) max(i__1,*m) / bnorm / ulp;
} else {
result[2] = 0.f;
}
/* Compute I - Q*Q' */
claset_("Full", n, n, &c_b1, &c_b2, &r__[r_offset], lda);
cherk_("Upper", "No Transpose", n, n, &c_b34, &q[q_offset], lda, &c_b35, &
r__[r_offset], lda);
/* Compute norm( I - Q'*Q ) / ( N * ULP ) . */
resid = clanhe_("1", "Upper", n, &r__[r_offset], lda, &rwork[1]);
result[3] = resid / (real) max(1,*n) / ulp;
/* Compute I - Z'*Z */
claset_("Full", p, p, &c_b1, &c_b2, &t[t_offset], ldb);
cherk_("Upper", "Conjugate transpose", p, p, &c_b34, &z__[z_offset], ldb,
&c_b35, &t[t_offset], ldb);
/* Compute norm( I - Z'*Z ) / ( P*ULP ) . */
resid = clanhe_("1", "Upper", p, &t[t_offset], ldb, &rwork[1]);
result[4] = resid / (real) max(1,*p) / ulp;
return 0;
/* End of CGRQTS */
} /* cgrqts_ */
/* Subroutine */ int cchkql_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, integer *nrhs, real *thresh, logical *tsterr, integer *nmax,
complex *a, complex *af, complex *aq, complex *al, complex *ac,
complex *b, complex *x, complex *xact, complex *tau, complex *work,
real *rwork, integer *iwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
"5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
"t(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
imat, info;
char path[3];
integer kval[4];
char dist[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), cget02_(
char *, integer *, integer *, integer *, complex *, integer *,
complex *, integer *, complex *, integer *, real *, real *);
integer nfail, iseed[4];
extern /* Subroutine */ int cqlt01_(integer *, integer *, complex *,
complex *, complex *, complex *, integer *, complex *, complex *,
integer *, real *, real *), cqlt02_(integer *, integer *, integer
*, complex *, complex *, complex *, complex *, integer *, complex
*, complex *, integer *, real *, real *), cqlt03_(integer *,
integer *, integer *, complex *, complex *, complex *, complex *,
integer *, complex *, complex *, integer *, real *, real *);
real anorm;
integer minmn, nerrs, lwork;
extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, real *, integer *, real *, char *
), alaerh_(char *, char *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *), clacpy_(char *, integer *, integer *, complex *,
integer *, complex *, integer *), clarhs_(char *, char *,
char *, char *, integer *, integer *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, integer *, integer *),
cgeqls_(integer *, integer *, integer *, complex *, integer *,
complex *, complex *, integer *, complex *, integer *, integer *),
alasum_(char *, integer *, integer *, integer *, integer *);
real cndnum;
extern /* Subroutine */ int clatms_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, integer *, integer *
, char *, complex *, integer *, complex *, integer *), cerrql_(char *, integer *), xlaenv_(
integer *, integer *);
real result[7];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKQL tests CGEQLF, CUNGQL and CUNMQL. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NM (input) INTEGER */
/* The number of values of M contained in the vector MVAL. */
/* MVAL (input) INTEGER array, dimension (NM) */
/* The values of the matrix row dimension M. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix column dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB and NX contained in the */
/* vectors NBVAL and NXVAL. The blocking parameters are used */
/* in pairs (NB,NX). */
/* NBVAL (input) INTEGER array, dimension (NNB) */
/* The values of the blocksize NB. */
/* NXVAL (input) INTEGER array, dimension (NNB) */
/* The values of the crossover point NX. */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors to be generated for */
/* each linear system. */
/* THRESH (input) REAL */
/* The threshold value for the test ratios. A result is */
/* included in the output file if RESULT >= THRESH. To have */
/* every test ratio printed, use THRESH = 0. */
/* TSTERR (input) LOGICAL */
/* Flag that indicates whether error exits are to be tested. */
/* NMAX (input) INTEGER */
/* The maximum value permitted for M or N, used in dimensioning */
/* the work arrays. */
/* A (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AF (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AQ (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AL (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* AC (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* B (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* X (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) */
/* TAU (workspace) COMPLEX array, dimension (NMAX) */
/* WORK (workspace) COMPLEX array, dimension (NMAX*NMAX) */
/* RWORK (workspace) REAL array, dimension (NMAX) */
/* IWORK (workspace) INTEGER array, dimension (NMAX) */
/* NOUT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--iwork;
--rwork;
--work;
--tau;
--xact;
--x;
--b;
--ac;
--al;
--aq;
--af;
--a;
--nxval;
--nbval;
--nval;
--mval;
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Initialize constants and the random number seed. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "QL", (ftnlen)2, (ftnlen)2);
nrun = 0;
nfail = 0;
nerrs = 0;
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__ - 1] = iseedy[i__ - 1];
/* L10: */
}
/* Test the error exits */
if (*tsterr) {
cerrql_(path, nout);
}
infoc_1.infot = 0;
xlaenv_(&c__2, &c__2);
lda = *nmax;
lwork = *nmax * max(*nmax,*nrhs);
/* Do for each value of M in MVAL. */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
/* Do for each value of N in NVAL. */
i__2 = *nn;
for (in = 1; in <= i__2; ++in) {
n = nval[in];
minmn = min(m,n);
for (imat = 1; imat <= 8; ++imat) {
/* Do the tests only if DOTYPE( IMAT ) is true. */
if (! dotype[imat]) {
goto L50;
}
/* Set up parameters with CLATB4 and generate a test matrix */
/* with CLATMS. */
clatb4_(path, &imat, &m, &n, type__, &kl, &ku, &anorm, &mode,
&cndnum, dist);
s_copy(srnamc_1.srnamt, "CLATMS", (ftnlen)6, (ftnlen)6);
clatms_(&m, &n, dist, iseed, type__, &rwork[1], &mode, &
cndnum, &anorm, &kl, &ku, "No packing", &a[1], &lda, &
work[1], &info);
/* Check error code from CLATMS. */
if (info != 0) {
alaerh_(path, "CLATMS", &info, &c__0, " ", &m, &n, &c_n1,
&c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
goto L50;
}
/* Set some values for K: the first value must be MINMN, */
/* corresponding to the call of CQLT01; other values are */
/* used in the calls of CQLT02, and must not exceed MINMN. */
kval[0] = minmn;
kval[1] = 0;
kval[2] = 1;
kval[3] = minmn / 2;
if (minmn == 0) {
nk = 1;
} else if (minmn == 1) {
nk = 2;
} else if (minmn <= 3) {
nk = 3;
} else {
nk = 4;
}
/* Do for each value of K in KVAL */
i__3 = nk;
for (ik = 1; ik <= i__3; ++ik) {
k = kval[ik - 1];
/* Do for each pair of values (NB,NX) in NBVAL and NXVAL. */
i__4 = *nnb;
for (inb = 1; inb <= i__4; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
nt = 2;
if (ik == 1) {
/* Test CGEQLF */
cqlt01_(&m, &n, &a[1], &af[1], &aq[1], &al[1], &
lda, &tau[1], &work[1], &lwork, &rwork[1],
result);
} else if (m >= n) {
/* Test CUNGQL, using factorization */
/* returned by CQLT01 */
cqlt02_(&m, &n, &k, &a[1], &af[1], &aq[1], &al[1],
&lda, &tau[1], &work[1], &lwork, &rwork[
1], result);
} else {
result[0] = 0.f;
result[1] = 0.f;
}
if (m >= k) {
/* Test CUNMQL, using factorization returned */
/* by CQLT01 */
cqlt03_(&m, &n, &k, &af[1], &ac[1], &al[1], &aq[1]
, &lda, &tau[1], &work[1], &lwork, &rwork[
1], &result[2]);
nt += 4;
/* If M>=N and K=N, call CGEQLS to solve a system */
/* with NRHS right hand sides and compute the */
/* residual. */
if (k == n && inb == 1) {
/* Generate a solution and set the right */
/* hand side. */
s_copy(srnamc_1.srnamt, "CLARHS", (ftnlen)6, (
ftnlen)6);
clarhs_(path, "New", "Full", "No transpose", &
m, &n, &c__0, &c__0, nrhs, &a[1], &
lda, &xact[1], &lda, &b[1], &lda,
iseed, &info);
clacpy_("Full", &m, nrhs, &b[1], &lda, &x[1],
&lda);
s_copy(srnamc_1.srnamt, "CGEQLS", (ftnlen)6, (
ftnlen)6);
cgeqls_(&m, &n, nrhs, &af[1], &lda, &tau[1], &
x[1], &lda, &work[1], &lwork, &info);
/* Check error code from CGEQLS. */
if (info != 0) {
alaerh_(path, "CGEQLS", &info, &c__0,
" ", &m, &n, nrhs, &c_n1, &nb, &
imat, &nfail, &nerrs, nout);
}
cget02_("No transpose", &m, &n, nrhs, &a[1], &
lda, &x[m - n + 1], &lda, &b[1], &lda,
&rwork[1], &result[6]);
++nt;
} else {
result[6] = 0.f;
}
} else {
result[2] = 0.f;
result[3] = 0.f;
result[4] = 0.f;
result[5] = 0.f;
}
/* Print information about the tests that did not */
/* pass the threshold. */
i__5 = nt;
for (i__ = 1; i__ <= i__5; ++i__) {
if (result[i__ - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[i__ - 1], (
ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
/* L20: */
}
nrun += nt;
/* L30: */
}
/* L40: */
}
L50:
;
}
/* L60: */
}
/* L70: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
return 0;
/* End of CCHKQL */
} /* cchkql_ */
/* Subroutine */ int chet21_(integer *itype, char *uplo, integer *n, integer *
kband, complex *a, integer *lda, real *d__, real *e, complex *u,
integer *ldu, complex *v, integer *ldv, complex *tau, complex *work,
real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
integer j, jr;
real ulp;
extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
integer *, complex *, integer *);
integer jcol;
real unfl;
integer jrow;
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *),
cgemm_(char *, char *, integer *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
integer iinfo;
real anorm;
char cuplo[1];
complex vsave;
logical lower;
real wnorm;
extern /* Subroutine */ int cunm2l_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *), cunm2r_(char *, char *,
integer *, integer *, integer *, complex *, integer *, complex *,
complex *, integer *, complex *, integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), clanhe_(char *, char *, integer *,
complex *, integer *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), claset_(char *,
integer *, integer *, complex *, complex *, complex *, integer *), clarfy_(char *, integer *, complex *, integer *, complex
*, complex *, integer *, complex *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHET21 generally checks a decomposition of the form */
/* A = U S U* */
/* where * means conjugate transpose, A is hermitian, U is unitary, and */
/* S is diagonal (if KBAND=0) or (real) symmetric tridiagonal (if */
/* KBAND=1). */
/* If ITYPE=1, then U is represented as a dense matrix; otherwise U is */
/* expressed as a product of Householder transformations, whose vectors */
/* are stored in the array "V" and whose scaling constants are in "TAU". */
/* We shall use the letter "V" to refer to the product of Householder */
/* transformations (which should be equal to U). */
/* Specifically, if ITYPE=1, then: */
/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU* | / ( n ulp ) */
/* If ITYPE=2, then: */
/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
/* If ITYPE=3, then: */
/* RESULT(1) = | I - UV* | / ( n ulp ) */
/* For ITYPE > 1, the transformation U is expressed as a product */
/* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)* and each */
/* vector v(j) has its first j elements 0 and the remaining n-j elements */
/* stored in V(j+1:n,j). */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the type of tests to be performed. */
/* 1: U expressed as a dense unitary matrix: */
/* RESULT(1) = | A - U S U* | / ( |A| n ulp ) *and* */
/* RESULT(2) = | I - UU* | / ( n ulp ) */
/* 2: U expressed as a product V of Housholder transformations: */
/* RESULT(1) = | A - V S V* | / ( |A| n ulp ) */
/* 3: U expressed both as a dense unitary matrix and */
/* as a product of Housholder transformations: */
/* RESULT(1) = | I - UV* | / ( n ulp ) */
/* UPLO (input) CHARACTER */
/* If UPLO='U', the upper triangle of A and V will be used and */
/* the (strictly) lower triangle will not be referenced. */
/* If UPLO='L', the lower triangle of A and V will be used and */
/* the (strictly) upper triangle will not be referenced. */
/* N (input) INTEGER */
/* The size of the matrix. If it is zero, CHET21 does nothing. */
/* It must be at least zero. */
/* KBAND (input) INTEGER */
/* The bandwidth of the matrix. It may only be zero or one. */
/* If zero, then S is diagonal, and E is not referenced. If */
/* one, then S is symmetric tri-diagonal. */
/* A (input) COMPLEX array, dimension (LDA, N) */
/* The original (unfactored) matrix. It is assumed to be */
/* hermitian, and only the upper (UPLO='U') or only the lower */
/* (UPLO='L') will be referenced. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 1 */
/* and at least N. */
/* D (input) REAL array, dimension (N) */
/* The diagonal of the (symmetric tri-) diagonal matrix. */
/* E (input) REAL array, dimension (N-1) */
/* The off-diagonal of the (symmetric tri-) diagonal matrix. */
/* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and */
/* (3,2) element, etc. */
/* Not referenced if KBAND=0. */
/* U (input) COMPLEX array, dimension (LDU, N) */
/* If ITYPE=1 or 3, this contains the unitary matrix in */
/* the decomposition, expressed as a dense matrix. If ITYPE=2, */
/* then it is not referenced. */
/* LDU (input) INTEGER */
/* The leading dimension of U. LDU must be at least N and */
/* at least 1. */
/* V (input) COMPLEX array, dimension (LDV, N) */
/* If ITYPE=2 or 3, the columns of this array contain the */
/* Householder vectors used to describe the unitary matrix */
/* in the decomposition. If UPLO='L', then the vectors are in */
/* the lower triangle, if UPLO='U', then in the upper */
/* triangle. */
/* *NOTE* If ITYPE=2 or 3, V is modified and restored. The */
/* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U') */
/* is set to one, and later reset to its original value, during */
/* the course of the calculation. */
/* If ITYPE=1, then it is neither referenced nor modified. */
/* LDV (input) INTEGER */
/* The leading dimension of V. LDV must be at least N and */
/* at least 1. */
/* TAU (input) COMPLEX array, dimension (N) */
/* If ITYPE >= 2, then TAU(j) is the scalar factor of */
/* v(j) v(j)* in the Householder transformation H(j) of */
/* the product U = H(1)...H(n-2) */
/* If ITYPE < 2, then TAU is not referenced. */
/* WORK (workspace) COMPLEX array, dimension (2*N**2) */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESULT (output) REAL array, dimension (2) */
/* The values computed by the two tests described above. The */
/* values are currently limited to 1/ulp, to avoid overflow. */
/* RESULT(1) is always modified. RESULT(2) is modified only */
/* if ITYPE=1. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
result[1] = 0.f;
if (*itype == 1) {
result[2] = 0.f;
}
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U")) {
lower = FALSE_;
*(unsigned char *)cuplo = 'U';
} else {
lower = TRUE_;
*(unsigned char *)cuplo = 'L';
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Epsilon") * slamch_("Base");
/* Some Error Checks */
if (*itype < 1 || *itype > 3) {
result[1] = 10.f / ulp;
return 0;
}
/* Do Test 1 */
/* Norm of A: */
if (*itype == 3) {
anorm = 1.f;
} else {
/* Computing MAX */
r__1 = clanhe_("1", cuplo, n, &a[a_offset], lda, &rwork[1]);
anorm = dmax(r__1,unfl);
}
/* Compute error matrix: */
if (*itype == 1) {
/* ITYPE=1: error = A - U S U* */
claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
clacpy_(cuplo, n, n, &a[a_offset], lda, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
r__1 = -d__[j];
cher_(cuplo, n, &r__1, &u[j * u_dim1 + 1], &c__1, &work[1], n);
/* L10: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
q__2.r = e[i__2], q__2.i = 0.f;
q__1.r = -q__2.r, q__1.i = -q__2.i;
cher2_(cuplo, n, &q__1, &u[j * u_dim1 + 1], &c__1, &u[(j - 1)
* u_dim1 + 1], &c__1, &work[1], n);
/* L20: */
}
}
wnorm = clanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
} else if (*itype == 2) {
/* ITYPE=2: error = V S V* - A */
claset_("Full", n, n, &c_b1, &c_b1, &work[1], n);
if (lower) {
/* Computing 2nd power */
i__2 = *n;
i__1 = i__2 * i__2;
i__3 = *n;
work[i__1].r = d__[i__3], work[i__1].i = 0.f;
for (j = *n - 1; j >= 1; --j) {
if (*kband == 1) {
i__1 = (*n + 1) * (j - 1) + 2;
i__2 = j;
q__2.r = 1.f - tau[i__2].r, q__2.i = 0.f - tau[i__2].i;
i__3 = j;
q__1.r = e[i__3] * q__2.r, q__1.i = e[i__3] * q__2.i;
work[i__1].r = q__1.r, work[i__1].i = q__1.i;
i__1 = *n;
for (jr = j + 2; jr <= i__1; ++jr) {
i__2 = (j - 1) * *n + jr;
i__3 = j;
q__3.r = -tau[i__3].r, q__3.i = -tau[i__3].i;
i__4 = j;
q__2.r = e[i__4] * q__3.r, q__2.i = e[i__4] * q__3.i;
i__5 = jr + j * v_dim1;
q__1.r = q__2.r * v[i__5].r - q__2.i * v[i__5].i,
q__1.i = q__2.r * v[i__5].i + q__2.i * v[i__5]
.r;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L30: */
}
}
i__1 = j + 1 + j * v_dim1;
vsave.r = v[i__1].r, vsave.i = v[i__1].i;
i__1 = j + 1 + j * v_dim1;
v[i__1].r = 1.f, v[i__1].i = 0.f;
i__1 = *n - j;
/* Computing 2nd power */
i__2 = *n;
clarfy_("L", &i__1, &v[j + 1 + j * v_dim1], &c__1, &tau[j], &
work[(*n + 1) * j + 1], n, &work[i__2 * i__2 + 1]);
i__1 = j + 1 + j * v_dim1;
v[i__1].r = vsave.r, v[i__1].i = vsave.i;
i__1 = (*n + 1) * (j - 1) + 1;
i__2 = j;
work[i__1].r = d__[i__2], work[i__1].i = 0.f;
/* L40: */
}
} else {
work[1].r = d__[1], work[1].i = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
if (*kband == 1) {
i__2 = (*n + 1) * j;
i__3 = j;
q__2.r = 1.f - tau[i__3].r, q__2.i = 0.f - tau[i__3].i;
i__4 = j;
q__1.r = e[i__4] * q__2.r, q__1.i = e[i__4] * q__2.i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
i__2 = j - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = j * *n + jr;
i__4 = j;
q__3.r = -tau[i__4].r, q__3.i = -tau[i__4].i;
i__5 = j;
q__2.r = e[i__5] * q__3.r, q__2.i = e[i__5] * q__3.i;
i__6 = jr + (j + 1) * v_dim1;
q__1.r = q__2.r * v[i__6].r - q__2.i * v[i__6].i,
q__1.i = q__2.r * v[i__6].i + q__2.i * v[i__6]
.r;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L50: */
}
}
i__2 = j + (j + 1) * v_dim1;
vsave.r = v[i__2].r, vsave.i = v[i__2].i;
i__2 = j + (j + 1) * v_dim1;
v[i__2].r = 1.f, v[i__2].i = 0.f;
/* Computing 2nd power */
i__2 = *n;
clarfy_("U", &j, &v[(j + 1) * v_dim1 + 1], &c__1, &tau[j], &
work[1], n, &work[i__2 * i__2 + 1]);
i__2 = j + (j + 1) * v_dim1;
v[i__2].r = vsave.r, v[i__2].i = vsave.i;
i__2 = (*n + 1) * j + 1;
i__3 = j + 1;
work[i__2].r = d__[i__3], work[i__2].i = 0.f;
/* L60: */
}
}
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
if (lower) {
i__2 = *n;
for (jrow = jcol; jrow <= i__2; ++jrow) {
i__3 = jrow + *n * (jcol - 1);
i__4 = jrow + *n * (jcol - 1);
i__5 = jrow + jcol * a_dim1;
q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L70: */
}
} else {
i__2 = jcol;
for (jrow = 1; jrow <= i__2; ++jrow) {
i__3 = jrow + *n * (jcol - 1);
i__4 = jrow + *n * (jcol - 1);
i__5 = jrow + jcol * a_dim1;
q__1.r = work[i__4].r - a[i__5].r, q__1.i = work[i__4].i
- a[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L80: */
}
}
/* L90: */
}
wnorm = clanhe_("1", cuplo, n, &work[1], n, &rwork[1]);
} else if (*itype == 3) {
/* ITYPE=3: error = U V* - I */
if (*n < 2) {
return 0;
}
clacpy_(" ", n, n, &u[u_offset], ldu, &work[1], n);
if (lower) {
i__1 = *n - 1;
i__2 = *n - 1;
/* Computing 2nd power */
i__3 = *n;
cunm2r_("R", "C", n, &i__1, &i__2, &v[v_dim1 + 2], ldv, &tau[1], &
work[*n + 1], n, &work[i__3 * i__3 + 1], &iinfo);
} else {
i__1 = *n - 1;
i__2 = *n - 1;
/* Computing 2nd power */
i__3 = *n;
cunm2l_("R", "C", n, &i__1, &i__2, &v[(v_dim1 << 1) + 1], ldv, &
tau[1], &work[1], n, &work[i__3 * i__3 + 1], &iinfo);
}
if (iinfo != 0) {
result[1] = 10.f / ulp;
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L100: */
}
wnorm = clange_("1", n, n, &work[1], n, &rwork[1]);
}
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *n * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*n);
result[1] = dmin(r__1,r__2) / (*n * ulp);
}
}
/* Do Test 2 */
/* Compute UU* - I */
if (*itype == 1) {
cgemm_("N", "C", n, n, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu,
&c_b1, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = (*n + 1) * (j - 1) + 1;
i__3 = (*n + 1) * (j - 1) + 1;
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i - 0.f;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L110: */
}
/* Computing MIN */
r__1 = clange_("1", n, n, &work[1], n, &rwork[1]), r__2 = (
real) (*n);
result[2] = dmin(r__1,r__2) / (*n * ulp);
}
return 0;
/* End of CHET21 */
} /* chet21_ */
/* Subroutine */ int crqt02_(integer *m, integer *n, integer *k, complex *a,
complex *af, complex *q, complex *r__, integer *lda, complex *tau,
complex *work, integer *lwork, real *rwork, real *result)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, q_dim1, q_offset, r_dim1,
r_offset, i__1, i__2;
/* Local variables */
real eps;
integer info;
real resid, anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CRQT02 tests CUNGRQ, which generates an m-by-n matrix Q with */
/* orthonornmal rows that is defined as the product of k elementary */
/* reflectors. */
/* Given the RQ factorization of an m-by-n matrix A, CRQT02 generates */
/* the orthogonal matrix Q defined by the factorization of the last k */
/* rows of A; it compares R(m-k+1:m,n-m+1:n) with */
/* A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are */
/* orthonormal. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix Q to be generated. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix Q to be generated. */
/* N >= M >= 0. */
/* K (input) INTEGER */
/* The number of elementary reflectors whose product defines the */
/* matrix Q. M >= K >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The m-by-n matrix A which was factorized by CRQT01. */
/* AF (input) COMPLEX array, dimension (LDA,N) */
/* Details of the RQ factorization of A, as returned by CGERQF. */
/* See CGERQF for further details. */
/* Q (workspace) COMPLEX array, dimension (LDA,N) */
/* R (workspace) COMPLEX array, dimension (LDA,M) */
/* LDA (input) INTEGER */
/* The leading dimension of the arrays A, AF, Q and L. LDA >= N. */
/* TAU (input) COMPLEX array, dimension (M) */
/* The scalar factors of the elementary reflectors corresponding */
/* to the RQ factorization in AF. */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The dimension of the array WORK. */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESULT (output) REAL array, dimension (2) */
/* The test ratios: */
/* RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) */
/* RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
r_dim1 = *lda;
r_offset = 1 + r_dim1;
r__ -= r_offset;
q_dim1 = *lda;
q_offset = 1 + q_dim1;
q -= q_offset;
af_dim1 = *lda;
af_offset = 1 + af_dim1;
af -= af_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
--rwork;
--result;
/* Function Body */
if (*m == 0 || *n == 0 || *k == 0) {
result[1] = 0.f;
result[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
/* Copy the last k rows of the factorization to the array Q */
claset_("Full", m, n, &c_b1, &c_b1, &q[q_offset], lda);
if (*k < *n) {
i__1 = *n - *k;
clacpy_("Full", k, &i__1, &af[*m - *k + 1 + af_dim1], lda, &q[*m - *k
+ 1 + q_dim1], lda);
}
if (*k > 1) {
i__1 = *k - 1;
i__2 = *k - 1;
clacpy_("Lower", &i__1, &i__2, &af[*m - *k + 2 + (*n - *k + 1) *
af_dim1], lda, &q[*m - *k + 2 + (*n - *k + 1) * q_dim1], lda);
}
/* Generate the last n rows of the matrix Q */
s_copy(srnamc_1.srnamt, "CUNGRQ", (ftnlen)32, (ftnlen)6);
cungrq_(m, n, k, &q[q_offset], lda, &tau[*m - *k + 1], &work[1], lwork, &
info);
/* Copy R(m-k+1:m,n-m+1:n) */
claset_("Full", k, m, &c_b9, &c_b9, &r__[*m - *k + 1 + (*n - *m + 1) *
r_dim1], lda);
clacpy_("Upper", k, k, &af[*m - *k + 1 + (*n - *k + 1) * af_dim1], lda, &
r__[*m - *k + 1 + (*n - *k + 1) * r_dim1], lda);
/* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' */
cgemm_("No transpose", "Conjugate transpose", k, m, n, &c_b14, &a[*m - *k
+ 1 + a_dim1], lda, &q[q_offset], lda, &c_b15, &r__[*m - *k + 1 +
(*n - *m + 1) * r_dim1], lda);
/* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . */
anorm = clange_("1", k, n, &a[*m - *k + 1 + a_dim1], lda, &rwork[1]);
resid = clange_("1", k, m, &r__[*m - *k + 1 + (*n - *m + 1) * r_dim1],
lda, &rwork[1]);
if (anorm > 0.f) {
result[1] = resid / (real) max(1,*n) / anorm / eps;
} else {
result[1] = 0.f;
}
/* Compute I - Q*Q' */
claset_("Full", m, m, &c_b9, &c_b15, &r__[r_offset], lda);
cherk_("Upper", "No transpose", m, n, &c_b23, &q[q_offset], lda, &c_b24, &
r__[r_offset], lda);
/* Compute norm( I - Q*Q' ) / ( N * EPS ) . */
resid = clansy_("1", "Upper", m, &r__[r_offset], lda, &rwork[1]);
result[2] = resid / (real) max(1,*n) / eps;
return 0;
/* End of CRQT02 */
} /* crqt02_ */
/* Subroutine */ int cheevx_(char *jobz, char *range, char *uplo, integer *n,
complex *a, integer *lda, real *vl, real *vu, integer *il, integer *
iu, real *abstol, integer *m, real *w, complex *z__, integer *ldz,
complex *work, integer *lwork, real *rwork, integer *iwork, integer *
ifail, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, nb, jj;
real eps, vll, vuu, tmp1;
integer indd, inde;
real anrm;
integer imax;
real rmin, rmax;
logical test;
integer itmp1, indee;
real sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
char order[1];
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
logical lower;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
logical wantz;
extern doublereal clanhe_(char *, char *, integer *, complex *, integer *,
real *);
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
extern doublereal slamch_(char *);
extern /* Subroutine */ int chetrd_(char *, integer *, complex *, integer
*, real *, real *, complex *, complex *, integer *, integer *), csscal_(integer *, real *, complex *, integer *),
clacpy_(char *, integer *, integer *, complex *, integer *,
complex *, integer *);
real safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real abstll, bignum;
integer indiwk, indisp, indtau;
extern /* Subroutine */ int cstein_(integer *, real *, real *, integer *,
real *, integer *, integer *, complex *, integer *, real *,
integer *, integer *, integer *);
integer indrwk, indwrk, lwkmin;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), cungtr_(char *,
integer *, complex *, integer *, complex *, complex *, integer *,
integer *), ssterf_(integer *, real *, real *, integer *),
cunmtr_(char *, char *, char *, integer *, integer *, complex *,
integer *, complex *, complex *, integer *, complex *, integer *,
integer *);
integer nsplit, llwork;
real smlnum;
extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
real *, integer *, integer *, real *, real *, real *, integer *,
integer *, real *, integer *, integer *, real *, integer *,
integer *);
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHEEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a complex Hermitian matrix A. Eigenvalues and eigenvectors can */
/* be selected by specifying either a range of values or a range of */
/* indices for the desired eigenvalues. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found. */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found. */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA, N) */
/* On entry, the Hermitian matrix A. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of A contains the */
/* upper triangular part of the matrix A. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, the lower triangle (if UPLO='L') or the upper */
/* triangle (if UPLO='U') of A, including the diagonal, is */
/* destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) REAL */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing A to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*SLAMCH('S'). */
/* See "Computing Small Singular Values of Bidiagonal Matrices */
/* with Guaranteed High Relative Accuracy," by Demmel and */
/* Kahan, LAPACK Working Note #3. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* On normal exit, the first M elements contain the selected */
/* eigenvalues in ascending order. */
/* Z (output) COMPLEX array, dimension (LDZ, max(1,M)) */
/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix A */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If an eigenvector fails to converge, then that column of Z */
/* contains the latest approximation to the eigenvector, and the */
/* index of the eigenvector is returned in IFAIL. */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= 1, when N <= 1; */
/* otherwise 2*N. */
/* For optimal efficiency, LWORK >= (NB+1)*N, */
/* where NB is the max of the blocksize for CHETRD and for */
/* CUNMTR as returned by ILAENV. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* RWORK (workspace) REAL array, dimension (7*N) */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (N) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvectors that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, then i eigenvectors failed to converge. */
/* Their indices are stored in array IFAIL. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1;
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -8;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -9;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -10;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -15;
}
}
if (*info == 0) {
if (*n <= 1) {
lwkmin = 1;
work[1].r = (real) lwkmin, work[1].i = 0.f;
} else {
lwkmin = *n << 1;
nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "CUNMTR", uplo, n, &c_n1, &c_n1,
&c_n1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = (nb + 1) * *n;
lwkopt = max(i__1,i__2);
work[1].r = (real) lwkopt, work[1].i = 0.f;
}
if (*lwork < lwkmin && ! lquery) {
*info = -17;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
} else if (valeig) {
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
if (*vl < a[i__1].r && *vu >= a[i__2].r) {
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
}
}
if (wantz) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = clanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
csscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call CHETRD to reduce Hermitian matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
chetrd_(uplo, n, &a[a_offset], lda, &rwork[indd], &rwork[inde], &work[
indtau], &work[indwrk], &llwork, &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal to */
/* zero, then call SSTERF or CUNGTR and CSTEQR. If this fails for */
/* some eigenvalue, then try SSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.f) {
scopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
ssterf_(n, &w[1], &rwork[indee], info);
} else {
clacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
cungtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk]
, &llwork, &iinfo);
i__1 = *n - 1;
scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
csteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
rwork[indrwk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L30: */
}
}
}
if (*info == 0) {
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
rwork[indrwk], &iwork[indiwk], info);
if (wantz) {
cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
indiwk], &ifail[1], info);
/* Apply unitary matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by CSTEIN. */
cunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
z_offset], ldz, &work[indwrk], &llwork, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L40:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L50: */
}
if (i__ != 0) {
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal complex workspace size. */
work[1].r = (real) lwkopt, work[1].i = 0.f;
return 0;
/* End of CHEEVX */
} /* cheevx_ */
/* Subroutine */ int ctimqr_(char *line, integer *nm, integer *mval, integer *
nval, integer *nk, integer *kval, integer *nnb, integer *nbval,
integer *nxval, integer *nlda, integer *ldaval, real *timmin, complex
*a, complex *tau, complex *b, complex *work, real *rwork, real *
reslts, integer *ldr1, integer *ldr2, integer *ldr3, integer *nout,
ftnlen line_len)
{
/* Initialized data */
static char subnam[6*3] = "CGEQRF" "CUNGQR" "CUNMQR";
static char sides[1*2] = "L" "R";
static char transs[1*2] = "N" "C";
static integer iseed[4] = { 0,0,0,1 };
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 timing run not attempted\002,/)";
static char fmt_9998[] = "(/\002 *** Speed of \002,a6,\002 in megaflops "
"***\002)";
static char fmt_9997[] = "(5x,\002line \002,i2,\002 with LDA = \002,i5)";
static char fmt_9996[] = "(5x,\002K = min(M,N)\002,/)";
static char fmt_9995[] = "(/5x,a6,\002 with SIDE = '\002,a1,\002', TRANS"
" = '\002,a1,\002', \002,a1,\002 =\002,i6,/)";
static char fmt_9994[] = "(\002 *** No pairs (M,N) found with M >= N: "
" \002,a6,\002 not timed\002)";
/* System generated locals */
integer reslts_dim1, reslts_dim2, reslts_dim3, reslts_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer ilda;
static char labm[1], side[1];
static integer info;
static char path[3];
static real time;
static integer isub, muse[12], nuse[12], i__, k, m, n;
static char cname[6];
static integer iside, itoff, itran, minmn;
extern doublereal sopla_(char *, integer *, integer *, integer *, integer
*, integer *);
extern /* Subroutine */ int icopy_(integer *, integer *, integer *,
integer *, integer *);
static char trans[1];
static integer k1, i4, m1, n1;
static real s1, s2;
static integer ic;
extern /* Subroutine */ int sprtb4_(char *, char *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
real *, integer *, integer *, integer *, ftnlen, ftnlen, ftnlen),
sprtb5_(char *, char *, char *, integer *, integer *, integer *,
integer *, integer *, integer *, real *, integer *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static integer nb, ik, im, lw, nx, reseed[4];
extern /* Subroutine */ int atimck_(integer *, char *, integer *, integer
*, integer *, integer *, integer *, integer *, ftnlen), cgeqrf_(
integer *, integer *, complex *, integer *, complex *, complex *,
integer *, integer *);
extern doublereal second_(void);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), ctimmg_(integer *,
integer *, integer *, complex *, integer *, integer *, integer *),
atimin_(char *, char *, integer *, char *, logical *, integer *,
integer *, ftnlen, ftnlen, ftnlen), clatms_(integer *, integer *,
char *, integer *, char *, real *, integer *, real *, real *,
integer *, integer *, char *, complex *, integer *, complex *,
integer *), xlaenv_(integer *, integer *);
extern doublereal smflop_(real *, real *, integer *);
static real untime;
extern /* Subroutine */ int cungqr_(integer *, integer *, integer *,
complex *, integer *, complex *, complex *, integer *, integer *);
static logical timsub[3];
extern /* Subroutine */ int cunmqr_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, complex *, integer *,
complex *, integer *, integer *);
static integer lda, icl, inb, imx;
static real ops;
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 0, 0, 0, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9994, 0 };
#define subnam_ref(a_0,a_1) &subnam[(a_1)*6 + a_0 - 6]
#define reslts_ref(a_1,a_2,a_3,a_4) reslts[(((a_4)*reslts_dim3 + (a_3))*\
reslts_dim2 + (a_2))*reslts_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
CTIMQR times the LAPACK routines to perform the QR factorization of
a COMPLEX general matrix.
Arguments
=========
LINE (input) CHARACTER*80
The input line that requested this routine. The first six
characters contain either the name of a subroutine or a
generic path name. The remaining characters may be used to
specify the individual routines to be timed. See ATIMIN for
a full description of the format of the input line.
NM (input) INTEGER
The number of values of M and N contained in the vectors
MVAL and NVAL. The matrix sizes are used in pairs (M,N).
MVAL (input) INTEGER array, dimension (NM)
The values of the matrix row dimension M.
NVAL (input) INTEGER array, dimension (NM)
The values of the matrix column dimension N.
NK (input) INTEGER
The number of values of K in the vector KVAL.
KVAL (input) INTEGER array, dimension (NK)
The values of the matrix dimension K, used in CUNMQR.
NNB (input) INTEGER
The number of values of NB and NX contained in the
vectors NBVAL and NXVAL. The blocking parameters are used
in pairs (NB,NX).
NBVAL (input) INTEGER array, dimension (NNB)
The values of the blocksize NB.
NXVAL (input) INTEGER array, dimension (NNB)
The values of the crossover point NX.
NLDA (input) INTEGER
The number of values of LDA contained in the vector LDAVAL.
LDAVAL (input) INTEGER array, dimension (NLDA)
The values of the leading dimension of the array A.
TIMMIN (input) REAL
The minimum time a subroutine will be timed.
A (workspace) COMPLEX array, dimension (LDAMAX*NMAX)
where LDAMAX and NMAX are the maximum values of LDA and N.
TAU (workspace) COMPLEX array, dimension (min(M,N))
B (workspace) COMPLEX array, dimension (LDAMAX*NMAX)
WORK (workspace) COMPLEX array, dimension (LDAMAX*NBMAX)
where NBMAX is the maximum value of NB.
RWORK (workspace) REAL array, dimension
(min(MMAX,NMAX))
RESLTS (workspace) REAL array, dimension
(LDR1,LDR2,LDR3,2*NK)
The timing results for each subroutine over the relevant
values of (M,N), (NB,NX), and LDA.
LDR1 (input) INTEGER
The first dimension of RESLTS. LDR1 >= max(1,NNB).
LDR2 (input) INTEGER
The second dimension of RESLTS. LDR2 >= max(1,NM).
LDR3 (input) INTEGER
The third dimension of RESLTS. LDR3 >= max(1,NLDA).
NOUT (input) INTEGER
The unit number for output.
Internal Parameters
===================
MODE INTEGER
The matrix type. MODE = 3 is a geometric distribution of
eigenvalues. See CLATMS for further details.
COND REAL
The condition number of the matrix. The singular values are
set to values from DMAX to DMAX/COND.
DMAX REAL
The magnitude of the largest singular value.
=====================================================================
Parameter adjustments */
--mval;
--nval;
--kval;
--nbval;
--nxval;
--ldaval;
--a;
--tau;
--b;
--work;
--rwork;
reslts_dim1 = *ldr1;
reslts_dim2 = *ldr2;
reslts_dim3 = *ldr3;
reslts_offset = 1 + reslts_dim1 * (1 + reslts_dim2 * (1 + reslts_dim3 * 1)
);
reslts -= reslts_offset;
/* Function Body
Extract the timing request from the input line. */
s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
s_copy(path + 1, "QR", (ftnlen)2, (ftnlen)2);
atimin_(path, line, &c__3, subnam, timsub, nout, &info, (ftnlen)3, (
ftnlen)80, (ftnlen)6);
if (info != 0) {
goto L230;
}
/* Check that M <= LDA for the input values. */
s_copy(cname, line, (ftnlen)6, (ftnlen)6);
atimck_(&c__1, cname, nm, &mval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, cname, (ftnlen)6);
e_wsfe();
goto L230;
}
/* Do for each pair of values (M,N): */
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
m = mval[im];
n = nval[im];
minmn = min(m,n);
icopy_(&c__4, iseed, &c__1, reseed, &c__1);
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
/* Do for each pair of values (NB, NX) in NBVAL and NXVAL. */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Computing MAX */
i__4 = 1, i__5 = n * max(1,nb);
lw = max(i__4,i__5);
icopy_(&c__4, reseed, &c__1, iseed, &c__1);
/* Generate a test matrix of size M by N. */
clatms_(&m, &n, "Uniform", iseed, "Nonsymm", &rwork[1], &c__3,
&c_b24, &c_b25, &m, &n, "No packing", &b[1], &lda, &
work[1], &info);
if (timsub[0]) {
/* CGEQRF: QR factorization */
clacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
ic = 0;
s1 = second_();
L10:
cgeqrf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &
info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
clacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
goto L10;
}
/* Subtract the time used in CLACPY. */
icl = 1;
s1 = second_();
L20:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
clacpy_("Full", &m, &n, &a[1], &lda, &b[1], &lda);
goto L20;
}
time = (time - untime) / (real) ic;
ops = sopla_("CGEQRF", &m, &n, &c__0, &c__0, &nb);
reslts_ref(inb, im, ilda, 1) = smflop_(&ops, &time, &info)
;
} else {
/* If CGEQRF was not timed, generate a matrix and factor
it using CGEQRF anyway so that the factored form of
the matrix can be used in timing the other routines. */
clacpy_("Full", &m, &n, &b[1], &lda, &a[1], &lda);
cgeqrf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &
info);
}
if (timsub[1]) {
/* CUNGQR: Generate orthogonal matrix Q from the QR
factorization */
clacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
ic = 0;
s1 = second_();
L30:
cungqr_(&m, &minmn, &minmn, &b[1], &lda, &tau[1], &work[1]
, &lw, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
clacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
goto L30;
}
/* Subtract the time used in CLACPY. */
icl = 1;
s1 = second_();
L40:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
clacpy_("Full", &m, &minmn, &a[1], &lda, &b[1], &lda);
goto L40;
}
time = (time - untime) / (real) ic;
ops = sopla_("CUNGQR", &m, &minmn, &minmn, &c__0, &nb);
reslts_ref(inb, im, ilda, 2) = smflop_(&ops, &time, &info)
;
}
/* L50: */
}
/* L60: */
}
/* L70: */
}
/* Print tables of results */
for (isub = 1; isub <= 2; ++isub) {
if (! timsub[isub - 1]) {
goto L90;
}
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
if (*nlda > 1) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)sizeof(integer));
e_wsfe();
/* L80: */
}
}
io___32.ciunit = *nout;
s_wsle(&io___32);
e_wsle();
if (isub == 2) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
e_wsfe();
}
sprtb4_("( NB, NX)", "M", "N", nnb, &nbval[1], &nxval[1], nm, &mval[
1], &nval[1], nlda, &reslts_ref(1, 1, 1, isub), ldr1, ldr2,
nout, (ftnlen)11, (ftnlen)1, (ftnlen)1);
L90:
;
}
/* Time CUNMQR separately. Here the starting matrix is M by N, and
K is the free dimension of the matrix multiplied by Q. */
if (timsub[2]) {
/* Check that K <= LDA for the input values. */
atimck_(&c__3, cname, nk, &kval[1], nlda, &ldaval[1], nout, &info, (
ftnlen)6);
if (info > 0) {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, subnam_ref(0, 3), (ftnlen)6);
e_wsfe();
goto L230;
}
/* Use only the pairs (M,N) where M >= N. */
imx = 0;
i__1 = *nm;
for (im = 1; im <= i__1; ++im) {
if (mval[im] >= nval[im]) {
++imx;
muse[imx - 1] = mval[im];
nuse[imx - 1] = nval[im];
}
/* L100: */
}
/* CUNMQR: Multiply by Q stored as a product of elementary
transformations
Do for each pair of values (M,N): */
i__1 = imx;
for (im = 1; im <= i__1; ++im) {
m = muse[im - 1];
n = nuse[im - 1];
/* Do for each value of LDA: */
i__2 = *nlda;
for (ilda = 1; ilda <= i__2; ++ilda) {
lda = ldaval[ilda];
/* Generate an M by N matrix and form its QR decomposition. */
clatms_(&m, &n, "Uniform", iseed, "Nonsymm", &rwork[1], &c__3,
&c_b24, &c_b25, &m, &n, "No packing", &a[1], &lda, &
work[1], &info);
/* Computing MAX */
i__3 = 1, i__4 = n * max(1,nb);
lw = max(i__3,i__4);
cgeqrf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lw, &info);
/* Do first for SIDE = 'L', then for SIDE = 'R' */
i4 = 0;
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside -
1];
/* Do for each pair of values (NB, NX) in NBVAL and
NXVAL. */
i__3 = *nnb;
for (inb = 1; inb <= i__3; ++inb) {
nb = nbval[inb];
xlaenv_(&c__1, &nb);
nx = nxval[inb];
xlaenv_(&c__3, &nx);
/* Do for each value of K in KVAL */
i__4 = *nk;
for (ik = 1; ik <= i__4; ++ik) {
k = kval[ik];
/* Sort out which variable is which */
if (iside == 1) {
m1 = m;
k1 = n;
n1 = k;
/* Computing MAX */
i__5 = 1, i__6 = n1 * max(1,nb);
lw = max(i__5,i__6);
} else {
n1 = m;
k1 = n;
m1 = k;
/* Computing MAX */
i__5 = 1, i__6 = m1 * max(1,nb);
lw = max(i__5,i__6);
}
/* Do first for TRANS = 'N', then for TRANS = 'T' */
itoff = 0;
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&
transs[itran - 1];
ctimmg_(&c__0, &m1, &n1, &b[1], &lda, &c__0, &
c__0);
ic = 0;
s1 = second_();
L110:
cunmqr_(side, trans, &m1, &n1, &k1, &a[1], &
lda, &tau[1], &b[1], &lda, &work[1], &
lw, &info);
s2 = second_();
time = s2 - s1;
++ic;
if (time < *timmin) {
ctimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L110;
}
/* Subtract the time used in CTIMMG. */
icl = 1;
s1 = second_();
L120:
s2 = second_();
untime = s2 - s1;
++icl;
if (icl <= ic) {
ctimmg_(&c__0, &m1, &n1, &b[1], &lda, &
c__0, &c__0);
goto L120;
}
time = (time - untime) / (real) ic;
i__5 = iside - 1;
ops = sopla_("CUNMQR", &m1, &n1, &k1, &i__5, &
nb);
reslts_ref(inb, im, ilda, i4 + itoff + ik) =
smflop_(&ops, &time, &info);
itoff = *nk;
/* L130: */
}
/* L140: */
}
/* L150: */
}
i4 = *nk << 1;
/* L160: */
}
/* L170: */
}
/* L180: */
}
/* Print tables of results */
isub = 3;
i4 = 1;
if (imx >= 1) {
for (iside = 1; iside <= 2; ++iside) {
*(unsigned char *)side = *(unsigned char *)&sides[iside - 1];
if (iside == 1) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
if (*nlda > 1) {
i__1 = *nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&ldaval[i__], (ftnlen)
sizeof(integer));
e_wsfe();
/* L190: */
}
}
}
for (itran = 1; itran <= 2; ++itran) {
*(unsigned char *)trans = *(unsigned char *)&transs[itran
- 1];
i__1 = *nk;
for (ik = 1; ik <= i__1; ++ik) {
if (iside == 1) {
n = kval[ik];
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
e_wsfe();
*(unsigned char *)labm = 'M';
} else {
m = kval[ik];
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
do_fio(&c__1, side, (ftnlen)1);
do_fio(&c__1, trans, (ftnlen)1);
do_fio(&c__1, "M", (ftnlen)1);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer))
;
e_wsfe();
*(unsigned char *)labm = 'N';
}
sprtb5_("NB", labm, "K", nnb, &nbval[1], &imx, muse,
nuse, nlda, &reslts_ref(1, 1, 1, i4), ldr1,
ldr2, nout, (ftnlen)2, (ftnlen)1, (ftnlen)1);
++i4;
/* L200: */
}
/* L210: */
}
/* L220: */
}
} else {
io___54.ciunit = *nout;
s_wsfe(&io___54);
do_fio(&c__1, subnam_ref(0, isub), (ftnlen)6);
e_wsfe();
}
}
L230:
return 0;
/* End of CTIMQR */
} /* ctimqr_ */
