int
f2c_chemv(char* uplo, integer* N,
complex* alpha,
complex* A, integer* lda,
complex* X, integer* incX,
complex* beta,
complex* Y, integer* incY)
{
chemv_(uplo, N, alpha, A, lda,
X, incX, beta, Y, incY);
return 0;
}
/* Subroutine */ int cherfs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, complex *af, integer *ldaf, integer *ipiv, 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
=======
CHERFS improves the computed solution to a system of linear
equations when the coefficient matrix is Hermitian indefinite, and
provides error bounds and backward error estimates for the solution.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
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 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.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
AF (input) COMPLEX array, dimension (LDAF,N)
The factored form of the matrix A. AF contains the block
diagonal matrix D and the multipliers used to obtain the
factor U or L from the factorization A = U*D*U**H or
A = L*D*L**H as computed by CHETRF.
LDAF (input) INTEGER
The leading dimension of the array AF. LDAF >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by CHETRF.
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/output) COMPLEX array, dimension (LDX,NRHS)
On entry, the solution matrix X, as computed by CHETRS.
On exit, the improved 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
Internal Parameters
===================
ITMAX is the maximum number of steps of iterative refinement.
=====================================================================
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, af_dim1, af_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 chemv_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, complex *, integer *
), ccopy_(integer *, complex *, integer *, complex *,
integer *), caxpy_(integer *, complex *, complex *, integer *,
complex *, integer *);
static integer count;
static logical upper;
extern /* Subroutine */ int 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 *), chetrs_(
char *, integer *, integer *, complex *, integer *, integer *,
complex *, integer *, integer *);
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;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1 * 1;
af -= af_offset;
--ipiv;
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");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < max(1,*n)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
} else if (*ldx < max(1,*n)) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHERFS", &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;
}
/* 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) {
count = 1;
lstres = 3.f;
L20:
/* Loop until stopping criterion is satisfied.
Compute residual R = B - A * X */
ccopy_(n, &b_ref(1, j), &c__1, &work[1], &c__1);
q__1.r = -1.f, q__1.i = 0.f;
chemv_(uplo, n, &q__1, &a[a_offset], lda, &x_ref(1, j), &c__1, &c_b1,
&work[1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(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));
/* L30: */
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
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;
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)));
/* L40: */
}
i__3 = a_subscr(k, k);
rwork[k] = rwork[k] + (r__1 = a[i__3].r, dabs(r__1)) * xk + s;
/* L50: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
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 = a_subscr(k, k);
rwork[k] += (r__1 = a[i__3].r, dabs(r__1)) * xk;
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;
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)));
/* L60: */
}
rwork[k] += s;
/* L70: */
}
}
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);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if
1) The residual BERR(J) is larger than machine epsilon, and
2) BERR(J) decreased by at least a factor of 2 during the
last iteration, and
3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
/* Update solution and try again. */
chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1],
n, info);
caxpy_(n, &c_b1, &work[1], &c__1, &x_ref(1, j), &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(A))*
( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(A) is the inverse of 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(A)*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(A)*abs(X) + abs(B) is less than SAFE2.
Use CLACON to estimate the infinity-norm of the matrix
inv(A) * diag(W),
where W = abs(R) + NZ*EPS*( abs(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;
}
/* L90: */
}
kase = 0;
L100:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
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;
/* L110: */
}
} else if (kase == 2) {
/* Multiply by inv(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;
/* L120: */
}
chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
1], n, info);
}
goto L100;
}
/* 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);
/* L130: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of CHERFS */
} /* cherfs_ */
void
chemv(char uplo, int n, complex *alpha, complex *a, int lda, complex *x, int incx, complex *beta, complex *y, int incy)
{
chemv_( &uplo, &n, alpha, a, &lda, x, &incx, beta, y, &incy );
}
/* Subroutine */
int cla_herfsx_extended_(integer *prec_type__, char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *ipiv, logical *colequ, real *c__, complex *b, integer *ldb, complex *y, integer *ldy, real *berr_out__, integer * n_norms__, real *err_bnds_norm__, real *err_bnds_comp__, complex *res, real *ayb, complex *dy, complex *y_tail__, real *rcond, integer * ithresh, real *rthresh, real *dz_ub__, logical *ignore_cwise__, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
real dxratmax, dzratmax;
integer i__, j;
extern /* Subroutine */
int cla_heamv_(integer *, integer *, real *, complex *, integer *, complex *, integer *, real *, real *, integer *);
logical incr_prec__;
real prev_dz_z__, yk, final_dx_x__;
extern /* Subroutine */
int cla_wwaddw_(integer *, complex *, complex *, complex *);
real final_dz_z__, prevnormdx;
integer cnt;
real dyk, eps, incr_thresh__, dx_x__, dz_z__;
extern /* Subroutine */
int cla_lin_berr_(integer *, integer *, integer * , complex *, real *, real *);
real ymin;
extern /* Subroutine */
int blas_chemv_x_(integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *, integer *);
integer y_prec_state__, uplo2;
extern /* Subroutine */
int blas_chemv2_x_(integer *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, complex *, complex *, integer *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int chemv_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, complex *, integer * ), ccopy_(integer *, complex *, integer *, complex *, integer *);
real dxrat, dzrat;
extern /* Subroutine */
int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
logical upper;
real normx, normy;
extern real slamch_(char *);
extern /* Subroutine */
int xerbla_(char *, integer *), chetrs_( char *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *);
real normdx, hugeval;
extern integer ilauplo_(char *);
integer x_state__, z_state__;
/* -- 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 .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Parameters .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function Definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
y_dim1 = *ldy;
y_offset = 1 + y_dim1;
y -= y_offset;
--berr_out__;
--res;
--ayb;
--dy;
--y_tail__;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*nrhs < 0)
{
*info = -4;
}
else if (*lda < max(1,*n))
{
*info = -6;
}
else if (*ldaf < max(1,*n))
{
*info = -8;
}
else if (*ldb < max(1,*n))
{
*info = -13;
}
else if (*ldy < max(1,*n))
{
*info = -15;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CLA_HERFSX_EXTENDED", &i__1);
return 0;
}
eps = slamch_("Epsilon");
hugeval = slamch_("Overflow");
/* Force HUGEVAL to Inf */
hugeval *= hugeval;
/* Using HUGEVAL may lead to spurious underflows. */
incr_thresh__ = (real) (*n) * eps;
if (lsame_(uplo, "L"))
{
uplo2 = ilauplo_("L");
}
else
{
uplo2 = ilauplo_("U");
}
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
y_prec_state__ = 1;
if (y_prec_state__ == 2)
{
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__;
y_tail__[i__3].r = 0.f;
y_tail__[i__3].i = 0.f; // , expr subst
}
}
dxrat = 0.f;
dxratmax = 0.f;
dzrat = 0.f;
dzratmax = 0.f;
final_dx_x__ = hugeval;
final_dz_z__ = hugeval;
prevnormdx = hugeval;
prev_dz_z__ = hugeval;
dz_z__ = hugeval;
dx_x__ = hugeval;
x_state__ = 1;
z_state__ = 0;
incr_prec__ = FALSE_;
i__2 = *ithresh;
for (cnt = 1;
cnt <= i__2;
++cnt)
{
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
if (y_prec_state__ == 0)
{
chemv_(uplo, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b15, &res[1], &c__1);
}
else if (y_prec_state__ == 1)
{
blas_chemv_x_(&uplo2, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b15, &res[1], &c__1, prec_type__);
}
else
{
blas_chemv2_x_(&uplo2, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], &y_tail__[1], &c__1, &c_b15, &res[1], & c__1, prec_type__);
}
/* XXX: RES is no longer needed. */
ccopy_(n, &res[1], &c__1, &dy[1], &c__1);
chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1], n, info);
/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */
normx = 0.f;
normy = 0.f;
normdx = 0.f;
dz_z__ = 0.f;
ymin = hugeval;
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__ + j * y_dim1;
yk = (r__1 = y[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&y[i__ + j * y_dim1]), f2c_abs(r__2));
i__4 = i__;
dyk = (r__1 = dy[i__4].r, f2c_abs(r__1)) + (r__2 = r_imag(&dy[i__] ), f2c_abs(r__2));
if (yk != 0.f)
{
/* Computing MAX */
r__1 = dz_z__;
r__2 = dyk / yk; // , expr subst
dz_z__ = max(r__1,r__2);
}
else if (dyk != 0.f)
{
dz_z__ = hugeval;
}
ymin = min(ymin,yk);
normy = max(normy,yk);
if (*colequ)
{
/* Computing MAX */
r__1 = normx;
r__2 = yk * c__[i__]; // , expr subst
normx = max(r__1,r__2);
/* Computing MAX */
r__1 = normdx;
r__2 = dyk * c__[i__]; // , expr subst
normdx = max(r__1,r__2);
}
else
{
normx = normy;
normdx = max(normdx,dyk);
}
}
if (normx != 0.f)
{
dx_x__ = normdx / normx;
}
else if (normdx == 0.f)
{
dx_x__ = 0.f;
}
else
{
dx_x__ = hugeval;
}
dxrat = normdx / prevnormdx;
dzrat = dz_z__ / prev_dz_z__;
/* Check termination criteria. */
if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2)
{
incr_prec__ = TRUE_;
}
if (x_state__ == 3 && dxrat <= *rthresh)
{
x_state__ = 1;
}
if (x_state__ == 1)
{
if (dx_x__ <= eps)
{
x_state__ = 2;
}
else if (dxrat > *rthresh)
{
if (y_prec_state__ != 2)
{
incr_prec__ = TRUE_;
}
else
{
x_state__ = 3;
}
}
else
{
if (dxrat > dxratmax)
{
dxratmax = dxrat;
}
}
if (x_state__ > 1)
{
final_dx_x__ = dx_x__;
}
}
if (z_state__ == 0 && dz_z__ <= *dz_ub__)
{
z_state__ = 1;
}
if (z_state__ == 3 && dzrat <= *rthresh)
{
z_state__ = 1;
}
if (z_state__ == 1)
{
if (dz_z__ <= eps)
{
z_state__ = 2;
}
else if (dz_z__ > *dz_ub__)
{
z_state__ = 0;
dzratmax = 0.f;
final_dz_z__ = hugeval;
}
else if (dzrat > *rthresh)
{
if (y_prec_state__ != 2)
{
incr_prec__ = TRUE_;
}
else
{
z_state__ = 3;
}
}
else
{
if (dzrat > dzratmax)
{
dzratmax = dzrat;
}
}
if (z_state__ > 1)
{
final_dz_z__ = dz_z__;
}
}
if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1))
{
goto L666;
}
if (incr_prec__)
{
incr_prec__ = FALSE_;
++y_prec_state__;
i__3 = *n;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = i__;
y_tail__[i__4].r = 0.f;
y_tail__[i__4].i = 0.f; // , expr subst
}
}
prevnormdx = normdx;
prev_dz_z__ = dz_z__;
/* Update soluton. */
if (y_prec_state__ < 2)
{
caxpy_(n, &c_b15, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1);
}
else
{
cla_wwaddw_(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]);
}
}
/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't CALL F90_EXIT. */
L666: /* Set final_* when cnt hits ithresh. */
if (x_state__ == 1)
{
final_dx_x__ = dx_x__;
}
if (z_state__ == 1)
{
final_dz_z__ = dz_z__;
}
/* Compute error bounds. */
if (*n_norms__ >= 1)
{
err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( 1 - dxratmax);
}
if (*n_norms__ >= 2)
{
err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( 1 - dzratmax);
}
/* Compute componentwise relative backward error from formula */
/* max(i) ( f2c_abs(R(i)) / ( f2c_abs(op(A_s))*f2c_abs(Y) + f2c_abs(B_s) )(i) ) */
/* where f2c_abs(Z) is the componentwise absolute value of the matrix */
/* or vector Z. */
/* Compute residual RES = B_s - op(A_s) * Y, */
/* op(A) = A, A**T, or A**H depending on TRANS (and type). */
ccopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1);
chemv_(uplo, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b15, &res[1], &c__1);
i__2 = *n;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * b_dim1;
ayb[i__] = (r__1 = b[i__3].r, f2c_abs(r__1)) + (r__2 = r_imag(&b[i__ + j * b_dim1]), f2c_abs(r__2));
}
/* Compute f2c_abs(op(A_s))*f2c_abs(Y) + f2c_abs(B_s). */
cla_heamv_(&uplo2, n, &c_b37, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, &c_b37, &ayb[1], &c__1);
cla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]);
/* End of loop for each RHS. */
}
return 0;
}
/* Subroutine */
int clatrd_(char *uplo, integer *n, integer *nb, complex *a, integer *lda, real *e, complex *tau, complex *w, integer *ldw)
{
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Local variables */
integer i__, iw;
complex alpha;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *);
extern /* Complex */
VOID cdotc_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
extern /* Subroutine */
int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), chemv_(char *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), clarfg_(integer *, complex *, complex *, integer *, complex *), clacgv_(integer *, complex *, integer *);
/* -- LAPACK auxiliary 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0)
{
return 0;
}
if (lsame_(uplo, "U"))
{
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n;
i__ >= i__1;
--i__)
{
iw = i__ - *n + *nb;
if (i__ < *n)
{
/* Update A(1:i,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1;
a[i__2].i = 0.f; // , expr subst
i__2 = *n - i__;
clacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__, &i__2, &q__1, &a[(i__ + 1) * a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
clacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = *n - i__;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__, &i__2, &q__1, &w[(iw + 1) * w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & c_b2, &a[i__ * a_dim1 + 1], &c__1);
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1;
a[i__2].i = 0.f; // , expr subst
}
if (i__ > 1)
{
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1 + i__ * a_dim1;
alpha.r = a[i__2].r;
alpha.i = a[i__2].i; // , expr subst
i__2 = i__ - 1;
clarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__ - 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = i__ - 1 + i__ * a_dim1;
a[i__2].r = 1.f;
a[i__2].i = 0.f; // , expr subst
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
chemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ * a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1);
if (i__ < *n)
{
i__2 = i__ - 1;
i__3 = *n - i__;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw + 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], & c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[(i__ + 1) * a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[( i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__2, &i__3, &q__1, &w[(iw + 1) * w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1);
}
i__2 = i__ - 1;
cscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
q__3.r = -.5f;
q__3.i = -0.f; // , expr subst
i__2 = i__ - 1;
q__2.r = q__3.r * tau[i__2].r - q__3.i * tau[i__2].i;
q__2.i = q__3.r * tau[i__2].i + q__3.i * tau[i__2].r; // , expr subst
i__3 = i__ - 1;
cdotc_f2c_(&q__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i;
q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; // , expr subst
alpha.r = q__1.r;
alpha.i = q__1.i; // , expr subst
i__2 = i__ - 1;
caxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * w_dim1 + 1], &c__1);
}
/* L10: */
}
}
else
{
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Update A(i:n,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1;
a[i__2].i = 0.f; // , expr subst
i__2 = i__ - 1;
clacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + a_dim1], lda, &w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], & c__1);
i__2 = i__ - 1;
clacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = i__ - 1;
clacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__2, &i__3, &q__1, &w[i__ + w_dim1], ldw, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], & c__1);
i__2 = i__ - 1;
clacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1;
a[i__2].i = 0.f; // , expr subst
if (i__ < *n)
{
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:n,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r;
alpha.i = a[i__2].i; // , expr subst
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
clarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, &tau[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1.f;
a[i__2].i = 0.f; // , expr subst
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
chemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1] , lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[ i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1 + w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, & c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 + a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & c_b1, &w[i__ * w_dim1 + 1], &c__1);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("No transpose", &i__2, &i__3, &q__1, &w[i__ + 1 + w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[ i__ + 1 + i__ * w_dim1], &c__1);
i__2 = *n - i__;
cscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
q__3.r = -.5f;
q__3.i = -0.f; // , expr subst
i__2 = i__;
q__2.r = q__3.r * tau[i__2].r - q__3.i * tau[i__2].i;
q__2.i = q__3.r * tau[i__2].i + q__3.i * tau[i__2].r; // , expr subst
i__3 = *n - i__;
cdotc_f2c_(&q__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[ i__ + 1 + i__ * a_dim1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i;
q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; // , expr subst
alpha.r = q__1.r;
alpha.i = q__1.i; // , expr subst
i__2 = *n - i__;
caxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ i__ + 1 + i__ * w_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of CLATRD */
}
/* Subroutine */
int cherfs_(char *uplo, integer *n, integer *nrhs, complex * a, integer *lda, complex *af, integer *ldaf, integer *ipiv, 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, af_dim1, af_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 *);
extern /* Subroutine */
int chemv_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, complex *, integer * );
integer isave[3];
extern /* Subroutine */
int ccopy_(integer *, complex *, integer *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
integer count;
logical upper;
extern /* Subroutine */
int clacn2_(integer *, complex *, complex *, real *, integer *, integer *);
extern real slamch_(char *);
real safmin;
extern /* Subroutine */
int xerbla_(char *, integer *), chetrs_( char *, integer *, integer *, complex *, integer *, integer *, complex *, integer *, integer *);
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;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*lda < max(1,*n))
{
*info = -5;
}
else if (*ldaf < max(1,*n))
{
*info = -7;
}
else if (*ldb < max(1,*n))
{
*info = -10;
}
else if (*ldx < max(1,*n))
{
*info = -12;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CHERFS", &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;
}
/* 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)
{
count = 1;
lstres = 3.f;
L20: /* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
chemv_(uplo, n, &q__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, & c_b1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( f2c_abs(R(i)) / ( f2c_abs(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));
/* L30: */
}
/* Compute f2c_abs(A)*f2c_abs(X) + f2c_abs(B). */
if (upper)
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.f;
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;
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)));
/* L40: */
}
i__3 = k + k * a_dim1;
rwork[k] = rwork[k] + (r__1 = a[i__3].r, f2c_abs(r__1)) * xk + s;
/* L50: */
}
}
else
{
i__2 = *n;
for (k = 1;
k <= i__2;
++k)
{
s = 0.f;
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 + k * a_dim1;
rwork[k] += (r__1 = a[i__3].r, f2c_abs(r__1)) * xk;
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;
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)));
/* L60: */
}
rwork[k] += s;
/* L70: */
}
}
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);
}
/* L80: */
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5)
{
/* Update solution and try again. */
chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[1], n, info);
caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( f2c_abs(inv(A))* */
/* ( f2c_abs(R) + NZ*EPS*( f2c_abs(A)*f2c_abs(X)+f2c_abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of 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(A)*f2c_abs(X)+f2c_abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* f2c_abs(A)*f2c_abs(X) + f2c_abs(B) is less than SAFE2. */
/* Use CLACN2 to estimate the infinity-norm of the matrix */
/* inv(A) * diag(W), */
/* where W = f2c_abs(R) + NZ*EPS*( f2c_abs(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;
}
/* L90: */
}
kase = 0;
L100:
clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0)
{
if (kase == 1)
{
/* Multiply by diag(W)*inv(A**H). */
chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ 1], n, info);
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
/* L110: */
}
}
else if (kase == 2)
{
/* Multiply by inv(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
/* L120: */
}
chetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ 1], n, info);
}
goto L100;
}
/* 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);
/* L130: */
}
if (lstres != 0.f)
{
ferr[j] /= lstres;
}
/* L140: */
}
return 0;
/* End of CHERFS */
}
/* Subroutine */
int chetd2_(char *uplo, integer *n, complex *a, integer *lda, real *d__, real *e, complex *tau, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Local variables */
integer i__;
complex taui;
extern /* Subroutine */
int cher2_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, integer *);
complex alpha;
extern /* Complex */
VOID cdotc_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int chemv_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *, complex *, integer * ), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */
int 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 .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--d__;
--e;
--tau;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*lda < max(1,*n))
{
*info = -4;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CHETD2", &i__1);
return 0;
}
/* Quick return if possible */
if (*n <= 0)
{
return 0;
}
if (upper)
{
/* Reduce the upper triangle of A */
i__1 = *n + *n * a_dim1;
i__2 = *n + *n * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1;
a[i__1].i = 0.f; // , expr subst
for (i__ = *n - 1;
i__ >= 1;
--i__)
{
/* Generate elementary reflector H(i) = I - tau * v * v**H */
/* to annihilate A(1:i-1,i+1) */
i__1 = i__ + (i__ + 1) * a_dim1;
alpha.r = a[i__1].r;
alpha.i = a[i__1].i; // , expr subst
clarfg_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &taui);
i__1 = i__;
e[i__1] = alpha.r;
if (taui.r != 0.f || taui.i != 0.f)
{
/* Apply H(i) from both sides to A(1:i,1:i) */
i__1 = i__ + (i__ + 1) * a_dim1;
a[i__1].r = 1.f;
a[i__1].i = 0.f; // , expr subst
/* Compute x := tau * A * v storing x in TAU(1:i) */
chemv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * a_dim1 + 1], &c__1, &c_b2, &tau[1], &c__1);
/* Compute w := x - 1/2 * tau * (x**H * v) * v */
q__3.r = -.5f;
q__3.i = -0.f; // , expr subst
q__2.r = q__3.r * taui.r - q__3.i * taui.i;
q__2.i = q__3.r * taui.i + q__3.i * taui.r; // , expr subst
cdotc_f2c_(&q__4, &i__, &tau[1], &c__1, &a[(i__ + 1) * a_dim1 + 1] , &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i;
q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; // , expr subst
alpha.r = q__1.r;
alpha.i = q__1.i; // , expr subst
caxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[ 1], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**H - w * v**H */
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cher2_(uplo, &i__, &q__1, &a[(i__ + 1) * a_dim1 + 1], &c__1, & tau[1], &c__1, &a[a_offset], lda);
}
else
{
i__1 = i__ + i__ * a_dim1;
i__2 = i__ + i__ * a_dim1;
r__1 = a[i__2].r;
a[i__1].r = r__1;
a[i__1].i = 0.f; // , expr subst
}
i__1 = i__ + (i__ + 1) * a_dim1;
i__2 = i__;
a[i__1].r = e[i__2];
a[i__1].i = 0.f; // , expr subst
i__1 = i__ + 1;
i__2 = i__ + 1 + (i__ + 1) * a_dim1;
d__[i__1] = a[i__2].r;
i__1 = i__;
tau[i__1].r = taui.r;
tau[i__1].i = taui.i; // , expr subst
/* L10: */
}
i__1 = a_dim1 + 1;
d__[1] = a[i__1].r;
}
else
{
/* Reduce the lower triangle of A */
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
r__1 = a[i__2].r;
a[i__1].r = r__1;
a[i__1].i = 0.f; // , expr subst
i__1 = *n - 1;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Generate elementary reflector H(i) = I - tau * v * v**H */
/* to annihilate A(i+2:n,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r;
alpha.i = a[i__2].i; // , expr subst
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
clarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1, & taui);
i__2 = i__;
e[i__2] = alpha.r;
if (taui.r != 0.f || taui.i != 0.f)
{
/* Apply H(i) from both sides to A(i+1:n,i+1:n) */
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1.f;
a[i__2].i = 0.f; // , expr subst
/* Compute x := tau * A * v storing y in TAU(i:n-1) */
i__2 = *n - i__;
chemv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b2, &tau[ i__], &c__1);
/* Compute w := x - 1/2 * tau * (x**H * v) * v */
q__3.r = -.5f;
q__3.i = -0.f; // , expr subst
q__2.r = q__3.r * taui.r - q__3.i * taui.i;
q__2.i = q__3.r * taui.i + q__3.i * taui.r; // , expr subst
i__2 = *n - i__;
cdotc_f2c_(&q__4, &i__2, &tau[i__], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i;
q__1.i = q__2.r * q__4.i + q__2.i * q__4.r; // , expr subst
alpha.r = q__1.r;
alpha.i = q__1.i; // , expr subst
i__2 = *n - i__;
caxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ i__], &c__1);
/* Apply the transformation as a rank-2 update: */
/* A := A - v * w**H - w * v**H */
i__2 = *n - i__;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cher2_(uplo, &i__2, &q__1, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda);
}
else
{
i__2 = i__ + 1 + (i__ + 1) * a_dim1;
i__3 = i__ + 1 + (i__ + 1) * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1;
a[i__2].i = 0.f; // , expr subst
}
i__2 = i__ + 1 + i__ * a_dim1;
i__3 = i__;
a[i__2].r = e[i__3];
a[i__2].i = 0.f; // , expr subst
i__2 = i__;
i__3 = i__ + i__ * a_dim1;
d__[i__2] = a[i__3].r;
i__2 = i__;
tau[i__2].r = taui.r;
tau[i__2].i = taui.i; // , expr subst
/* L20: */
}
i__1 = *n;
i__2 = *n + *n * a_dim1;
d__[i__1] = a[i__2].r;
}
return 0;
/* End of CHETD2 */
}
/* Subroutine */ int claghe_slu(integer *n, integer *k, real *d, complex *a,
integer *lda, integer *iseed, complex *work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
/* Local variables */
extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, integer *);
static integer i, j;
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *);
static complex alpha;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), chemv_(char *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
extern real scnrm2_(integer *, complex *, integer *);
static complex wa, wb;
static real wn;
extern /* Subroutine */ int clarnv_slu(integer *, integer *, integer *, complex *);
extern int input_error(char *, int *);
static complex tau;
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CLAGHE generates a complex hermitian matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random unitary matrix:
A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
unitary transformations.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
K (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= K <= N-1.
D (input) REAL array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) COMPLEX array, dimension (LDA,N)
The generated n by n hermitian matrix A (the full matrix is
stored).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) COMPLEX array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
input_error("CLAGHE", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = i + j * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
i__2 = i + i * a_dim1;
i__3 = i;
a[i__2].r = d[i__3], a[i__2].i = 0.f;
/* L30: */
}
/* Generate lower triangle of hermitian matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
clarnv_slu(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = scnrm2_(&i__1, &work[1], &c__1);
d__1 = wn / c_abs(&work[1]);
q__1.r = d__1 * work[1].r, q__1.i = d__1 * work[1].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__1 = *n - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__1, &q__1, &work[2], &c__1);
work[1].r = 1.f, work[1].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * u */
i__1 = *n - i + 1;
chemv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b1, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__1 = *n - i + 1;
cdotc_(&q__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__1 = *n - i + 1;
caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
i__1 = *n - i + 1;
q__1.r = -1.f, q__1.i = 0.f;
cher2_("Lower", &i__1, &q__1, &work[1], &c__1, &work[*n + 1], &c__1, &
a[i + i * a_dim1], lda);
/* L40: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i = 1; i <= i__1; ++i) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i + 1;
wn = scnrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
d__1 = wn / c_abs(&a[*k + i + i * a_dim1]);
i__2 = *k + i + i * a_dim1;
q__1.r = d__1 * a[i__2].r, q__1.i = d__1 * a[i__2].i;
wa.r = q__1.r, wa.i = q__1.i;
if (wn == 0.f) {
tau.r = 0.f, tau.i = 0.f;
} else {
i__2 = *k + i + i * a_dim1;
q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
wb.r = q__1.r, wb.i = q__1.i;
i__2 = *n - *k - i;
c_div(&q__1, &c_b2, &wb);
cscal_(&i__2, &q__1, &a[*k + i + 1 + i * a_dim1], &c__1);
i__2 = *k + i + i * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
c_div(&q__1, &wb, &wa);
d__1 = q__1.r;
tau.r = d__1, tau.i = 0.f;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i + (i + 1)
* a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b1, &work[
1], &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
q__1.r = -(doublereal)tau.r, q__1.i = -(doublereal)tau.i;
cgerc_(&i__2, &i__3, &q__1, &a[*k + i + i * a_dim1], &c__1, &work[1],
&c__1, &a[*k + i + (i + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the rig
ht
compute y := tau * A * u */
i__2 = *n - *k - i + 1;
chemv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
q__3.r = -.5f, q__3.i = 0.f;
q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i +
q__3.i * tau.r;
i__2 = *n - *k - i + 1;
cdotc_(&q__4, &i__2, &work[1], &c__1, &a[*k + i + i * a_dim1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i
+ q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - *k - i + 1;
caxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i + 1;
q__1.r = -1.f, q__1.i = 0.f;
cher2_("Lower", &i__2, &q__1, &a[*k + i + i * a_dim1], &c__1, &work[1]
, &c__1, &a[*k + i + (*k + i) * a_dim1], lda);
i__2 = *k + i + i * a_dim1;
q__1.r = -(doublereal)wa.r, q__1.i = -(doublereal)wa.i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
i__3 = j + i * a_dim1;
a[i__3].r = 0.f, a[i__3].i = 0.f;
/* L50: */
}
/* L60: */
}
/* Store full hermitian matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = j + i * a_dim1;
r_cnjg(&q__1, &a[i + j * a_dim1]);
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of CLAGHE */
} /* claghe_slu */
/* Subroutine */ int cporfs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, complex *af, integer *ldaf, 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, af_dim1, af_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;
/* Local variables */
integer i__, j, k;
real s, xk;
integer nz;
real eps;
integer kase;
real safe1, safe2;
integer isave[3];
integer count;
logical upper;
real safmin;
real lstres;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Modified to call CLACN2 in place of CLACON, 10 Feb 03, SJH. */
/* Purpose */
/* ======= */
/* CPORFS improves the computed solution to a system of linear */
/* equations when the coefficient matrix is Hermitian positive definite, */
/* and provides error bounds and backward error estimates for the */
/* solution. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* 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 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. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input) COMPLEX array, dimension (LDAF,N) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**H*U or A = L*L**H, as computed by CPOTRF. */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= 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/output) COMPLEX array, dimension (LDX,NRHS) */
/* On entry, the solution matrix X, as computed by CPOTRS. */
/* On exit, the improved 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 */
/* Internal Parameters */
/* =================== */
/* ITMAX is the maximum number of steps of iterative refinement. */
/* ==================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_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");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
} else if (*ldaf < 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_("CPORFS", &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;
}
return 0;
}
/* 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) {
count = 1;
lstres = 3.f;
L20:
/* Loop until stopping criterion is satisfied. */
/* Compute residual R = B - A * X */
ccopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
q__1.r = -1.f, q__1.i = -0.f;
chemv_(uplo, n, &q__1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &
c_b1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula */
/* max(i) ( abs(R(i)) / ( abs(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 = i__ + j * b_dim1;
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[
i__ + j * b_dim1]), dabs(r__2));
}
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
* x_dim1]), dabs(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, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk;
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[
i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[
i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j *
x_dim1]), dabs(r__4)));
}
i__3 = k + k * a_dim1;
rwork[k] = rwork[k] + (r__1 = a[i__3].r, dabs(r__1)) * xk + s;
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k + j * x_dim1;
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[k + j
* x_dim1]), dabs(r__2));
i__3 = k + k * a_dim1;
rwork[k] += (r__1 = a[i__3].r, dabs(r__1)) * xk;
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, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + k * a_dim1]), dabs(r__2))) * xk;
i__4 = i__ + k * a_dim1;
i__5 = i__ + j * x_dim1;
s += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 = r_imag(&a[
i__ + k * a_dim1]), dabs(r__2))) * ((r__3 = x[
i__5].r, dabs(r__3)) + (r__4 = r_imag(&x[i__ + j *
x_dim1]), dabs(r__4)));
}
rwork[k] += s;
}
}
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);
}
}
berr[j] = s;
/* Test stopping criterion. Continue iterating if */
/* 1) The residual BERR(J) is larger than machine epsilon, and */
/* 2) BERR(J) decreased by at least a factor of 2 during the */
/* last iteration, and */
/* 3) At most ITMAX iterations tried. */
if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
/* Update solution and try again. */
cpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n, info);
caxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1);
lstres = berr[j];
++count;
goto L20;
}
/* Bound error from formula */
/* norm(X - XTRUE) / norm(X) .le. FERR = */
/* norm( abs(inv(A))* */
/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
/* where */
/* norm(Z) is the magnitude of the largest component of Z */
/* inv(A) is the inverse of 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(A)*abs(X)+abs(B)) */
/* is incremented by SAFE1 if the i-th component of */
/* abs(A)*abs(X) + abs(B) is less than SAFE2. */
/* Use CLACN2 to estimate the infinity-norm of the matrix */
/* inv(A) * diag(W), */
/* where W = abs(R) + NZ*EPS*( abs(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;
}
}
kase = 0;
L100:
clacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(A'). */
cpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n,
info);
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;
}
} else if (kase == 2) {
/* Multiply by inv(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;
}
cpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &work[1], n,
info);
}
goto L100;
}
/* 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, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + j * x_dim1]), dabs(r__2));
lstres = dmax(r__3,r__4);
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
}
return 0;
/* End of CPORFS */
} /* cporfs_ */
/* Subroutine */ int clatrd_(char *uplo, integer *n, integer *nb, complex *a,
integer *lda, real *e, complex *tau, complex *w, integer *ldw, ftnlen
uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3;
real r__1;
complex q__1, q__2, q__3, q__4;
/* Local variables */
static integer i__, iw;
static complex alpha;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *, ftnlen), chemv_(char *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, complex *,
integer *, ftnlen);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), clarfg_(integer *, complex *,
complex *, integer *, complex *), 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 */
/* ======= */
/* CLATRD reduces NB rows and columns of a complex Hermitian matrix A to */
/* Hermitian tridiagonal form by a unitary similarity */
/* transformation Q' * A * Q, and returns the matrices V and W which are */
/* needed to apply the transformation to the unreduced part of A. */
/* If UPLO = 'U', CLATRD reduces the last NB rows and columns of a */
/* matrix, of which the upper triangle is supplied; */
/* if UPLO = 'L', CLATRD reduces the first NB rows and columns of a */
/* matrix, of which the lower triangle is supplied. */
/* This is an auxiliary routine called by CHETRD. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER */
/* 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 order of the matrix A. */
/* NB (input) INTEGER */
/* The number of rows and columns to be reduced. */
/* 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 UPLO = 'U', the last NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements above the diagonal */
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors; */
/* if UPLO = 'L', the first NB columns have been reduced to */
/* tridiagonal form, with the diagonal elements overwriting */
/* the diagonal elements of A; the elements below the diagonal */
/* with the array TAU, represent the unitary matrix Q as a */
/* product of elementary reflectors. */
/* See Further Details. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* E (output) REAL array, dimension (N-1) */
/* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */
/* elements of the last NB columns of the reduced matrix; */
/* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */
/* the first NB columns of the reduced matrix. */
/* TAU (output) COMPLEX array, dimension (N-1) */
/* The scalar factors of the elementary reflectors, stored in */
/* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */
/* See Further Details. */
/* W (output) COMPLEX array, dimension (LDW,NB) */
/* The n-by-nb matrix W required to update the unreduced part */
/* of A. */
/* LDW (input) INTEGER */
/* The leading dimension of the array W. LDW >= max(1,N). */
/* Further Details */
/* =============== */
/* If UPLO = 'U', the matrix Q is represented as a product of elementary */
/* reflectors */
/* Q = H(n) H(n-1) . . . H(n-nb+1). */
/* 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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */
/* and tau in TAU(i-1). */
/* If UPLO = 'L', the matrix Q is represented as a product of 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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */
/* and tau in TAU(i). */
/* The elements of the vectors v together form the n-by-nb matrix V */
/* which is needed, with W, to apply the transformation to the unreduced */
/* part of the matrix, using a Hermitian rank-2k update of the form: */
/* A := A - V*W' - W*V'. */
/* The contents of A on exit are illustrated by the following examples */
/* with n = 5 and nb = 2: */
/* if UPLO = 'U': if UPLO = 'L': */
/* ( a a a v4 v5 ) ( d ) */
/* ( a a v4 v5 ) ( 1 d ) */
/* ( a 1 v5 ) ( v1 1 a ) */
/* ( d 1 ) ( v1 v2 a a ) */
/* ( d ) ( v1 v2 a a a ) */
/* where d denotes a diagonal element of the reduced matrix, a denotes */
/* an element of the original matrix that is unchanged, and vi denotes */
/* an element of the vector defining H(i). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--e;
--tau;
w_dim1 = *ldw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) {
/* Reduce last NB columns of upper triangle */
i__1 = *n - *nb + 1;
for (i__ = *n; i__ >= i__1; --i__) {
iw = i__ - *n + *nb;
if (i__ < *n) {
/* Update A(1:i,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1, a[i__2].i = 0.f;
i__2 = *n - i__;
clacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__, &i__2, &q__1, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, &
c_b2, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12);
i__2 = *n - i__;
clacgv_(&i__2, &w[i__ + (iw + 1) * w_dim1], ldw);
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__, &i__2, &q__1, &w[(iw + 1) *
w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, &
c_b2, &a[i__ * a_dim1 + 1], &c__1, (ftnlen)12);
i__2 = *n - i__;
clacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1, a[i__2].i = 0.f;
}
if (i__ > 1) {
/* Generate elementary reflector H(i) to annihilate */
/* A(1:i-2,i) */
i__2 = i__ - 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = i__ - 1;
clarfg_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &tau[i__
- 1]);
i__2 = i__ - 1;
e[i__2] = alpha.r;
i__2 = i__ - 1 + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Compute W(1:i-1,i) */
i__2 = i__ - 1;
chemv_("Upper", &i__2, &c_b2, &a[a_offset], lda, &a[i__ *
a_dim1 + 1], &c__1, &c_b1, &w[iw * w_dim1 + 1], &c__1,
(ftnlen)5);
if (i__ < *n) {
i__2 = i__ - 1;
i__3 = *n - i__;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[(iw
+ 1) * w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &
c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1, (
ftnlen)19);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[(i__ + 1) *
a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1, (ftnlen)
12);
i__2 = i__ - 1;
i__3 = *n - i__;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[(
i__ + 1) * a_dim1 + 1], lda, &a[i__ * a_dim1 + 1],
&c__1, &c_b1, &w[i__ + 1 + iw * w_dim1], &c__1, (
ftnlen)19);
i__2 = i__ - 1;
i__3 = *n - i__;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &w[(iw + 1) *
w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], &
c__1, &c_b2, &w[iw * w_dim1 + 1], &c__1, (ftnlen)
12);
}
i__2 = i__ - 1;
cscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1);
q__3.r = -.5f, q__3.i = -0.f;
i__2 = i__ - 1;
q__2.r = q__3.r * tau[i__2].r - q__3.i * tau[i__2].i, q__2.i =
q__3.r * tau[i__2].i + q__3.i * tau[i__2].r;
i__3 = i__ - 1;
cdotc_(&q__4, &i__3, &w[iw * w_dim1 + 1], &c__1, &a[i__ *
a_dim1 + 1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
q__4.i + q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = i__ - 1;
caxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw *
w_dim1 + 1], &c__1);
}
/* L10: */
}
} else {
/* Reduce first NB columns of lower triangle */
i__1 = *nb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Update A(i:n,i) */
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1, a[i__2].i = 0.f;
i__2 = i__ - 1;
clacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = *n - 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[i__ + a_dim1], lda,
&w[i__ + w_dim1], ldw, &c_b2, &a[i__ + i__ * a_dim1], &
c__1, (ftnlen)12);
i__2 = i__ - 1;
clacgv_(&i__2, &w[i__ + w_dim1], ldw);
i__2 = i__ - 1;
clacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = *n - 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, &w[i__ + w_dim1], ldw,
&a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], &
c__1, (ftnlen)12);
i__2 = i__ - 1;
clacgv_(&i__2, &a[i__ + a_dim1], lda);
i__2 = i__ + i__ * a_dim1;
i__3 = i__ + i__ * a_dim1;
r__1 = a[i__3].r;
a[i__2].r = r__1, a[i__2].i = 0.f;
if (i__ < *n) {
/* Generate elementary reflector H(i) to annihilate */
/* A(i+2:n,i) */
i__2 = i__ + 1 + i__ * a_dim1;
alpha.r = a[i__2].r, alpha.i = a[i__2].i;
i__2 = *n - i__;
/* Computing MIN */
i__3 = i__ + 2;
clarfg_(&i__2, &alpha, &a[min(i__3,*n) + i__ * a_dim1], &c__1,
&tau[i__]);
i__2 = i__;
e[i__2] = alpha.r;
i__2 = i__ + 1 + i__ * a_dim1;
a[i__2].r = 1.f, a[i__2].i = 0.f;
/* Compute W(i+1:n,i) */
i__2 = *n - i__;
chemv_("Lower", &i__2, &c_b2, &a[i__ + 1 + (i__ + 1) * a_dim1]
, lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b1, &w[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)5);
i__2 = *n - i__;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &w[i__ + 1
+ w_dim1], ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &w[i__ * w_dim1 + 1], &c__1, (ftnlen)19);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &a[i__ + 1 +
a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12);
i__2 = *n - i__;
i__3 = i__ - 1;
cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1
+ a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &
c_b1, &w[i__ * w_dim1 + 1], &c__1, (ftnlen)19);
i__2 = *n - i__;
i__3 = i__ - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("No transpose", &i__2, &i__3, &q__1, &w[i__ + 1 +
w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b2, &w[
i__ + 1 + i__ * w_dim1], &c__1, (ftnlen)12);
i__2 = *n - i__;
cscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1);
q__3.r = -.5f, q__3.i = -0.f;
i__2 = i__;
q__2.r = q__3.r * tau[i__2].r - q__3.i * tau[i__2].i, q__2.i =
q__3.r * tau[i__2].i + q__3.i * tau[i__2].r;
i__3 = *n - i__;
cdotc_(&q__4, &i__3, &w[i__ + 1 + i__ * w_dim1], &c__1, &a[
i__ + 1 + i__ * a_dim1], &c__1);
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r *
q__4.i + q__2.i * q__4.r;
alpha.r = q__1.r, alpha.i = q__1.i;
i__2 = *n - i__;
caxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[
i__ + 1 + i__ * w_dim1], &c__1);
}
/* L20: */
}
}
return 0;
/* End of CLATRD */
} /* clatrd_ */
/* Subroutine */ int chetri_(char *uplo, integer *n, complex *a, integer *lda,
integer *ipiv, complex *work, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CHETRI computes the inverse of a complex Hermitian indefinite matrix
A using the factorization A = U*D*U**H or A = L*D*L**H computed by
CHETRF.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the details of the factorization are stored
as an upper or lower triangular matrix.
= 'U': Upper triangular, form is A = U*D*U**H;
= 'L': Lower triangular, form is A = L*D*L**H.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA,N)
On entry, the block diagonal matrix D and the multipliers
used to obtain the factor U or L as computed by CHETRF.
On exit, if INFO = 0, the (Hermitian) inverse of the original
matrix. If UPLO = 'U', the upper triangular part of the
inverse is formed and the part of A below the diagonal is not
referenced; if UPLO = 'L' the lower triangular part of the
inverse is formed and the part of A above the diagonal is
not referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by CHETRF.
WORK (workspace) COMPLEX array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
inverse could not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static complex c_b2 = {0.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
complex q__1, q__2;
/* Builtin functions */
double c_abs(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static complex temp, akkp1;
static real d;
static integer j, k;
static real t;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int chemv_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, complex *, integer *
), ccopy_(integer *, complex *, integer *, complex *,
integer *), cswap_(integer *, complex *, integer *, complex *,
integer *);
static integer kstep;
static logical upper;
static real ak;
static integer kp;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real akp1;
#define IPIV(I) ipiv[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHETRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check that the diagonal matrix D is nonsingular. */
if (upper) {
/* Upper triangular storage: examine D from bottom to top */
for (*info = *n; *info >= 1; --(*info)) {
i__1 = *info + *info * a_dim1;
if (IPIV(*info) > 0 && (A(*info,*info).r == 0.f && A(*info,*info).i == 0.f)) {
return 0;
}
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = *info + *info * a_dim1;
if (IPIV(*info) > 0 && (A(*info,*info).r == 0.f && A(*info,*info).i == 0.f)) {
return 0;
}
/* L20: */
}
}
*info = 0;
if (upper) {
/* Compute inv(A) from the factorization A = U*D*U'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (IPIV(k) > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = 1.f / A(k,k).r;
A(k,k).r = d__1, A(k,k).i = 0.f;
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &A(1,k), &c__1, &WORK(1), &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
chemv_(uplo, &i__1, &q__1, &A(1,1), lda, &WORK(1), &c__1,
&c_b2, &A(1,k), &c__1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = k - 1;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &A(1,k), &
c__1);
d__1 = q__2.r;
q__1.r = A(k,k).r - d__1, q__1.i = A(k,k).i;
A(k,k).r = q__1.r, A(k,k).i = q__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = c_abs(&A(k,k+1));
i__1 = k + k * a_dim1;
ak = A(k,k).r / t;
i__1 = k + 1 + (k + 1) * a_dim1;
akp1 = A(k+1,k+1).r / t;
i__1 = k + (k + 1) * a_dim1;
q__1.r = A(k,k+1).r / t, q__1.i = A(k,k+1).i / t;
akkp1.r = q__1.r, akkp1.i = q__1.i;
d = t * (ak * akp1 - 1.f);
i__1 = k + k * a_dim1;
d__1 = akp1 / d;
A(k,k).r = d__1, A(k,k).i = 0.f;
i__1 = k + 1 + (k + 1) * a_dim1;
d__1 = ak / d;
A(k+1,k+1).r = d__1, A(k+1,k+1).i = 0.f;
i__1 = k + (k + 1) * a_dim1;
q__2.r = -(doublereal)akkp1.r, q__2.i = -(doublereal)akkp1.i;
q__1.r = q__2.r / d, q__1.i = q__2.i / d;
A(k,k+1).r = q__1.r, A(k,k+1).i = q__1.i;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &A(1,k), &c__1, &WORK(1), &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
chemv_(uplo, &i__1, &q__1, &A(1,1), lda, &WORK(1), &c__1,
&c_b2, &A(1,k), &c__1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = k - 1;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &A(1,k), &
c__1);
d__1 = q__2.r;
q__1.r = A(k,k).r - d__1, q__1.i = A(k,k).i;
A(k,k).r = q__1.r, A(k,k).i = q__1.i;
i__1 = k + (k + 1) * a_dim1;
i__2 = k + (k + 1) * a_dim1;
i__3 = k - 1;
cdotc_(&q__2, &i__3, &A(1,k), &c__1, &A(1,k+1), &c__1);
q__1.r = A(k,k+1).r - q__2.r, q__1.i = A(k,k+1).i - q__2.i;
A(k,k+1).r = q__1.r, A(k,k+1).i = q__1.i;
i__1 = k - 1;
ccopy_(&i__1, &A(1,k+1), &c__1, &WORK(1), &
c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
chemv_(uplo, &i__1, &q__1, &A(1,1), lda, &WORK(1), &c__1,
&c_b2, &A(1,k+1), &c__1);
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
i__3 = k - 1;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &A(1,k+1)
, &c__1);
d__1 = q__2.r;
q__1.r = A(k+1,k+1).r - d__1, q__1.i = A(k+1,k+1).i;
A(k+1,k+1).r = q__1.r, A(k+1,k+1).i = q__1.i;
}
kstep = 2;
}
kp = (i__1 = IPIV(k), abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the leading
submatrix A(1:k+1,1:k+1) */
i__1 = kp - 1;
cswap_(&i__1, &A(1,k), &c__1, &A(1,kp), &
c__1);
i__1 = k - 1;
for (j = kp + 1; j <= k-1; ++j) {
r_cnjg(&q__1, &A(j,k));
temp.r = q__1.r, temp.i = q__1.i;
i__2 = j + k * a_dim1;
r_cnjg(&q__1, &A(kp,j));
A(j,k).r = q__1.r, A(j,k).i = q__1.i;
i__2 = kp + j * a_dim1;
A(kp,j).r = temp.r, A(kp,j).i = temp.i;
/* L40: */
}
i__1 = kp + k * a_dim1;
r_cnjg(&q__1, &A(kp,k));
A(kp,k).r = q__1.r, A(kp,k).i = q__1.i;
i__1 = k + k * a_dim1;
temp.r = A(k,k).r, temp.i = A(k,k).i;
i__1 = k + k * a_dim1;
i__2 = kp + kp * a_dim1;
A(k,k).r = A(kp,kp).r, A(k,k).i = A(kp,kp).i;
i__1 = kp + kp * a_dim1;
A(kp,kp).r = temp.r, A(kp,kp).i = temp.i;
if (kstep == 2) {
i__1 = k + (k + 1) * a_dim1;
temp.r = A(k,k+1).r, temp.i = A(k,k+1).i;
i__1 = k + (k + 1) * a_dim1;
i__2 = kp + (k + 1) * a_dim1;
A(k,k+1).r = A(kp,k+1).r, A(k,k+1).i = A(kp,k+1).i;
i__1 = kp + (k + 1) * a_dim1;
A(kp,k+1).r = temp.r, A(kp,k+1).i = temp.i;
}
}
k += kstep;
goto L30;
L50:
;
} else {
/* Compute inv(A) from the factorization A = L*D*L'.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L60:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L80;
}
if (IPIV(k) > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
d__1 = 1.f / A(k,k).r;
A(k,k).r = d__1, A(k,k).i = 0.f;
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &A(k+1,k), &c__1, &WORK(1), &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
chemv_(uplo, &i__1, &q__1, &A(k+1,k+1), lda,
&WORK(1), &c__1, &c_b2, &A(k+1,k), &c__1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = *n - k;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &A(k+1,k),
&c__1);
d__1 = q__2.r;
q__1.r = A(k,k).r - d__1, q__1.i = A(k,k).i;
A(k,k).r = q__1.r, A(k,k).i = q__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
t = c_abs(&A(k,k-1));
i__1 = k - 1 + (k - 1) * a_dim1;
ak = A(k-1,k-1).r / t;
i__1 = k + k * a_dim1;
akp1 = A(k,k).r / t;
i__1 = k + (k - 1) * a_dim1;
q__1.r = A(k,k-1).r / t, q__1.i = A(k,k-1).i / t;
akkp1.r = q__1.r, akkp1.i = q__1.i;
d = t * (ak * akp1 - 1.f);
i__1 = k - 1 + (k - 1) * a_dim1;
d__1 = akp1 / d;
A(k-1,k-1).r = d__1, A(k-1,k-1).i = 0.f;
i__1 = k + k * a_dim1;
d__1 = ak / d;
A(k,k).r = d__1, A(k,k).i = 0.f;
i__1 = k + (k - 1) * a_dim1;
q__2.r = -(doublereal)akkp1.r, q__2.i = -(doublereal)akkp1.i;
q__1.r = q__2.r / d, q__1.i = q__2.i / d;
A(k,k-1).r = q__1.r, A(k,k-1).i = q__1.i;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &A(k+1,k), &c__1, &WORK(1), &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
chemv_(uplo, &i__1, &q__1, &A(k+1,k+1), lda,
&WORK(1), &c__1, &c_b2, &A(k+1,k), &c__1);
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
i__3 = *n - k;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &A(k+1,k),
&c__1);
d__1 = q__2.r;
q__1.r = A(k,k).r - d__1, q__1.i = A(k,k).i;
A(k,k).r = q__1.r, A(k,k).i = q__1.i;
i__1 = k + (k - 1) * a_dim1;
i__2 = k + (k - 1) * a_dim1;
i__3 = *n - k;
cdotc_(&q__2, &i__3, &A(k+1,k), &c__1, &A(k+1,k-1), &c__1);
q__1.r = A(k,k-1).r - q__2.r, q__1.i = A(k,k-1).i - q__2.i;
A(k,k-1).r = q__1.r, A(k,k-1).i = q__1.i;
i__1 = *n - k;
ccopy_(&i__1, &A(k+1,k-1), &c__1, &WORK(1), &
c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
chemv_(uplo, &i__1, &q__1, &A(k+1,k+1), lda,
&WORK(1), &c__1, &c_b2, &A(k+1,k-1),
&c__1);
i__1 = k - 1 + (k - 1) * a_dim1;
i__2 = k - 1 + (k - 1) * a_dim1;
i__3 = *n - k;
cdotc_(&q__2, &i__3, &WORK(1), &c__1, &A(k+1,k-1), &c__1);
d__1 = q__2.r;
q__1.r = A(k-1,k-1).r - d__1, q__1.i = A(k-1,k-1).i;
A(k-1,k-1).r = q__1.r, A(k-1,k-1).i = q__1.i;
}
kstep = 2;
}
kp = (i__1 = IPIV(k), abs(i__1));
if (kp != k) {
/* Interchange rows and columns K and KP in the trailing
submatrix A(k-1:n,k-1:n) */
if (kp < *n) {
i__1 = *n - kp;
cswap_(&i__1, &A(kp+1,k), &c__1, &A(kp+1,kp), &c__1);
}
i__1 = kp - 1;
for (j = k + 1; j <= kp-1; ++j) {
r_cnjg(&q__1, &A(j,k));
temp.r = q__1.r, temp.i = q__1.i;
i__2 = j + k * a_dim1;
r_cnjg(&q__1, &A(kp,j));
A(j,k).r = q__1.r, A(j,k).i = q__1.i;
i__2 = kp + j * a_dim1;
A(kp,j).r = temp.r, A(kp,j).i = temp.i;
/* L70: */
}
i__1 = kp + k * a_dim1;
r_cnjg(&q__1, &A(kp,k));
A(kp,k).r = q__1.r, A(kp,k).i = q__1.i;
i__1 = k + k * a_dim1;
temp.r = A(k,k).r, temp.i = A(k,k).i;
i__1 = k + k * a_dim1;
i__2 = kp + kp * a_dim1;
A(k,k).r = A(kp,kp).r, A(k,k).i = A(kp,kp).i;
i__1 = kp + kp * a_dim1;
A(kp,kp).r = temp.r, A(kp,kp).i = temp.i;
if (kstep == 2) {
i__1 = k + (k - 1) * a_dim1;
temp.r = A(k,k-1).r, temp.i = A(k,k-1).i;
i__1 = k + (k - 1) * a_dim1;
i__2 = kp + (k - 1) * a_dim1;
A(k,k-1).r = A(kp,k-1).r, A(k,k-1).i = A(kp,k-1).i;
i__1 = kp + (k - 1) * a_dim1;
A(kp,k-1).r = temp.r, A(kp,k-1).i = temp.i;
}
}
k -= kstep;
goto L60;
L80:
;
}
return 0;
/* End of CHETRI */
} /* chetri_ */
