/* Subroutine */ int ctrti2_(char *uplo, char *diag, integer *n, complex *a,
integer *lda, integer *info)
{
/* -- LAPACK 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
=======
CTRTI2 computes the inverse of a complex upper or lower triangular
matrix.
This is the Level 2 BLAS version of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the matrix A is upper or lower triangular.
= 'U': Upper triangular
= 'L': Lower triangular
DIAG (input) CHARACTER*1
Specifies whether or not the matrix A is unit triangular.
= 'N': Non-unit triangular
= 'U': Unit triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the triangular matrix A. If UPLO = 'U', the
leading n by n upper triangular part of the array A contains
the upper triangular matrix, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading n by n lower triangular part of the array A contains
the lower triangular matrix, and the strictly upper
triangular part of A is not referenced. If DIAG = 'U', the
diagonal elements of A are also not referenced and are
assumed to be 1.
On exit, the (triangular) inverse of the original matrix, in
the same storage format.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -k, the k-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
complex q__1;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
static integer j;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), xerbla_(char *, integer *);
static logical nounit;
static complex ajj;
#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)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRTI2", &i__1);
return 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
i__2 = a_subscr(j, j);
c_div(&q__1, &c_b1, &a_ref(j, j));
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = a_subscr(j, j);
q__1.r = -a[i__2].r, q__1.i = -a[i__2].i;
ajj.r = q__1.r, ajj.i = q__1.i;
} else {
q__1.r = -1.f, q__1.i = 0.f;
ajj.r = q__1.r, ajj.i = q__1.i;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
ctrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
a_ref(1, j), &c__1);
i__2 = j - 1;
cscal_(&i__2, &ajj, &a_ref(1, j), &c__1);
/* L10: */
}
} else {
/* Compute inverse of lower triangular matrix. */
for (j = *n; j >= 1; --j) {
if (nounit) {
i__1 = a_subscr(j, j);
c_div(&q__1, &c_b1, &a_ref(j, j));
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = a_subscr(j, j);
q__1.r = -a[i__1].r, q__1.i = -a[i__1].i;
ajj.r = q__1.r, ajj.i = q__1.i;
} else {
q__1.r = -1.f, q__1.i = 0.f;
ajj.r = q__1.r, ajj.i = q__1.i;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
ctrmv_("Lower", "No transpose", diag, &i__1, &a_ref(j + 1, j
+ 1), lda, &a_ref(j + 1, j), &c__1);
i__1 = *n - j;
cscal_(&i__1, &ajj, &a_ref(j + 1, j), &c__1);
}
/* L20: */
}
}
return 0;
/* End of CTRTI2 */
} /* ctrti2_ */
/* Subroutine */ int ctrt03_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *a, integer *lda, real *scale, real *cnorm,
real *tscal, complex *x, integer *ldx, complex *b, integer *ldb,
complex *work, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
real r__1, r__2;
complex q__1;
/* Local variables */
integer j, ix;
real eps, err;
real xscal;
real tnorm, xnorm;
real smlnum;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTRT03 computes the residual for the solution to a scaled triangular */
/* system of equations A*x = s*b, A**T *x = s*b, or A**H *x = s*b. */
/* Here A is a triangular matrix, A**T denotes the transpose of A, A**H */
/* denotes the conjugate transpose of A, s is a scalar, and x and b are */
/* N by NRHS matrices. The test ratio is the maximum over the number of */
/* right hand sides of */
/* norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ), */
/* where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': A *x = s*b (No transpose) */
/* = 'T': A**T *x = s*b (Transpose) */
/* = 'C': A**H *x = s*b (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* 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 X and B. NRHS >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* SCALE (input) REAL */
/* The scaling factor s used in solving the triangular system. */
/* CNORM (input) REAL array, dimension (N) */
/* The 1-norms of the columns of A, not counting the diagonal. */
/* TSCAL (input) REAL */
/* The scaling factor used in computing the 1-norms in CNORM. */
/* CNORM actually contains the column norms of TSCAL*A. */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The computed solution vectors for the system of linear */
/* equations. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* B (input) COMPLEX array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* WORK (workspace) COMPLEX array, dimension (N) */
/* RESID (output) REAL */
/* The maximum over the number of right hand sides of */
/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--cnorm;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--work;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
*resid = 0.f;
return 0;
}
eps = slamch_("Epsilon");
smlnum = slamch_("Safe minimum");
/* Compute the norm of the triangular matrix A using the column */
/* norms already computed by CLATRS. */
tnorm = 0.f;
if (lsame_(diag, "N")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal * c_abs(&a[j + j * a_dim1]) + cnorm[j]
;
tnorm = dmax(r__1,r__2);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
r__1 = tnorm, r__2 = *tscal + cnorm[j];
tnorm = dmax(r__1,r__2);
/* L20: */
}
}
/* Compute the maximum over the number of right hand sides of */
/* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ). */
*resid = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ix = icamax_(n, &work[1], &c__1);
/* Computing MAX */
r__1 = 1.f, r__2 = c_abs(&x[ix + j * x_dim1]);
xnorm = dmax(r__1,r__2);
xscal = 1.f / xnorm / (real) (*n);
csscal_(n, &xscal, &work[1], &c__1);
ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
r__1 = -(*scale) * xscal;
q__1.r = r__1, q__1.i = 0.f;
caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
ix = icamax_(n, &work[1], &c__1);
err = *tscal * c_abs(&work[ix]);
ix = icamax_(n, &x[j * x_dim1 + 1], &c__1);
xnorm = c_abs(&x[ix + j * x_dim1]);
if (err * smlnum <= xnorm) {
if (xnorm > 0.f) {
err /= xnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
if (err * smlnum <= tnorm) {
if (tnorm > 0.f) {
err /= tnorm;
}
} else {
if (err > 0.f) {
err = 1.f / eps;
}
}
*resid = dmax(*resid,err);
/* L30: */
}
return 0;
/* End of CTRT03 */
} /* ctrt03_ */
/* Subroutine */ int clahrd_(integer *n, integer *k, integer *nb, complex *a,
integer *lda, complex *tau, complex *t, integer *ldt, complex *y,
integer *ldy)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)
matrix A so that elements below the k-th subdiagonal are zero. The
reduction is performed by a unitary similarity transformation
Q' * A * Q. The routine returns the matrices V and T which determine
Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
This is an auxiliary routine called by CGEHRD.
Arguments
=========
N (input) INTEGER
The order of the matrix A.
K (input) INTEGER
The offset for the reduction. Elements below the k-th
subdiagonal in the first NB columns are reduced to zero.
NB (input) INTEGER
The number of columns to be reduced.
A (input/output) COMPLEX array, dimension (LDA,N-K+1)
On entry, the n-by-(n-k+1) general matrix A.
On exit, the elements on and above the k-th subdiagonal in
the first NB columns are overwritten with the corresponding
elements of the reduced matrix; the elements below the k-th
subdiagonal, with the array TAU, represent the matrix Q as a
product of elementary reflectors. The other columns of A are
unchanged. See Further Details.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
TAU (output) COMPLEX array, dimension (NB)
The scalar factors of the elementary reflectors. See Further
Details.
T (output) COMPLEX array, dimension (LDT,NB)
The upper triangular matrix T.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= NB.
Y (output) COMPLEX array, dimension (LDY,NB)
The n-by-nb matrix Y.
LDY (input) INTEGER
The leading dimension of the array Y. LDY >= max(1,N).
Further Details
===============
The matrix Q is represented as a product of nb elementary reflectors
Q = H(1) H(2) . . . H(nb).
Each H(i) has the form
H(i) = I - tau * v * v'
where tau is a complex scalar, and v is a complex vector with
v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
A(i+k+1:n,i), and tau in TAU(i).
The elements of the vectors v together form the (n-k+1)-by-nb matrix
V which is needed, with T and Y, to apply the transformation to the
unreduced part of the matrix, using an update of the form:
A := (I - V*T*V') * (A - Y*V').
The contents of A on exit are illustrated by the following example
with n = 7, k = 3 and nb = 2:
( a h a a a )
( a h a a a )
( a h a a a )
( h h a a a )
( v1 h a a a )
( v1 v2 a a a )
( v1 v2 a a a )
where a denotes an element of the original matrix A, h denotes a
modified element of the upper Hessenberg matrix H, and vi denotes an
element of the vector defining H(i).
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {0.f,0.f};
static complex c_b2 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
complex q__1;
/* Local variables */
static integer i__;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgemv_(char *, integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), ctrmv_(char *, char *, char *,
integer *, complex *, integer *, complex *, integer *);
static complex ei;
extern /* Subroutine */ int clarfg_(integer *, complex *, complex *,
integer *, complex *), clacgv_(integer *, complex *, integer *);
#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 t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1
#define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)]
#define y_subscr(a_1,a_2) (a_2)*y_dim1 + a_1
#define y_ref(a_1,a_2) y[y_subscr(a_1,a_2)]
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1 * 1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(1:n,i)
Compute i-th column of A - Y * V' */
i__2 = i__ - 1;
clacgv_(&i__2, &a_ref(*k + i__ - 1, 1), lda);
i__2 = i__ - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("No transpose", n, &i__2, &q__1, &y[y_offset], ldy, &a_ref(
*k + i__ - 1, 1), lda, &c_b2, &a_ref(1, i__), &c__1);
i__2 = i__ - 1;
clacgv_(&i__2, &a_ref(*k + i__ - 1, 1), lda);
/* Apply I - V * T' * V' to this column (call it b) from the
left, using the last column of T as workspace
Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
( V2 ) ( b2 )
where V1 is unit lower triangular
w := V1' * b1 */
i__2 = i__ - 1;
ccopy_(&i__2, &a_ref(*k + 1, i__), &c__1, &t_ref(1, *nb), &c__1);
i__2 = i__ - 1;
ctrmv_("Lower", "Conjugate transpose", "Unit", &i__2, &a_ref(*k +
1, 1), lda, &t_ref(1, *nb), &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a_ref(*k +
i__, 1), lda, &a_ref(*k + i__, i__), &c__1, &c_b2, &t_ref(
1, *nb), &c__1);
/* w := T'*w */
i__2 = i__ - 1;
ctrmv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t_ref(1, *nb), &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a_ref(*k + i__, 1),
lda, &t_ref(1, *nb), &c__1, &c_b2, &a_ref(*k + i__, i__),
&c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
ctrmv_("Lower", "No transpose", "Unit", &i__2, &a_ref(*k + 1, 1),
lda, &t_ref(1, *nb), &c__1);
i__2 = i__ - 1;
q__1.r = -1.f, q__1.i = 0.f;
caxpy_(&i__2, &q__1, &t_ref(1, *nb), &c__1, &a_ref(*k + 1, i__), &
c__1);
i__2 = a_subscr(*k + i__ - 1, i__ - 1);
a[i__2].r = ei.r, a[i__2].i = ei.i;
}
/* Generate the elementary reflector H(i) to annihilate
A(k+i+1:n,i) */
i__2 = a_subscr(*k + i__, i__);
ei.r = a[i__2].r, ei.i = a[i__2].i;
/* Computing MIN */
i__2 = *k + i__ + 1;
i__3 = *n - *k - i__ + 1;
clarfg_(&i__3, &ei, &a_ref(min(i__2,*n), i__), &c__1, &tau[i__]);
i__2 = a_subscr(*k + i__, i__);
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Compute Y(1:n,i) */
i__2 = *n - *k - i__ + 1;
cgemv_("No transpose", n, &i__2, &c_b2, &a_ref(1, i__ + 1), lda, &
a_ref(*k + i__, i__), &c__1, &c_b1, &y_ref(1, i__), &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a_ref(*k + i__, 1)
, lda, &a_ref(*k + i__, i__), &c__1, &c_b1, &t_ref(1, i__), &
c__1);
i__2 = i__ - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("No transpose", n, &i__2, &q__1, &y[y_offset], ldy, &t_ref(1,
i__), &c__1, &c_b2, &y_ref(1, i__), &c__1);
cscal_(n, &tau[i__], &y_ref(1, i__), &c__1);
/* Compute T(1:i,i) */
i__2 = i__ - 1;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cscal_(&i__2, &q__1, &t_ref(1, i__), &c__1);
i__2 = i__ - 1;
ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[t_offset], ldt,
&t_ref(1, i__), &c__1);
i__2 = t_subscr(i__, i__);
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
/* L10: */
}
i__1 = a_subscr(*k + *nb, *nb);
a[i__1].r = ei.r, a[i__1].i = ei.i;
return 0;
/* End of CLAHRD */
} /* clahrd_ */
/* Subroutine */ int ctrrfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb,
complex *x, integer *ldx, real *ferr, real *berr, complex *work, 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
September 30, 1994
Purpose
=======
CTRRFS provides error bounds and backward error estimates for the
solution to a system of linear equations with a triangular
coefficient matrix.
The solution matrix X must be computed by CTRTRS or some other
means before entering this routine. CTRRFS does not do iterative
refinement because doing so cannot improve the backward error.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose)
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
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) COMPLEX array, dimension (LDA,N)
The triangular matrix A. If UPLO = 'U', the leading N-by-N
upper triangular part of the array A contains the upper
triangular matrix, and the strictly lower triangular part of
A is not referenced. If UPLO = 'L', the leading N-by-N lower
triangular part of the array A contains the lower triangular
matrix, and the strictly upper triangular part of A is not
referenced. If DIAG = 'U', the diagonal elements of A are
also not referenced and are assumed to be 1.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) COMPLEX array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX array, dimension (LDX,NRHS)
The solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
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
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2,
i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j, k;
static real s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *,
integer *, complex *, integer *), clacon_(
integer *, complex *, complex *, real *, integer *);
static real xk;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static char transn[1], transt[1];
static logical nounit;
static real lstres, 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 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 x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldx < max(1,*n)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
ccopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
q__1.r = -1.f, q__1.i = 0.f;
caxpy_(n, &q__1, &b_ref(1, j), &c__1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matrix
or vector Z. If the i-th component of the denominator is less
than SAFE2, then SAFE1 is added to the i-th components of the
numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(i__, j)), dabs(r__2));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a_ref(i__, k)), dabs(r__2))
) * xk;
/* L30: */
}
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a_ref(i__, k)), dabs(r__2))
) * xk;
/* L50: */
}
rwork[k] += xk;
/* L60: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a_ref(i__, k)), dabs(r__2))
) * xk;
/* L70: */
}
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
rwork[i__] += ((r__1 = a[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&a_ref(i__, k)), dabs(r__2))
) * xk;
/* L90: */
}
rwork[k] += xk;
/* L100: */
}
}
}
} else {
/* Compute abs(A**H)*abs(X) + abs(B). */
if (upper) {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a_ref(i__, k)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L110: */
}
rwork[k] += s;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a_ref(i__, k)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L130: */
}
rwork[k] += s;
/* L140: */
}
}
} else {
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a_ref(i__, k)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L150: */
}
rwork[k] += s;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = a_subscr(i__, k);
i__5 = x_subscr(i__, j);
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a_ref(i__, k)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L170: */
}
rwork[k] += s;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__4);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix or
vector Z
NZ is the maximum number of nonzeros in any row of A, plus 1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use CLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
ctrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[1], &
c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L230: */
}
ctrsv_(uplo, transn, diag, n, &a[a_offset], lda, &work[1], &
c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x_ref(i__, j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L240: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of CTRRFS */
} /* ctrrfs_ */
/* Subroutine */ int chegs2_(integer *itype, char *uplo, integer *n, complex *
a, integer *lda, complex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1, r__2;
complex q__1;
/* Local variables */
integer k;
complex ct;
real akk, bkk;
logical upper;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CHEGS2 reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L') */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L. */
/* B must have been previously factorized as U'*U or L*L' by CPOTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L'); */
/* = 2 or 3: compute U*A*U' or L'*A*L. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored, and how B has been factorized. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the matrices A and B. 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, 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 INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* The triangular factor from the Cholesky factorization of B, */
/* as returned by CPOTRF. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a[k + (k + 1) * a_dim1], lda);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
clacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cher2_(uplo, &i__2, &q__1, &a[k + (k + 1) * a_dim1], lda,
&b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
k + 1) * a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &b[k + (k + 1) * b_dim1], ldb);
i__2 = *n - k;
ctrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
k + 1 + (k + 1) * b_dim1], ldb, &a[k + (k + 1) *
a_dim1], lda);
i__2 = *n - k;
clacgv_(&i__2, &a[k + (k + 1) * a_dim1], lda);
}
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = k + k * a_dim1;
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a[k + 1 + k * a_dim1], &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cher2_(uplo, &i__2, &q__1, &a[k + 1 + k * a_dim1], &c__1,
&b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1)
* a_dim1], lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k +
1 + k * a_dim1], &c__1);
i__2 = *n - k;
ctrsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1
+ (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1],
&c__1);
}
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
ctrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a[k * a_dim1 + 1], &c__1);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a[k * a_dim1 + 1], &c__1, &b[k *
b_dim1 + 1], &c__1, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 +
1], &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
i__2 = k + k * a_dim1;
akk = a[i__2].r;
i__2 = k + k * b_dim1;
bkk = b[i__2].r;
i__2 = k - 1;
clacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k - 1;
ctrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
b_offset], ldb, &a[k + a_dim1], lda);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
clacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a[k + a_dim1], lda, &b[k + b_dim1]
, ldb, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
i__2 = k - 1;
clacgv_(&i__2, &b[k + b_dim1], ldb);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a[k + a_dim1], lda);
i__2 = k - 1;
clacgv_(&i__2, &a[k + a_dim1], lda);
i__2 = k + k * a_dim1;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
}
}
}
return 0;
/* End of CHEGS2 */
} /* chegs2_ */
/* Subroutine */ int chegs2_(integer *itype, char *uplo, integer *n, complex *
a, integer *lda, complex *b, integer *ldb, integer *info)
{
/* -- LAPACK 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
=======
CHEGS2 reduces a complex Hermitian-definite generalized
eigenproblem to standard form.
If ITYPE = 1, the problem is A*x = lambda*B*x,
and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
B must have been previously factorized as U'*U or L*L' by CPOTRF.
Arguments
=========
ITYPE (input) INTEGER
= 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
= 2 or 3: compute U*A*U' or L'*A*L.
UPLO (input) CHARACTER
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored, and how B has been factorized.
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrices A and B. 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, 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 INFO = 0, the transformed matrix, stored in the
same format as A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input) COMPLEX array, dimension (LDB,N)
The triangular factor from the Cholesky factorization of B,
as returned by CPOTRF.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
real r__1, r__2;
complex q__1;
/* Local variables */
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *);
static integer k;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *,
integer *, complex *, integer *);
static complex ct;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
static real akk, bkk;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHEGS2", &i__1);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(k:n,k:n) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = a_subscr(k, k);
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a_ref(k, k + 1), lda);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
clacgv_(&i__2, &a_ref(k, k + 1), lda);
i__2 = *n - k;
clacgv_(&i__2, &b_ref(k, k + 1), ldb);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cher2_(uplo, &i__2, &q__1, &a_ref(k, k + 1), lda, &b_ref(
k, k + 1), ldb, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k, k + 1), ldb, &a_ref(k, k + 1)
, lda);
i__2 = *n - k;
clacgv_(&i__2, &b_ref(k, k + 1), ldb);
i__2 = *n - k;
ctrsv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &
b_ref(k + 1, k + 1), ldb, &a_ref(k, k + 1), lda);
i__2 = *n - k;
clacgv_(&i__2, &a_ref(k, k + 1), lda);
}
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(k:n,k:n) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = a_subscr(k, k);
a[i__2].r = akk, a[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &a_ref(k + 1, k), &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cher2_(uplo, &i__2, &q__1, &a_ref(k + 1, k), &c__1, &
b_ref(k + 1, k), &c__1, &a_ref(k + 1, k + 1), lda);
i__2 = *n - k;
caxpy_(&i__2, &ct, &b_ref(k + 1, k), &c__1, &a_ref(k + 1,
k), &c__1);
i__2 = *n - k;
ctrsv_(uplo, "No transpose", "Non-unit", &i__2, &b_ref(k
+ 1, k + 1), ldb, &a_ref(k + 1, k), &c__1);
}
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the upper triangle of A(1:k,1:k) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
i__2 = k - 1;
ctrmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset],
ldb, &a_ref(1, k), &c__1);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a_ref(1, k), &c__1, &b_ref(1, k),
&c__1, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(1, k), &c__1, &a_ref(1, k), &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a_ref(1, k), &c__1);
i__2 = a_subscr(k, k);
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L30: */
}
} else {
/* Compute L'*A*L */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/* Update the lower triangle of A(1:k,1:k) */
i__2 = a_subscr(k, k);
akk = a[i__2].r;
i__2 = b_subscr(k, k);
bkk = b[i__2].r;
i__2 = k - 1;
clacgv_(&i__2, &a_ref(k, 1), lda);
i__2 = k - 1;
ctrmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &b[
b_offset], ldb, &a_ref(k, 1), lda);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
clacgv_(&i__2, &b_ref(k, 1), ldb);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
cher2_(uplo, &i__2, &c_b1, &a_ref(k, 1), lda, &b_ref(k, 1),
ldb, &a[a_offset], lda);
i__2 = k - 1;
caxpy_(&i__2, &ct, &b_ref(k, 1), ldb, &a_ref(k, 1), lda);
i__2 = k - 1;
clacgv_(&i__2, &b_ref(k, 1), ldb);
i__2 = k - 1;
csscal_(&i__2, &bkk, &a_ref(k, 1), lda);
i__2 = k - 1;
clacgv_(&i__2, &a_ref(k, 1), lda);
i__2 = a_subscr(k, k);
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
a[i__2].r = r__1, a[i__2].i = 0.f;
/* L40: */
}
}
}
return 0;
/* End of CHEGS2 */
} /* chegs2_ */
/* Subroutine */ int clahr2_(integer *n, integer *k, integer *nb, complex *a,
integer *lda, complex *tau, complex *t, integer *ldt, complex *y,
integer *ldy)
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2,
i__3;
complex q__1;
/* Local variables */
integer i__;
complex ei;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgemm_(char *, char *, integer *, integer *, integer *
, complex *, complex *, integer *, complex *, integer *, complex *
, complex *, integer *), cgemv_(char *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *), ccopy_(integer *,
complex *, integer *, complex *, integer *), ctrmm_(char *, char *
, char *, char *, integer *, integer *, complex *, complex *,
integer *, complex *, integer *),
caxpy_(integer *, complex *, complex *, integer *, complex *,
integer *), ctrmv_(char *, char *, char *, integer *, complex *,
integer *, complex *, integer *), clarfg_(
integer *, complex *, complex *, integer *, complex *), clacgv_(
integer *, complex *, integer *), clacpy_(char *, integer *,
integer *, complex *, integer *, complex *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) */
/* matrix A so that elements below the k-th subdiagonal are zero. The */
/* reduction is performed by an unitary similarity transformation */
/* Q' * A * Q. The routine returns the matrices V and T which determine */
/* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. */
/* This is an auxiliary routine called by CGEHRD. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. */
/* K (input) INTEGER */
/* The offset for the reduction. Elements below the k-th */
/* subdiagonal in the first NB columns are reduced to zero. */
/* K < N. */
/* NB (input) INTEGER */
/* The number of columns to be reduced. */
/* A (input/output) COMPLEX array, dimension (LDA,N-K+1) */
/* On entry, the n-by-(n-k+1) general matrix A. */
/* On exit, the elements on and above the k-th subdiagonal in */
/* the first NB columns are overwritten with the corresponding */
/* elements of the reduced matrix; the elements below the k-th */
/* subdiagonal, with the array TAU, represent the matrix Q as a */
/* product of elementary reflectors. The other columns of A are */
/* unchanged. See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* TAU (output) COMPLEX array, dimension (NB) */
/* The scalar factors of the elementary reflectors. See Further */
/* Details. */
/* T (output) COMPLEX array, dimension (LDT,NB) */
/* The upper triangular matrix T. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= NB. */
/* Y (output) COMPLEX array, dimension (LDY,NB) */
/* The n-by-nb matrix Y. */
/* LDY (input) INTEGER */
/* The leading dimension of the array Y. LDY >= N. */
/* Further Details */
/* =============== */
/* The matrix Q is represented as a product of nb elementary reflectors */
/* Q = H(1) H(2) . . . H(nb). */
/* Each H(i) has the form */
/* H(i) = I - tau * v * v' */
/* where tau is a complex scalar, and v is a complex vector with */
/* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */
/* A(i+k+1:n,i), and tau in TAU(i). */
/* The elements of the vectors v together form the (n-k+1)-by-nb matrix */
/* V which is needed, with T and Y, to apply the transformation to the */
/* unreduced part of the matrix, using an update of the form: */
/* A := (I - V*T*V') * (A - Y*V'). */
/* The contents of A on exit are illustrated by the following example */
/* with n = 7, k = 3 and nb = 2: */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( a a a a a ) */
/* ( h h a a a ) */
/* ( v1 h a a a ) */
/* ( v1 v2 a a a ) */
/* ( v1 v2 a a a ) */
/* where a denotes an element of the original matrix A, h denotes a */
/* modified element of the upper Hessenberg matrix H, and vi denotes an */
/* element of the vector defining H(i). */
/* This file is a slight modification of LAPACK-3.0's CLAHRD */
/* incorporating improvements proposed by Quintana-Orti and Van de */
/* Gejin. Note that the entries of A(1:K,2:NB) differ from those */
/* returned by the original LAPACK routine. This function is */
/* not backward compatible with LAPACK3.0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
--tau;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
/* Function Body */
if (*n <= 1) {
return 0;
}
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (i__ > 1) {
/* Update A(K+1:N,I) */
/* Update I-th column of A - Y * V' */
i__2 = i__ - 1;
clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
i__2 = *n - *k;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("NO TRANSPOSE", &i__2, &i__3, &q__1, &y[*k + 1 + y_dim1],
ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b2, &a[*k + 1 +
i__ * a_dim1], &c__1);
i__2 = i__ - 1;
clacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda);
/* Apply I - V * T' * V' to this column (call it b) from the */
/* left, using the last column of T as workspace */
/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */
/* ( V2 ) ( b2 ) */
/* where V1 is unit lower triangular */
/* w := V1' * b1 */
i__2 = i__ - 1;
ccopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 +
1], &c__1);
i__2 = i__ - 1;
ctrmv_("Lower", "Conjugate transpose", "UNIT", &i__2, &a[*k + 1 +
a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1);
/* w := w + V2'*b2 */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, &
t[*nb * t_dim1 + 1], &c__1);
/* w := T'*w */
i__2 = i__ - 1;
ctrmv_("Upper", "Conjugate transpose", "NON-UNIT", &i__2, &t[
t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1);
/* b2 := b2 - V2*w */
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("NO TRANSPOSE", &i__2, &i__3, &q__1, &a[*k + i__ + a_dim1],
lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ +
i__ * a_dim1], &c__1);
/* b1 := b1 - V1*w */
i__2 = i__ - 1;
ctrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1]
, lda, &t[*nb * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
caxpy_(&i__2, &q__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__
* a_dim1], &c__1);
i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1;
a[i__2].r = ei.r, a[i__2].i = ei.i;
}
/* Generate the elementary reflector H(I) to annihilate */
/* A(K+I+1:N,I) */
i__2 = *n - *k - i__ + 1;
/* Computing MIN */
i__3 = *k + i__ + 1;
clarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[min(i__3, *n)+ i__ *
a_dim1], &c__1, &tau[i__]);
i__2 = *k + i__ + i__ * a_dim1;
ei.r = a[i__2].r, ei.i = a[i__2].i;
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Compute Y(K+1:N,I) */
i__2 = *n - *k;
i__3 = *n - *k - i__ + 1;
cgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b2, &a[*k + 1 + (i__ + 1) *
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[*
k + 1 + i__ * y_dim1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ +
a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[
i__ * t_dim1 + 1], &c__1);
i__2 = *n - *k;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("NO TRANSPOSE", &i__2, &i__3, &q__1, &y[*k + 1 + y_dim1], ldy,
&t[i__ * t_dim1 + 1], &c__1, &c_b2, &y[*k + 1 + i__ * y_dim1],
&c__1);
i__2 = *n - *k;
cscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1);
/* Compute T(1:I,I) */
i__2 = i__ - 1;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cscal_(&i__2, &q__1, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ - 1;
ctrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt,
&t[i__ * t_dim1 + 1], &c__1)
;
i__2 = i__ + i__ * t_dim1;
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
/* L10: */
}
i__1 = *k + *nb + *nb * a_dim1;
a[i__1].r = ei.r, a[i__1].i = ei.i;
/* Compute Y(1:K,1:NB) */
clacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy);
ctrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b2, &a[*k + 1
+ a_dim1], lda, &y[y_offset], ldy);
if (*n > *k + *nb) {
i__1 = *n - *k - *nb;
cgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b2, &a[(*nb +
2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b2,
&y[y_offset], ldy);
}
ctrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b2, &t[
t_offset], ldt, &y[y_offset], ldy);
return 0;
/* End of CLAHR2 */
} /* clahr2_ */
int ctrti2_(char *uplo, char *diag, int *n, complex *a,
int *lda, int *info)
{
/* System generated locals */
int a_dim1, a_offset, i__1, i__2;
complex q__1;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
int j;
complex ajj;
extern int cscal_(int *, complex *, complex *,
int *);
extern int lsame_(char *, char *);
int upper;
extern int ctrmv_(char *, char *, char *, int *,
complex *, int *, complex *, int *), xerbla_(char *, int *);
int nounit;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTRTI2 computes the inverse of a complex upper or lower triangular */
/* matrix. */
/* This is the Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the triangular matrix A. If UPLO = 'U', the */
/* leading n by n upper triangular part of the array A contains */
/* the upper triangular matrix, and the strictly lower */
/* triangular part of A is not referenced. If UPLO = 'L', the */
/* leading n by n lower triangular part of the array A contains */
/* the lower triangular matrix, and the strictly upper */
/* triangular part of A is not referenced. If DIAG = 'U', the */
/* diagonal elements of A are also not referenced and are */
/* assumed to be 1. */
/* On exit, the (triangular) inverse of the original matrix, in */
/* the same storage format. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= MAX(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. 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;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < MAX(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRTI2", &i__1);
return 0;
}
if (upper) {
/* Compute inverse of upper triangular matrix. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (nounit) {
i__2 = j + j * a_dim1;
c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j + j * a_dim1;
q__1.r = -a[i__2].r, q__1.i = -a[i__2].i;
ajj.r = q__1.r, ajj.i = q__1.i;
} else {
q__1.r = -1.f, q__1.i = -0.f;
ajj.r = q__1.r, ajj.i = q__1.i;
}
/* Compute elements 1:j-1 of j-th column. */
i__2 = j - 1;
ctrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, &
a[j * a_dim1 + 1], &c__1);
i__2 = j - 1;
cscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* Compute inverse of lower triangular matrix. */
for (j = *n; j >= 1; --j) {
if (nounit) {
i__1 = j + j * a_dim1;
c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = j + j * a_dim1;
q__1.r = -a[i__1].r, q__1.i = -a[i__1].i;
ajj.r = q__1.r, ajj.i = q__1.i;
} else {
q__1.r = -1.f, q__1.i = -0.f;
ajj.r = q__1.r, ajj.i = q__1.i;
}
if (j < *n) {
/* Compute elements j+1:n of j-th column. */
i__1 = *n - j;
ctrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j +
1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1);
i__1 = *n - j;
cscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of CTRTI2 */
} /* ctrti2_ */
/* Subroutine */ int cpbt01_(char *uplo, integer *n, integer *kd, complex *a,
integer *lda, complex *afac, integer *ldafac, real *rwork, real *
resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
i__5;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, j, k, kc, ml, mu;
real akk, eps;
extern /* Subroutine */ int cher_(char *, integer *, real *, complex *,
integer *, complex *, integer *);
integer klen;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
real anorm;
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *);
extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPBT01 reconstructs a Hermitian positive definite band matrix A from */
/* its L*L' or U'*U factorization and computes the residual */
/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of */
/* L, and U' is the conjugate transpose of U. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of super-diagonals of the matrix A if UPLO = 'U', */
/* or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The original Hermitian band matrix A. If UPLO = 'U', the */
/* upper triangular part of A is stored as a band matrix; if */
/* UPLO = 'L', the lower triangular part of A is stored. The */
/* columns of the appropriate triangle are stored in the columns */
/* of A and the diagonals of the triangle are stored in the rows */
/* of A. See CPBTRF for further details. */
/* LDA (input) INTEGER. */
/* The leading dimension of the array A. LDA >= max(1,KD+1). */
/* AFAC (input) COMPLEX array, dimension (LDAFAC,N) */
/* The factored form of the matrix A. AFAC contains the factor */
/* L or U from the L*L' or U'*U factorization in band storage */
/* format, as computed by CPBTRF. */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. */
/* LDAFAC >= max(1,KD+1). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhb_("1", uplo, n, kd, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[*kd + 1 + j * afac_dim1]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[j * afac_dim1 + 1]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
/* L20: */
}
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
for (k = *n; k >= 1; --k) {
/* Computing MAX */
i__1 = 1, i__2 = *kd + 2 - k;
kc = max(i__1,i__2);
klen = *kd + 1 - kc;
/* Compute the (K,K) element of the result. */
i__1 = klen + 1;
cdotc_(&q__1, &i__1, &afac[kc + k * afac_dim1], &c__1, &afac[kc +
k * afac_dim1], &c__1);
akk = q__1.r;
i__1 = *kd + 1 + k * afac_dim1;
afac[i__1].r = akk, afac[i__1].i = 0.f;
/* Compute the rest of column K. */
if (klen > 0) {
i__1 = *ldafac - 1;
ctrmv_("Upper", "Conjugate", "Non-unit", &klen, &afac[*kd + 1
+ (k - klen) * afac_dim1], &i__1, &afac[kc + k *
afac_dim1], &c__1);
}
/* L30: */
}
/* UPLO = 'L': Compute the product L*L', overwriting L. */
} else {
for (k = *n; k >= 1; --k) {
/* Computing MIN */
i__1 = *kd, i__2 = *n - k;
klen = min(i__1,i__2);
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (klen > 0) {
i__1 = *ldafac - 1;
cher_("Lower", &klen, &c_b17, &afac[k * afac_dim1 + 2], &c__1,
&afac[(k + 1) * afac_dim1 + 1], &i__1);
}
/* Scale column K by the diagonal element. */
i__1 = k * afac_dim1 + 1;
akk = afac[i__1].r;
i__1 = klen + 1;
csscal_(&i__1, &akk, &afac[k * afac_dim1 + 1], &c__1);
/* L40: */
}
}
/* Compute the difference L*L' - A or U'*U - A. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = 1, i__3 = *kd + 2 - j;
mu = max(i__2,i__3);
i__2 = *kd + 1;
for (i__ = mu; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
i__4 = i__ + j * afac_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L50: */
}
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kd + 1, i__3 = *n - j + 1;
ml = min(i__2,i__3);
i__2 = ml;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
i__4 = i__ + j * afac_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L70: */
}
/* L80: */
}
}
/* Compute norm( L*L' - A ) / ( N * norm(A) * EPS ) */
*resid = clanhb_("1", uplo, n, kd, &afac[afac_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of CPBT01 */
} /* cpbt01_ */
/* Subroutine */ int clarft_(char *direct, char *storev, integer *n, integer *
k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt)
{
/* -- LAPACK auxiliary 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
=======
CLARFT forms the triangular factor T of a complex block reflector H
of order n, which is defined as a product of k elementary reflectors.
If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
If STOREV = 'C', the vector which defines the elementary reflector
H(i) is stored in the i-th column of the array V, and
H = I - V * T * V'
If STOREV = 'R', the vector which defines the elementary reflector
H(i) is stored in the i-th row of the array V, and
H = I - V' * T * V
Arguments
=========
DIRECT (input) CHARACTER*1
Specifies the order in which the elementary reflectors are
multiplied to form the block reflector:
= 'F': H = H(1) H(2) . . . H(k) (Forward)
= 'B': H = H(k) . . . H(2) H(1) (Backward)
STOREV (input) CHARACTER*1
Specifies how the vectors which define the elementary
reflectors are stored (see also Further Details):
= 'C': columnwise
= 'R': rowwise
N (input) INTEGER
The order of the block reflector H. N >= 0.
K (input) INTEGER
The order of the triangular factor T (= the number of
elementary reflectors). K >= 1.
V (input/output) COMPLEX array, dimension
(LDV,K) if STOREV = 'C'
(LDV,N) if STOREV = 'R'
The matrix V. See further details.
LDV (input) INTEGER
The leading dimension of the array V.
If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
TAU (input) COMPLEX array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i).
T (output) COMPLEX array, dimension (LDT,K)
The k by k triangular factor T of the block reflector.
If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
lower triangular. The rest of the array is not used.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= K.
Further Details
===============
The shape of the matrix V and the storage of the vectors which define
the H(i) is best illustrated by the following example with n = 5 and
k = 3. The elements equal to 1 are not stored; the corresponding
array elements are modified but restored on exit. The rest of the
array is not used.
DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
( v1 1 ) ( 1 v2 v2 v2 )
( v1 v2 1 ) ( 1 v3 v3 )
( v1 v2 v3 )
( v1 v2 v3 )
DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
V = ( v1 v2 v3 ) V = ( v1 v1 1 )
( v1 v2 v3 ) ( v2 v2 v2 1 )
( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
( 1 v3 )
( 1 )
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static complex c_b2 = {0.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
static integer i__, j;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), clacgv_(integer *, complex *, integer *);
static complex vii;
#define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1
#define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)]
#define v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1
#define v_ref(a_1,a_2) v[v_subscr(a_1,a_2)]
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (lsame_(direct, "F")) {
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
if (tau[i__2].r == 0.f && tau[i__2].i == 0.f) {
/* H(i) = I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = t_subscr(j, i__);
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* L10: */
}
} else {
/* general case */
i__2 = v_subscr(i__, i__);
vii.r = v[i__2].r, vii.i = v[i__2].i;
i__2 = v_subscr(i__, i__);
v[i__2].r = 1.f, v[i__2].i = 0.f;
if (lsame_(storev, "C")) {
/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
i__4 = i__;
q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i;
cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &v_ref(
i__, 1), ldv, &v_ref(i__, i__), &c__1, &c_b2, &
t_ref(1, i__), &c__1);
} else {
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' */
if (i__ < *n) {
i__2 = *n - i__;
clacgv_(&i__2, &v_ref(i__, i__ + 1), ldv);
}
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
i__4 = i__;
q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i;
cgemv_("No transpose", &i__2, &i__3, &q__1, &v_ref(1, i__)
, ldv, &v_ref(i__, i__), ldv, &c_b2, &t_ref(1,
i__), &c__1);
if (i__ < *n) {
i__2 = *n - i__;
clacgv_(&i__2, &v_ref(i__, i__ + 1), ldv);
}
}
i__2 = v_subscr(i__, i__);
v[i__2].r = vii.r, v[i__2].i = vii.i;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t_ref(1, i__), &c__1);
i__2 = t_subscr(i__, i__);
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
}
/* L20: */
}
} else {
for (i__ = *k; i__ >= 1; --i__) {
i__1 = i__;
if (tau[i__1].r == 0.f && tau[i__1].i == 0.f) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
i__2 = t_subscr(j, i__);
t[i__2].r = 0.f, t[i__2].i = 0.f;
/* L30: */
}
} else {
/* general case */
if (i__ < *k) {
if (lsame_(storev, "C")) {
i__1 = v_subscr(*n - *k + i__, i__);
vii.r = v[i__1].r, vii.i = v[i__1].i;
i__1 = v_subscr(*n - *k + i__, i__);
v[i__1].r = 1.f, v[i__1].i = 0.f;
/* T(i+1:k,i) :=
- tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) */
i__1 = *n - *k + i__;
i__2 = *k - i__;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cgemv_("Conjugate transpose", &i__1, &i__2, &q__1, &
v_ref(1, i__ + 1), ldv, &v_ref(1, i__), &c__1,
&c_b2, &t_ref(i__ + 1, i__), &c__1);
i__1 = v_subscr(*n - *k + i__, i__);
v[i__1].r = vii.r, v[i__1].i = vii.i;
} else {
i__1 = v_subscr(i__, *n - *k + i__);
vii.r = v[i__1].r, vii.i = v[i__1].i;
i__1 = v_subscr(i__, *n - *k + i__);
v[i__1].r = 1.f, v[i__1].i = 0.f;
/* T(i+1:k,i) :=
- tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' */
i__1 = *n - *k + i__ - 1;
clacgv_(&i__1, &v_ref(i__, 1), ldv);
i__1 = *k - i__;
i__2 = *n - *k + i__;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cgemv_("No transpose", &i__1, &i__2, &q__1, &v_ref(
i__ + 1, 1), ldv, &v_ref(i__, 1), ldv, &c_b2,
&t_ref(i__ + 1, i__), &c__1);
i__1 = *n - *k + i__ - 1;
clacgv_(&i__1, &v_ref(i__, 1), ldv);
i__1 = v_subscr(i__, *n - *k + i__);
v[i__1].r = vii.r, v[i__1].i = vii.i;
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
ctrmv_("Lower", "No transpose", "Non-unit", &i__1, &t_ref(
i__ + 1, i__ + 1), ldt, &t_ref(i__ + 1, i__), &
c__1);
}
i__1 = t_subscr(i__, i__);
i__2 = i__;
t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i;
}
/* L40: */
}
}
return 0;
/* End of CLARFT */
} /* clarft_ */
/* Subroutine */
int ctrrfs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb, complex *x, integer *ldx, real *ferr, real *berr, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, j, k;
real s, xk;
integer nz;
real eps;
integer kase;
real safe1, safe2;
extern logical lsame_(char *, char *);
integer isave[3];
extern /* Subroutine */
int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */
int ctrmv_(char *, char *, char *, integer *, complex *, integer *, complex *, integer *), ctrsv_(char *, char *, char *, integer *, complex *, integer *, complex *, integer *), clacn2_( integer *, complex *, complex *, real *, integer *, integer *);
extern real slamch_(char *);
real safmin;
extern /* Subroutine */
int xerbla_(char *, integer *);
logical notran;
char transn[1], transt[1];
logical nounit;
real lstres;
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
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;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (! notran && ! lsame_(trans, "T") && ! lsame_(trans, "C"))
{
*info = -2;
}
else if (! nounit && ! lsame_(diag, "U"))
{
*info = -3;
}
else if (*n < 0)
{
*info = -4;
}
else if (*nrhs < 0)
{
*info = -5;
}
else if (*lda < max(1,*n))
{
*info = -7;
}
else if (*ldb < max(1,*n))
{
*info = -9;
}
else if (*ldx < max(1,*n))
{
*info = -11;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CTRRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0)
{
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
ferr[j] = 0.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
if (notran)
{
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
}
else
{
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
/* Compute residual R = B - op(A) * X, */
/* where op(A) = A, A**T, or A**H, depending on TRANS. */
ccopy_(n, &x[j * x_dim1 + 1], &c__1, &work[1], &c__1);
ctrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[1], &c__1);
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
caxpy_(n, &q__1, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( f2c_abs(R(i)) / ( f2c_abs(op(A))*f2c_abs(X) + f2c_abs(B) )(i) ) */
/* where f2c_abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. If the i-th component of the denominator is less */
/* than SAFE2, then SAFE1 is added to the i-th components of the */
/* numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * b_dim1;
rwork[i__] = (r__1 = b[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&b[ i__ + j * b_dim1]), f2c_abs(r__2));
/* L20: */
}
if (notran)
{
/* Compute f2c_abs(A)*f2c_abs(X) + f2c_abs(B). */
if (upper)
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), f2c_abs(r__2));
i__3 = k;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, f2c_abs(r__1)) + ( r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs( r__2))) * xk;
/* L30: */
}
/* L40: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), f2c_abs(r__2));
i__3 = k - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, f2c_abs(r__1)) + ( r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs( r__2))) * xk;
/* L50: */
}
rwork[k] += xk;
/* L60: */
}
}
}
else
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), f2c_abs(r__2));
i__3 = *n;
for (i__ = k;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, f2c_abs(r__1)) + ( r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs( r__2))) * xk;
/* L70: */
}
/* L80: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(& x[k + j * x_dim1]), f2c_abs(r__2));
i__3 = *n;
for (i__ = k + 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
rwork[i__] += ((r__1 = a[i__4].r, f2c_abs(r__1)) + ( r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs( r__2))) * xk;
/* L90: */
}
rwork[k] += xk;
/* L100: */
}
}
}
}
else
{
/* Compute f2c_abs(A**H)*f2c_abs(X) + f2c_abs(B). */
if (upper)
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.f;
i__3 = k;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs(r__2))) * ((r__3 = x[i__5].r, f2c_abs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), f2c_abs(r__4))) ;
/* L110: */
}
rwork[k] += s;
/* L120: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
s = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&x[ k + j * x_dim1]), f2c_abs(r__2));
i__3 = k - 1;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs(r__2))) * ((r__3 = x[i__5].r, f2c_abs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), f2c_abs(r__4))) ;
/* L130: */
}
rwork[k] += s;
/* L140: */
}
}
}
else
{
if (nounit)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.f;
i__3 = *n;
for (i__ = k;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs(r__2))) * ((r__3 = x[i__5].r, f2c_abs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), f2c_abs(r__4))) ;
/* L150: */
}
rwork[k] += s;
/* L160: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
i__3 = k + j * x_dim1;
s = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&x[ k + j * x_dim1]), f2c_abs(r__2));
i__3 = *n;
for (i__ = k + 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&a[i__ + k * a_dim1]), f2c_abs(r__2))) * ((r__3 = x[i__5].r, f2c_abs(r__3)) + (r__4 = r_imag(&x[i__ + j * x_dim1]), f2c_abs(r__4))) ;
/* L170: */
}
rwork[k] += s;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
if (rwork[i__] > safe2)
{
/* Computing MAX */
i__3 = i__;
r__3 = s;
r__4 = ((r__1 = work[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&work[i__]), f2c_abs(r__2))) / rwork[i__]; // , expr subst
s = max(r__3,r__4);
}
else
{
/* Computing MAX */
i__3 = i__;
r__3 = s;
r__4 = ((r__1 = work[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&work[i__]), f2c_abs(r__2)) + safe1) / (rwork[i__] + safe1); // , expr subst
s = max(r__3,r__4);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( f2c_abs(inv(op(A)))* */
/* ( f2c_abs(R) + NZ*EPS*( f2c_abs(op(A))*f2c_abs(X)+f2c_abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(op(A)) is the inverse of op(A) */
/* f2c_abs(Z) is the componentwise absolute value of the matrix or */
/* vector Z */
/* NZ is the maximum number of nonzeros in any row of A, plus 1 */
/* EPS is machine epsilon */
/* The i-th component of f2c_abs(R)+NZ*EPS*(f2c_abs(op(A))*f2c_abs(X)+f2c_abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* f2c_abs(op(A))*f2c_abs(X) + f2c_abs(B) is less than SAFE2. */
/* Use CLACN2 to estimate the infinity-norm of the matrix */
/* inv(op(A)) * diag(W), */
/* where W = f2c_abs(R) + NZ*EPS*( f2c_abs(op(A))*f2c_abs(X)+f2c_abs(B) ))) */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
if (rwork[i__] > safe2)
{
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&work[i__]), f2c_abs(r__2)) + nz * eps * rwork[i__] ;
}
else
{
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&work[i__]), f2c_abs(r__2)) + nz * eps * rwork[i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0)
{
if (kase == 1)
{
/* Multiply by diag(W)*inv(op(A)**H). */
ctrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[1], & c__1);
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r;
q__1.i = rwork[i__4] * work[i__5].i; // , expr subst
work[i__3].r = q__1.r;
work[i__3].i = q__1.i; // , expr subst
/* L220: */
}
}
else
{
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r;
q__1.i = rwork[i__4] * work[i__5].i; // , expr subst
work[i__3].r = q__1.r;
work[i__3].i = q__1.i; // , expr subst
/* L230: */
}
ctrsv_(uplo, transn, diag, n, &a[a_offset], lda, &work[1], & c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
/* Computing MAX */
i__3 = i__ + j * x_dim1;
r__3 = lstres;
r__4 = (r__1 = x[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&x[i__ + j * x_dim1]), f2c_abs(r__2)); // , expr subst
lstres = max(r__3,r__4);
/* L240: */
}
if (lstres != 0.f)
{
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of CTRRFS */
}
/* Subroutine */
int cgglse_(integer *m, integer *n, integer *p, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, complex *d__, complex *x, complex *work, integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
integer nb, mn, nr, nb1, nb2, nb3, nb4, lopt;
extern /* Subroutine */
int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), ctrmv_(char *, char *, char *, integer *, complex *, integer *, complex *, integer *), cggrqf_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
integer lwkmin;
extern /* Subroutine */
int cunmqr_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *), cunmrq_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */
int ctrtrs_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--c__;
--d__;
--x;
--work;
/* Function Body */
*info = 0;
mn = min(*m,*n);
lquery = *lwork == -1;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*p < 0 || *p > *n || *p < *n - *m)
{
*info = -3;
}
else if (*lda < max(1,*m))
{
*info = -5;
}
else if (*ldb < max(1,*p))
{
*info = -7;
}
/* Calculate workspace */
if (*info == 0)
{
if (*n == 0)
{
lwkmin = 1;
lwkopt = 1;
}
else
{
nb1 = ilaenv_(&c__1, "CGEQRF", " ", m, n, &c_n1, &c_n1);
nb2 = ilaenv_(&c__1, "CGERQF", " ", m, n, &c_n1, &c_n1);
nb3 = ilaenv_(&c__1, "CUNMQR", " ", m, n, p, &c_n1);
nb4 = ilaenv_(&c__1, "CUNMRQ", " ", m, n, p, &c_n1);
/* Computing MAX */
i__1 = max(nb1,nb2);
i__1 = max(i__1,nb3); // , expr subst
nb = max(i__1,nb4);
lwkmin = *m + *n + *p;
lwkopt = *p + mn + max(*m,*n) * nb;
}
work[1].r = (real) lwkopt;
work[1].i = 0.f; // , expr subst
if (*lwork < lwkmin && ! lquery)
{
*info = -12;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGGLSE", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Compute the GRQ factorization of matrices B and A: */
/* B*Q**H = ( 0 T12 ) P Z**H*A*Q**H = ( R11 R12 ) N-P */
/* N-P P ( 0 R22 ) M+P-N */
/* N-P P */
/* where T12 and R11 are upper triangular, and Q and Z are */
/* unitary. */
i__1 = *lwork - *p - mn;
cggrqf_(p, m, n, &b[b_offset], ldb, &work[1], &a[a_offset], lda, &work[*p + 1], &work[*p + mn + 1], &i__1, info);
i__1 = *p + mn + 1;
lopt = work[i__1].r;
/* Update c = Z**H *c = ( c1 ) N-P */
/* ( c2 ) M+P-N */
i__1 = max(1,*m);
i__2 = *lwork - *p - mn;
cunmqr_("Left", "Conjugate Transpose", m, &c__1, &mn, &a[a_offset], lda, & work[*p + 1], &c__[1], &i__1, &work[*p + mn + 1], &i__2, info);
/* Computing MAX */
i__3 = *p + mn + 1;
i__1 = lopt;
i__2 = (integer) work[i__3].r; // , expr subst
lopt = max(i__1,i__2);
/* Solve T12*x2 = d for x2 */
if (*p > 0)
{
ctrtrs_("Upper", "No transpose", "Non-unit", p, &c__1, &b[(*n - *p + 1) * b_dim1 + 1], ldb, &d__[1], p, info);
if (*info > 0)
{
*info = 1;
return 0;
}
/* Put the solution in X */
ccopy_(p, &d__[1], &c__1, &x[*n - *p + 1], &c__1);
/* Update c1 */
i__1 = *n - *p;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__1, p, &q__1, &a[(*n - *p + 1) * a_dim1 + 1] , lda, &d__[1], &c__1, &c_b1, &c__[1], &c__1);
}
/* Solve R11*x1 = c1 for x1 */
if (*n > *p)
{
i__1 = *n - *p;
i__2 = *n - *p;
ctrtrs_("Upper", "No transpose", "Non-unit", &i__1, &c__1, &a[ a_offset], lda, &c__[1], &i__2, info);
if (*info > 0)
{
*info = 2;
return 0;
}
/* Put the solutions in X */
i__1 = *n - *p;
ccopy_(&i__1, &c__[1], &c__1, &x[1], &c__1);
}
/* Compute the residual vector: */
if (*m < *n)
{
nr = *m + *p - *n;
if (nr > 0)
{
i__1 = *n - *m;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &nr, &i__1, &q__1, &a[*n - *p + 1 + (*m + 1) * a_dim1], lda, &d__[nr + 1], &c__1, &c_b1, &c__[*n - * p + 1], &c__1);
}
}
else
{
nr = *p;
}
if (nr > 0)
{
ctrmv_("Upper", "No transpose", "Non unit", &nr, &a[*n - *p + 1 + (*n - *p + 1) * a_dim1], lda, &d__[1], &c__1);
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
caxpy_(&nr, &q__1, &d__[1], &c__1, &c__[*n - *p + 1], &c__1);
}
/* Backward transformation x = Q**H*x */
i__1 = *lwork - *p - mn;
cunmrq_("Left", "Conjugate Transpose", n, &c__1, p, &b[b_offset], ldb, & work[1], &x[1], n, &work[*p + mn + 1], &i__1, info);
/* Computing MAX */
i__4 = *p + mn + 1;
i__2 = lopt;
i__3 = (integer) work[i__4].r; // , expr subst
i__1 = *p + mn + max(i__2,i__3);
work[1].r = (real) i__1;
work[1].i = 0.f; // , expr subst
return 0;
/* End of CGGLSE */
}
/* Subroutine */ int clarft_(char *direct, char *storev, integer *n, integer *
k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt,
ftnlen direct_len, ftnlen storev_len)
{
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
static integer i__, j;
static complex vii;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *, ftnlen, ftnlen,
ftnlen), clacgv_(integer *, complex *, integer *);
/* -- LAPACK auxiliary routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARFT forms the triangular factor T of a complex block reflector H */
/* of order n, which is defined as a product of k elementary reflectors. */
/* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
/* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
/* If STOREV = 'C', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th column of the array V, and */
/* H = I - V * T * V' */
/* If STOREV = 'R', the vector which defines the elementary reflector */
/* H(i) is stored in the i-th row of the array V, and */
/* H = I - V' * T * V */
/* Arguments */
/* ========= */
/* DIRECT (input) CHARACTER*1 */
/* Specifies the order in which the elementary reflectors are */
/* multiplied to form the block reflector: */
/* = 'F': H = H(1) H(2) . . . H(k) (Forward) */
/* = 'B': H = H(k) . . . H(2) H(1) (Backward) */
/* STOREV (input) CHARACTER*1 */
/* Specifies how the vectors which define the elementary */
/* reflectors are stored (see also Further Details): */
/* = 'C': columnwise */
/* = 'R': rowwise */
/* N (input) INTEGER */
/* The order of the block reflector H. N >= 0. */
/* K (input) INTEGER */
/* The order of the triangular factor T (= the number of */
/* elementary reflectors). K >= 1. */
/* V (input/output) COMPLEX array, dimension */
/* (LDV,K) if STOREV = 'C' */
/* (LDV,N) if STOREV = 'R' */
/* The matrix V. See further details. */
/* LDV (input) INTEGER */
/* The leading dimension of the array V. */
/* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
/* TAU (input) COMPLEX array, dimension (K) */
/* TAU(i) must contain the scalar factor of the elementary */
/* reflector H(i). */
/* T (output) COMPLEX array, dimension (LDT,K) */
/* The k by k triangular factor T of the block reflector. */
/* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
/* lower triangular. The rest of the array is not used. */
/* LDT (input) INTEGER */
/* The leading dimension of the array T. LDT >= K. */
/* Further Details */
/* =============== */
/* The shape of the matrix V and the storage of the vectors which define */
/* the H(i) is best illustrated by the following example with n = 5 and */
/* k = 3. The elements equal to 1 are not stored; the corresponding */
/* array elements are modified but restored on exit. The rest of the */
/* array is not used. */
/* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */
/* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */
/* ( v1 1 ) ( 1 v2 v2 v2 ) */
/* ( v1 v2 1 ) ( 1 v3 v3 ) */
/* ( v1 v2 v3 ) */
/* ( v1 v2 v3 ) */
/* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */
/* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */
/* ( v1 v2 v3 ) ( v2 v2 v2 1 ) */
/* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */
/* ( 1 v3 ) */
/* ( 1 ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (lsame_(direct, "F", (ftnlen)1, (ftnlen)1)) {
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
if (tau[i__2].r == 0.f && tau[i__2].i == 0.f) {
/* H(i) = I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = j + i__ * t_dim1;
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* L10: */
}
} else {
/* general case */
i__2 = i__ + i__ * v_dim1;
vii.r = v[i__2].r, vii.i = v[i__2].i;
i__2 = i__ + i__ * v_dim1;
v[i__2].r = 1.f, v[i__2].i = 0.f;
if (lsame_(storev, "C", (ftnlen)1, (ftnlen)1)) {
/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
i__4 = i__;
q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i;
cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &v[i__
+ v_dim1], ldv, &v[i__ + i__ * v_dim1], &c__1, &
c_b2, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)19);
} else {
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' */
if (i__ < *n) {
i__2 = *n - i__;
clacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv);
}
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
i__4 = i__;
q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i;
cgemv_("No transpose", &i__2, &i__3, &q__1, &v[i__ *
v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
c_b2, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)12);
if (i__ < *n) {
i__2 = *n - i__;
clacgv_(&i__2, &v[i__ + (i__ + 1) * v_dim1], ldv);
}
}
i__2 = i__ + i__ * v_dim1;
v[i__2].r = vii.r, v[i__2].i = vii.i;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1, (ftnlen)
5, (ftnlen)12, (ftnlen)8);
i__2 = i__ + i__ * t_dim1;
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
}
/* L20: */
}
} else {
for (i__ = *k; i__ >= 1; --i__) {
i__1 = i__;
if (tau[i__1].r == 0.f && tau[i__1].i == 0.f) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
i__2 = j + i__ * t_dim1;
t[i__2].r = 0.f, t[i__2].i = 0.f;
/* L30: */
}
} else {
/* general case */
if (i__ < *k) {
if (lsame_(storev, "C", (ftnlen)1, (ftnlen)1)) {
i__1 = *n - *k + i__ + i__ * v_dim1;
vii.r = v[i__1].r, vii.i = v[i__1].i;
i__1 = *n - *k + i__ + i__ * v_dim1;
v[i__1].r = 1.f, v[i__1].i = 0.f;
/* T(i+1:k,i) := */
/* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) */
i__1 = *n - *k + i__;
i__2 = *k - i__;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cgemv_("Conjugate transpose", &i__1, &i__2, &q__1, &v[
(i__ + 1) * v_dim1 + 1], ldv, &v[i__ * v_dim1
+ 1], &c__1, &c_b2, &t[i__ + 1 + i__ * t_dim1]
, &c__1, (ftnlen)19);
i__1 = *n - *k + i__ + i__ * v_dim1;
v[i__1].r = vii.r, v[i__1].i = vii.i;
} else {
i__1 = i__ + (*n - *k + i__) * v_dim1;
vii.r = v[i__1].r, vii.i = v[i__1].i;
i__1 = i__ + (*n - *k + i__) * v_dim1;
v[i__1].r = 1.f, v[i__1].i = 0.f;
/* T(i+1:k,i) := */
/* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' */
i__1 = *n - *k + i__ - 1;
clacgv_(&i__1, &v[i__ + v_dim1], ldv);
i__1 = *k - i__;
i__2 = *n - *k + i__;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cgemv_("No transpose", &i__1, &i__2, &q__1, &v[i__ +
1 + v_dim1], ldv, &v[i__ + v_dim1], ldv, &
c_b2, &t[i__ + 1 + i__ * t_dim1], &c__1, (
ftnlen)12);
i__1 = *n - *k + i__ - 1;
clacgv_(&i__1, &v[i__ + v_dim1], ldv);
i__1 = i__ + (*n - *k + i__) * v_dim1;
v[i__1].r = vii.r, v[i__1].i = vii.i;
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
ctrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__
+ 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
t_dim1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8)
;
}
i__1 = i__ + i__ * t_dim1;
i__2 = i__;
t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i;
}
/* L40: */
}
}
return 0;
/* End of CLARFT */
} /* clarft_ */
/* Subroutine */
int cgeqrt2_(integer *m, integer *n, complex *a, integer * lda, complex *t, integer *ldt, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3;
complex q__1, q__2;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, k;
complex aii;
extern /* Subroutine */
int cgerc_(integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, integer *);
complex alpha;
extern /* Subroutine */
int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), ctrmv_(char *, char *, char *, integer *, complex *, integer *, complex *, integer *), clarfg_(integer *, complex *, complex *, integer *, complex *), xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1;
t -= t_offset;
/* Function Body */
*info = 0;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*m))
{
*info = -4;
}
else if (*ldt < max(1,*n))
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGEQRT2", &i__1);
return 0;
}
k = min(*m,*n);
i__1 = k;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Generate elem. refl. H(i) to annihilate A(i+1:m,i), tau(I) -> T(I,1) */
i__2 = *m - i__ + 1;
/* Computing MIN */
i__3 = i__ + 1;
clarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3,*m) + i__ * a_dim1] , &c__1, &t[i__ + t_dim1]);
if (i__ < *n)
{
/* Apply H(i) to A(I:M,I+1:N) from the left */
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r;
aii.i = a[i__2].i; // , expr subst
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1.f;
a[i__2].i = 0.f; // , expr subst
/* W(1:N-I) := A(I:M,I+1:N)**H * A(I:M,I) [W = T(:,N)] */
i__2 = *m - i__ + 1;
i__3 = *n - i__;
cgemv_("C", &i__2, &i__3, &c_b1, &a[i__ + (i__ + 1) * a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b2, &t[*n * t_dim1 + 1], &c__1);
/* A(I:M,I+1:N) = A(I:m,I+1:N) + alpha*A(I:M,I)*W(1:N-1)**H */
r_cnjg(&q__2, &t[i__ + t_dim1]);
q__1.r = -q__2.r;
q__1.i = -q__2.i; // , expr subst
alpha.r = q__1.r;
alpha.i = q__1.i; // , expr subst
i__2 = *m - i__ + 1;
i__3 = *n - i__;
cgerc_(&i__2, &i__3, &alpha, &a[i__ + i__ * a_dim1], &c__1, &t[*n * t_dim1 + 1], &c__1, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r;
a[i__2].i = aii.i; // , expr subst
}
}
i__1 = *n;
for (i__ = 2;
i__ <= i__1;
++i__)
{
i__2 = i__ + i__ * a_dim1;
aii.r = a[i__2].r;
aii.i = a[i__2].i; // , expr subst
i__2 = i__ + i__ * a_dim1;
a[i__2].r = 1.f;
a[i__2].i = 0.f; // , expr subst
/* T(1:I-1,I) := alpha * A(I:M,1:I-1)**H * A(I:M,I) */
i__2 = i__ + t_dim1;
q__1.r = -t[i__2].r;
q__1.i = -t[i__2].i; // , expr subst
alpha.r = q__1.r;
alpha.i = q__1.i; // , expr subst
i__2 = *m - i__ + 1;
i__3 = i__ - 1;
cgemv_("C", &i__2, &i__3, &alpha, &a[i__ + a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b2, &t[i__ * t_dim1 + 1], &c__1);
i__2 = i__ + i__ * a_dim1;
a[i__2].r = aii.r;
a[i__2].i = aii.i; // , expr subst
/* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) */
i__2 = i__ - 1;
ctrmv_("U", "N", "N", &i__2, &t[t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
/* T(I,I) = tau(I) */
i__2 = i__ + i__ * t_dim1;
i__3 = i__ + t_dim1;
t[i__2].r = t[i__3].r;
t[i__2].i = t[i__3].i; // , expr subst
i__2 = i__ + t_dim1;
t[i__2].r = 0.f;
t[i__2].i = 0.f; // , expr subst
}
/* End of CGEQRT2 */
return 0;
}
/* Subroutine */ int cpot01_(char *uplo, integer *n, complex *a, integer *lda,
complex *afac, integer *ldafac, real *rwork, real *resid)
{
/* System generated locals */
integer a_dim1, a_offset, afac_dim1, afac_offset, i__1, i__2, i__3, i__4,
i__5;
real r__1;
complex q__1;
/* Local variables */
integer i__, j, k;
complex tc;
real tr, eps;
real anorm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPOT01 reconstructs a Hermitian positive definite matrix A from */
/* its L*L' or U'*U factorization and computes the residual */
/* norm( L*L' - A ) / ( N * norm(A) * EPS ) or */
/* norm( U'*U - A ) / ( N * norm(A) * EPS ), */
/* where EPS is the machine epsilon, L' is the conjugate transpose of L, */
/* and U' is the conjugate transpose of U. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows and columns of the matrix A. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The original Hermitian matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N) */
/* AFAC (input/output) COMPLEX array, dimension (LDAFAC,N) */
/* On entry, the factor L or U from the L*L' or U'*U */
/* factorization of A. */
/* Overwritten with the reconstructed matrix, and then with the */
/* difference L*L' - A (or U'*U - A). */
/* LDAFAC (input) INTEGER */
/* The leading dimension of the array AFAC. LDAFAC >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RESID (output) REAL */
/* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) */
/* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
afac_dim1 = *ldafac;
afac_offset = 1 + afac_dim1;
afac -= afac_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0. */
eps = slamch_("Epsilon");
anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anorm <= 0.f) {
*resid = 1.f / eps;
return 0;
}
/* Check the imaginary parts of the diagonal elements and return with */
/* an error code if any are nonzero. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (r_imag(&afac[j + j * afac_dim1]) != 0.f) {
*resid = 1.f / eps;
return 0;
}
/* L10: */
}
/* Compute the product U'*U, overwriting U. */
if (lsame_(uplo, "U")) {
for (k = *n; k >= 1; --k) {
/* Compute the (K,K) element of the result. */
cdotc_(&q__1, &k, &afac[k * afac_dim1 + 1], &c__1, &afac[k *
afac_dim1 + 1], &c__1);
tr = q__1.r;
i__1 = k + k * afac_dim1;
afac[i__1].r = tr, afac[i__1].i = 0.f;
/* Compute the rest of column K. */
i__1 = k - 1;
ctrmv_("Upper", "Conjugate", "Non-unit", &i__1, &afac[afac_offset]
, ldafac, &afac[k * afac_dim1 + 1], &c__1);
/* L20: */
}
/* Compute the product L*L', overwriting L. */
} else {
for (k = *n; k >= 1; --k) {
/* Add a multiple of column K of the factor L to each of */
/* columns K+1 through N. */
if (k + 1 <= *n) {
i__1 = *n - k;
cher_("Lower", &i__1, &c_b15, &afac[k + 1 + k * afac_dim1], &
c__1, &afac[k + 1 + (k + 1) * afac_dim1], ldafac);
}
/* Scale column K by the diagonal element. */
i__1 = k + k * afac_dim1;
tc.r = afac[i__1].r, tc.i = afac[i__1].i;
i__1 = *n - k + 1;
cscal_(&i__1, &tc, &afac[k + k * afac_dim1], &c__1);
/* L30: */
}
}
/* Compute the difference L*L' - A (or U'*U - A). */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
i__4 = i__ + j * afac_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L40: */
}
i__2 = j + j * afac_dim1;
i__3 = j + j * afac_dim1;
i__4 = j + j * a_dim1;
r__1 = a[i__4].r;
q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
/* L50: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j + j * afac_dim1;
i__3 = j + j * afac_dim1;
i__4 = j + j * a_dim1;
r__1 = a[i__4].r;
q__1.r = afac[i__3].r - r__1, q__1.i = afac[i__3].i;
afac[i__2].r = q__1.r, afac[i__2].i = q__1.i;
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * afac_dim1;
i__4 = i__ + j * afac_dim1;
i__5 = i__ + j * a_dim1;
q__1.r = afac[i__4].r - a[i__5].r, q__1.i = afac[i__4].i - a[
i__5].i;
afac[i__3].r = q__1.r, afac[i__3].i = q__1.i;
/* L60: */
}
/* L70: */
}
}
/* Compute norm( L*U - A ) / ( N * norm(A) * EPS ) */
*resid = clanhe_("1", uplo, n, &afac[afac_offset], ldafac, &rwork[1]);
*resid = *resid / (real) (*n) / anorm / eps;
return 0;
/* End of CPOT01 */
} /* cpot01_ */
