void
f2c_cdotu(complex* retval,
integer* N,
complex* X, integer* incX,
complex* Y, integer* incY)
{
cdotu_(retval, N, X, incX, Y, incY);
}
complex cdotu( int n, complex *x, int incx, complex *y, int incy)
{
complex ans;
#if defined( _WIN32 ) || defined( _WIN64 )
ans = cdotu_(&n, x, &incx, y, &incy);
#else
cdotusub_(&n, x, &incx, y, &incy, &ans);
#endif
return ans;
}
/* Subroutine */ int clatrs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, complex *a, integer *lda, complex *x, real *scale,
real *cnorm, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer i__, j;
real xj, rec, tjj;
integer jinc;
real xbnd;
integer imax;
real tmax;
complex tjjs;
real xmax, grow;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal;
complex uscal;
integer jlast;
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
complex csumj;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int ctrsv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLATRS solves one of the triangular systems */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */
/* with scaling to prevent overflow. Here A is an upper or lower */
/* triangular matrix, A**T denotes the transpose of A, A**H denotes the */
/* conjugate transpose of A, x and b are n-element vectors, and s is a */
/* scaling factor, usually less than or equal to 1, chosen so that the */
/* components of x will be less than the overflow threshold. If the */
/* unscaled problem will not cause overflow, the Level 2 BLAS routine */
/* CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */
/* then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */
/* 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': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A**T * x = s*b (Transpose) */
/* = 'C': Solve 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 */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 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). */
/* X (input/output) COMPLEX array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) REAL */
/* The scaling factor s for the triangular system */
/* A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) REAL array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, CTRSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* for j = 1, ..., n */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the */
/* reciprocal of the largest M(j), j=1,..,n, is larger than */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A**T *x = b or */
/* A**H *x = b. The basic algorithm for A upper triangular is */
/* for j = 1, ..., n */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
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 (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLATRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum /= slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = scasum_(&i__2, &a[j * a_dim1 + 1], &c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = scasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1);
/* L20: */
}
cnorm[*n] = 0.f;
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM/2. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum * .5f) {
tscal = 1.f;
} else {
tscal = .5f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine CTRSV can be used. */
xmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__3 = xmax, r__4 = (r__1 = x[i__2].r / 2.f, dabs(r__1)) + (r__2 =
r_imag(&x[j]) / 2.f, dabs(r__2));
xmax = dmax(r__3,r__4);
/* L30: */
}
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L60;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__2);
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.f;
}
/* L40: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L60;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1.f / (cnorm[j] + 1.f);
/* L50: */
}
}
L60:
;
} else {
/* Compute the growth in A**T * x = b or A**H * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L90;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{x(i), i=1,...,n}. */
grow = .5f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.f;
/* Computing MIN */
r__1 = grow, r__2 = xbnd / xj;
grow = dmin(r__1,r__2);
i__3 = j + j * a_dim1;
tjjs.r = a[i__3].r, tjjs.i = a[i__3].i;
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj >= smlnum) {
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
if (xj > tjj) {
xbnd *= tjj / xj;
}
} else {
/* M(j) could overflow, set XBND to 0. */
xbnd = 0.f;
}
/* L70: */
}
grow = dmin(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = .5f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L90;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.f;
grow /= xj;
/* L80: */
}
}
L90:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
ctrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum * .5f) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum * .5f / xmax;
csscal_(n, scale, &x[1], &c__1);
xmax = bignum;
} else {
xmax *= 2.f;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3].i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L105;
}
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.f) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L105:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f) {
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
csscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */
i__3 = j - 1;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
i__3 = j - 1;
i__ = icamax_(&i__3, &x[1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
} else {
if (j < *n) {
/* Compute the update */
/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */
i__3 = *n - j;
i__4 = j;
q__2.r = -x[i__4].r, q__2.i = -x[i__4].i;
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
caxpy_(&i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
i__3 = *n - j;
i__ = j + icamax_(&i__3, &x[j + 1], &c__1);
i__3 = i__;
xmax = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__]), dabs(r__2));
}
}
/* L110: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTU to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotu_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotu_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L120: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
i__4 = i__ + j * a_dim1;
q__3.r = a[i__4].r * uscal.r - a[i__4].i *
uscal.i, q__3.i = a[i__4].r * uscal.i + a[
i__4].i * uscal.r;
i__5 = i__;
q__2.r = q__3.r * x[i__5].r - q__3.i * x[i__5].i,
q__2.i = q__3.r * x[i__5].i + q__3.i * x[
i__5].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L130: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
i__3 = j + j * a_dim1;
q__1.r = tscal * a[i__3].r, q__1.i = tscal * a[i__3]
.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L145;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**T *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L145:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L150: */
}
} else {
/* Solve A**H * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]),
dabs(r__2));
uscal.r = tscal, uscal.i = 0.f;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
}
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r, uscal.i = q__1.i;
}
if (rec < 1.f) {
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f, csumj.i = 0.f;
if (uscal.r == 1.f && uscal.i == 0.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call CDOTC to perform the dot product. */
if (upper) {
i__3 = j - 1;
cdotc_(&q__1, &i__3, &a[j * a_dim1 + 1], &c__1, &x[1],
&c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
} else if (j < *n) {
i__3 = *n - j;
cdotc_(&q__1, &i__3, &a[j + 1 + j * a_dim1], &c__1, &
x[j + 1], &c__1);
csumj.r = q__1.r, csumj.i = q__1.i;
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
i__3 = j - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L160: */
}
} else if (j < *n) {
i__3 = *n;
for (i__ = j + 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &a[i__ + j * a_dim1]);
q__3.r = q__4.r * uscal.r - q__4.i * uscal.i,
q__3.i = q__4.r * uscal.i + q__4.i *
uscal.r;
i__4 = i__;
q__2.r = q__3.r * x[i__4].r - q__3.i * x[i__4].i,
q__2.i = q__3.r * x[i__4].i + q__3.i * x[
i__4].r;
q__1.r = csumj.r + q__2.r, q__1.i = csumj.i +
q__2.i;
csumj.r = q__1.r, csumj.i = q__1.i;
/* L170: */
}
}
}
q__1.r = tscal, q__1.i = 0.f;
if (uscal.r == q__1.r && uscal.i == q__1.i) {
/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
i__3 = j;
i__4 = j;
q__1.r = x[i__4].r - csumj.r, q__1.i = x[i__4].i -
csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
i__3 = j;
xj = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&x[j]
), dabs(r__2));
if (nounit) {
r_cnjg(&q__2, &a[j + j * a_dim1]);
q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
tjjs.r = q__1.r, tjjs.i = q__1.i;
} else {
tjjs.r = tscal, tjjs.i = 0.f;
if (tscal == 1.f) {
goto L185;
}
}
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjj = (r__1 = tjjs.r, dabs(r__1)) + (r__2 = r_imag(&tjjs),
dabs(r__2));
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
i__3 = j;
cladiv_(&q__1, &x[j], &tjjs);
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0 and compute a solution to A**H *x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = i__;
x[i__4].r = 0.f, x[i__4].i = 0.f;
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f, x[i__3].i = 0.f;
*scale = 0.f;
xmax = 0.f;
}
L185:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */
/* product has already been divided by 1/A(j,j). */
i__3 = j;
cladiv_(&q__2, &x[j], &tjjs);
q__1.r = q__2.r - csumj.r, q__1.i = q__2.i - csumj.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
}
/* Computing MAX */
i__3 = j;
r__3 = xmax, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[j]), dabs(r__2));
xmax = dmax(r__3,r__4);
/* L190: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f) {
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of CLATRS */
} /* clatrs_ */
/* DECK CSPCO */
/* Subroutine */ int cspco_(complex *ap, integer *n, integer *kpvt, real *
rcond, complex *z__)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8;
complex q__1, q__2, q__3;
/* Local variables */
static integer i__, j, k;
static real s;
static complex t;
static integer j1;
static complex ak, bk, ek;
static integer ij, ik, kk, kp, ks, jm1, kps;
static complex akm1, bkm1;
static integer ikm1, km1k, ikp1, info;
extern /* Subroutine */ int cspfa_(complex *, integer *, integer *,
integer *);
static integer km1km1;
static complex denom;
static real anorm;
extern /* Complex */ void cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static real ynorm;
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
extern doublereal scasum_(integer *, complex *, integer *);
/* ***BEGIN PROLOGUE CSPCO */
/* ***PURPOSE Factor a complex symmetric matrix stored in packed form */
/* by elimination with symmetric pivoting and estimate the */
/* condition number of the matrix. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2C1 */
/* ***TYPE COMPLEX (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C) */
/* ***KEYWORDS CONDITION NUMBER, LINEAR ALGEBRA, LINPACK, */
/* MATRIX FACTORIZATION, PACKED, SYMMETRIC */
/* ***AUTHOR Moler, C. B., (U. of New Mexico) */
/* ***DESCRIPTION */
/* CSPCO factors a complex symmetric matrix stored in packed */
/* form by elimination with symmetric pivoting and estimates */
/* the condition of the matrix. */
/* If RCOND is not needed, CSPFA is slightly faster. */
/* To solve A*X = B , follow CSPCO by CSPSL. */
/* To compute INVERSE(A)*C , follow CSPCO by CSPSL. */
/* To compute INVERSE(A) , follow CSPCO by CSPDI. */
/* To compute DETERMINANT(A) , follow CSPCO by CSPDI. */
/* On Entry */
/* AP COMPLEX (N*(N+1)/2) */
/* the packed form of a symmetric matrix A . The */
/* columns of the upper triangle are stored sequentially */
/* in a one-dimensional array of length N*(N+1)/2 . */
/* See comments below for details. */
/* N INTEGER */
/* the order of the matrix A . */
/* On Return */
/* AP a block diagonal matrix and the multipliers which */
/* were used to obtain it stored in packed form. */
/* The factorization can be written A = U*D*TRANS(U) */
/* where U is a product of permutation and unit */
/* upper triangular matrices , TRANS(U) is the */
/* transpose of U , and D is block diagonal */
/* with 1 by 1 and 2 by 2 blocks. */
/* KVPT INTEGER(N) */
/* an integer vector of pivot indices. */
/* RCOND REAL */
/* an estimate of the reciprocal condition of A . */
/* For the system A*X = B , relative perturbations */
/* in A and B of size EPSILON may cause */
/* relative perturbations in X of size EPSILON/RCOND . */
/* If RCOND is so small that the logical expression */
/* 1.0 + RCOND .EQ. 1.0 */
/* is true, then A may be singular to working */
/* precision. In particular, RCOND is zero if */
/* exact singularity is detected or the estimate */
/* underflows. */
/* Z COMPLEX(N) */
/* a work vector whose contents are usually unimportant. */
/* If A is close to a singular matrix, then Z is */
/* an approximate null vector in the sense that */
/* NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . */
/* Packed Storage */
/* The following program segment will pack the upper */
/* triangle of a symmetric matrix. */
/* K = 0 */
/* DO 20 J = 1, N */
/* DO 10 I = 1, J */
/* K = K + 1 */
/* AP(K) = A(I,J) */
/* 10 CONTINUE */
/* 20 CONTINUE */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CDOTU, CSPFA, CSSCAL, SCASUM */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891107 Corrected category and modified routine equivalence */
/* list. (WRB) */
/* 891107 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CSPCO */
/* FIND NORM OF A USING ONLY UPPER HALF */
/* ***FIRST EXECUTABLE STATEMENT CSPCO */
/* Parameter adjustments */
--z__;
--kpvt;
--ap;
/* Function Body */
j1 = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
r__1 = scasum_(&j, &ap[j1], &c__1);
q__1.r = r__1, q__1.i = 0.f;
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
ij = j1;
j1 += j;
jm1 = j - 1;
if (jm1 < 1) {
goto L20;
}
i__2 = jm1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = ij;
r__3 = z__[i__4].r + ((r__1 = ap[i__5].r, dabs(r__1)) + (r__2 =
r_imag(&ap[ij]), dabs(r__2)));
q__1.r = r__3, q__1.i = 0.f;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
++ij;
/* L10: */
}
L20:
/* L30: */
;
}
anorm = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = j;
r__1 = anorm, r__2 = z__[i__2].r;
anorm = dmax(r__1,r__2);
/* L40: */
}
/* FACTOR */
cspfa_(&ap[1], n, &kpvt[1], &info);
/* RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . */
/* ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . */
/* THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL */
/* GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . */
/* THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. */
/* SOLVE U*D*W = E */
ek.r = 1.f, ek.i = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
z__[i__2].r = 0.f, z__[i__2].i = 0.f;
/* L50: */
}
k = *n;
ik = *n * (*n - 1) / 2;
L60:
if (k == 0) {
goto L120;
}
kk = ik + k;
ikm1 = ik - (k - 1);
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
kp = (i__1 = kpvt[k], abs(i__1));
kps = k + 1 - ks;
if (kp == kps) {
goto L70;
}
i__1 = kps;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = kps;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L70:
i__1 = k;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(r__2)
) != 0.f) {
r__7 = (r__3 = ek.r, dabs(r__3)) + (r__4 = r_imag(&ek), dabs(r__4));
i__2 = k;
i__3 = k;
r__8 = (r__5 = z__[i__3].r, dabs(r__5)) + (r__6 = r_imag(&z__[k]),
dabs(r__6));
q__2.r = z__[i__2].r / r__8, q__2.i = z__[i__2].i / r__8;
q__1.r = r__7 * q__2.r, q__1.i = r__7 * q__2.i;
ek.r = q__1.r, ek.i = q__1.i;
}
i__1 = k;
i__2 = k;
q__1.r = z__[i__2].r + ek.r, q__1.i = z__[i__2].i + ek.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - ks;
caxpy_(&i__1, &z__[k], &ap[ik + 1], &c__1, &z__[1], &c__1);
if (ks == 1) {
goto L80;
}
i__1 = k - 1;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k - 1]), dabs(
r__2)) != 0.f) {
r__7 = (r__3 = ek.r, dabs(r__3)) + (r__4 = r_imag(&ek), dabs(r__4));
i__2 = k - 1;
i__3 = k - 1;
r__8 = (r__5 = z__[i__3].r, dabs(r__5)) + (r__6 = r_imag(&z__[k - 1]),
dabs(r__6));
q__2.r = z__[i__2].r / r__8, q__2.i = z__[i__2].i / r__8;
q__1.r = r__7 * q__2.r, q__1.i = r__7 * q__2.i;
ek.r = q__1.r, ek.i = q__1.i;
}
i__1 = k - 1;
i__2 = k - 1;
q__1.r = z__[i__2].r + ek.r, q__1.i = z__[i__2].i + ek.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - ks;
caxpy_(&i__1, &z__[k - 1], &ap[ikm1 + 1], &c__1, &z__[1], &c__1);
L80:
if (ks == 2) {
goto L100;
}
i__1 = k;
i__2 = kk;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(r__2)
) <= (r__3 = ap[i__2].r, dabs(r__3)) + (r__4 = r_imag(&ap[kk]),
dabs(r__4))) {
goto L90;
}
i__1 = kk;
i__2 = k;
s = ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2)
)) / ((r__3 = z__[i__2].r, dabs(r__3)) + (r__4 = r_imag(&z__[k]),
dabs(r__4)));
csscal_(n, &s, &z__[1], &c__1);
q__2.r = s, q__2.i = 0.f;
q__1.r = q__2.r * ek.r - q__2.i * ek.i, q__1.i = q__2.r * ek.i + q__2.i *
ek.r;
ek.r = q__1.r, ek.i = q__1.i;
L90:
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
!= 0.f) {
i__2 = k;
c_div(&q__1, &z__[k], &ap[kk]);
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
}
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
== 0.f) {
i__2 = k;
z__[i__2].r = 1.f, z__[i__2].i = 0.f;
}
goto L110;
L100:
km1k = ik + k - 1;
km1km1 = ikm1 + k - 1;
c_div(&q__1, &ap[kk], &ap[km1k]);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &ap[km1km1], &ap[km1k]);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &z__[k], &ap[km1k]);
bk.r = q__1.r, bk.i = q__1.i;
c_div(&q__1, &z__[k - 1], &ap[km1k]);
bkm1.r = q__1.r, bkm1.i = q__1.i;
q__2.r = ak.r * akm1.r - ak.i * akm1.i, q__2.i = ak.r * akm1.i + ak.i *
akm1.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = k;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * bk.i + akm1.i *
bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - 1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * bkm1.i + ak.i *
bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
L110:
k -= ks;
ik -= k;
if (ks == 2) {
ik -= k + 1;
}
goto L60;
L120:
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
/* SOLVE TRANS(U)*Y = W */
k = 1;
ik = 0;
L130:
if (k > *n) {
goto L160;
}
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
if (k == 1) {
goto L150;
}
i__1 = k;
i__2 = k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ik + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
ikp1 = ik + k;
if (ks == 2) {
i__1 = k + 1;
i__2 = k + 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ikp1 + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
}
kp = (i__1 = kpvt[k], abs(i__1));
if (kp == k) {
goto L140;
}
i__1 = k;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = k;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L140:
L150:
ik += k;
if (ks == 2) {
ik += k + 1;
}
k += ks;
goto L130;
L160:
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = 1.f;
/* SOLVE U*D*V = Y */
k = *n;
ik = *n * (*n - 1) / 2;
L170:
if (k == 0) {
goto L230;
}
kk = ik + k;
ikm1 = ik - (k - 1);
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
if (k == ks) {
goto L190;
}
kp = (i__1 = kpvt[k], abs(i__1));
kps = k + 1 - ks;
if (kp == kps) {
goto L180;
}
i__1 = kps;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = kps;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L180:
i__1 = k - ks;
caxpy_(&i__1, &z__[k], &ap[ik + 1], &c__1, &z__[1], &c__1);
if (ks == 2) {
i__1 = k - ks;
caxpy_(&i__1, &z__[k - 1], &ap[ikm1 + 1], &c__1, &z__[1], &c__1);
}
L190:
if (ks == 2) {
goto L210;
}
i__1 = k;
i__2 = kk;
if ((r__1 = z__[i__1].r, dabs(r__1)) + (r__2 = r_imag(&z__[k]), dabs(r__2)
) <= (r__3 = ap[i__2].r, dabs(r__3)) + (r__4 = r_imag(&ap[kk]),
dabs(r__4))) {
goto L200;
}
i__1 = kk;
i__2 = k;
s = ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2)
)) / ((r__3 = z__[i__2].r, dabs(r__3)) + (r__4 = r_imag(&z__[k]),
dabs(r__4)));
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
L200:
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
!= 0.f) {
i__2 = k;
c_div(&q__1, &z__[k], &ap[kk]);
z__[i__2].r = q__1.r, z__[i__2].i = q__1.i;
}
i__1 = kk;
if ((r__1 = ap[i__1].r, dabs(r__1)) + (r__2 = r_imag(&ap[kk]), dabs(r__2))
== 0.f) {
i__2 = k;
z__[i__2].r = 1.f, z__[i__2].i = 0.f;
}
goto L220;
L210:
km1k = ik + k - 1;
km1km1 = ikm1 + k - 1;
c_div(&q__1, &ap[kk], &ap[km1k]);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &ap[km1km1], &ap[km1k]);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &z__[k], &ap[km1k]);
bk.r = q__1.r, bk.i = q__1.i;
c_div(&q__1, &z__[k - 1], &ap[km1k]);
bkm1.r = q__1.r, bkm1.i = q__1.i;
q__2.r = ak.r * akm1.r - ak.i * akm1.i, q__2.i = ak.r * akm1.i + ak.i *
akm1.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = k;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * bk.i + akm1.i *
bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
i__1 = k - 1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * bkm1.i + ak.i *
bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
L220:
k -= ks;
ik -= k;
if (ks == 2) {
ik -= k + 1;
}
goto L170;
L230:
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
/* SOLVE TRANS(U)*Z = V */
k = 1;
ik = 0;
L240:
if (k > *n) {
goto L270;
}
ks = 1;
if (kpvt[k] < 0) {
ks = 2;
}
if (k == 1) {
goto L260;
}
i__1 = k;
i__2 = k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ik + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
ikp1 = ik + k;
if (ks == 2) {
i__1 = k + 1;
i__2 = k + 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ikp1 + 1], &c__1, &z__[1], &c__1);
q__1.r = z__[i__2].r + q__2.r, q__1.i = z__[i__2].i + q__2.i;
z__[i__1].r = q__1.r, z__[i__1].i = q__1.i;
}
kp = (i__1 = kpvt[k], abs(i__1));
if (kp == k) {
goto L250;
}
i__1 = k;
t.r = z__[i__1].r, t.i = z__[i__1].i;
i__1 = k;
i__2 = kp;
z__[i__1].r = z__[i__2].r, z__[i__1].i = z__[i__2].i;
i__1 = kp;
z__[i__1].r = t.r, z__[i__1].i = t.i;
L250:
L260:
ik += k;
if (ks == 2) {
ik += k + 1;
}
k += ks;
goto L240;
L270:
/* MAKE ZNORM = 1.0 */
s = 1.f / scasum_(n, &z__[1], &c__1);
csscal_(n, &s, &z__[1], &c__1);
ynorm = s * ynorm;
if (anorm != 0.f) {
*rcond = ynorm / anorm;
}
if (anorm == 0.f) {
*rcond = 0.f;
}
return 0;
} /* cspco_ */
/* DECK CSIDI */
/* Subroutine */ int csidi_(complex *a, integer *lda, integer *n, integer *
kpvt, complex *det, complex *work, integer *job)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
static complex d__;
static integer j, k;
static complex t, ak;
static integer jb, ks, km1;
static real ten;
static complex akp1, temp, akkp1;
static logical nodet;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
extern /* Complex */ void cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static integer kstep;
static logical noinv;
/* ***BEGIN PROLOGUE CSIDI */
/* ***PURPOSE Compute the determinant and inverse of a complex symmetric */
/* matrix using the factors from CSIFA. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2C1, D3C1 */
/* ***TYPE COMPLEX (SSIDI-S, DSIDI-D, CHIDI-C, CSIDI-C) */
/* ***KEYWORDS DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX, */
/* SYMMETRIC */
/* ***AUTHOR Bunch, J., (UCSD) */
/* ***DESCRIPTION */
/* CSIDI computes the determinant and inverse */
/* of a complex symmetric matrix using the factors from CSIFA. */
/* On Entry */
/* A COMPLEX(LDA,N) */
/* the output from CSIFA. */
/* LDA INTEGER */
/* the leading dimension of the array A . */
/* N INTEGER */
/* the order of the matrix A . */
/* KVPT INTEGER(N) */
/* the pivot vector from CSIFA. */
/* WORK COMPLEX(N) */
/* work vector. Contents destroyed. */
/* JOB INTEGER */
/* JOB has the decimal expansion AB where */
/* If B .NE. 0, the inverse is computed, */
/* If A .NE. 0, the determinant is computed, */
/* For example, JOB = 11 gives both. */
/* On Return */
/* Variables not requested by JOB are not used. */
/* A contains the upper triangle of the inverse of */
/* the original matrix. The strict lower triangle */
/* is never referenced. */
/* DET COMPLEX(2) */
/* determinant of original matrix. */
/* Determinant = DET(1) * 10.0**DET(2) */
/* with 1.0 .LE. ABS(DET(1)) .LT. 10.0 */
/* or DET(1) = 0.0. */
/* Error Condition */
/* A division by zero may occur if the inverse is requested */
/* and CSICO has set RCOND .EQ. 0.0 */
/* or CSIFA has set INFO .NE. 0 . */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CCOPY, CDOTU, CSWAP */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891107 Corrected category and modified routine equivalence */
/* list. (WRB) */
/* 891107 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CSIDI */
/* ***FIRST EXECUTABLE STATEMENT CSIDI */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--kpvt;
--det;
--work;
/* Function Body */
noinv = *job % 10 == 0;
nodet = *job % 100 / 10 == 0;
if (nodet) {
goto L100;
}
det[1].r = 1.f, det[1].i = 0.f;
det[2].r = 0.f, det[2].i = 0.f;
ten = 10.f;
t.r = 0.f, t.i = 0.f;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
i__2 = k + k * a_dim1;
d__.r = a[i__2].r, d__.i = a[i__2].i;
/* CHECK IF 1 BY 1 */
if (kpvt[k] > 0) {
goto L30;
}
/* 2 BY 2 BLOCK */
/* USE DET (D T) = (D/T * C - T) * T */
/* (T C) */
/* TO AVOID UNDERFLOW/OVERFLOW TROUBLES. */
/* TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. */
if ((r__1 = t.r, dabs(r__1)) + (r__2 = r_imag(&t), dabs(r__2)) != 0.f)
{
goto L10;
}
i__2 = k + (k + 1) * a_dim1;
t.r = a[i__2].r, t.i = a[i__2].i;
c_div(&q__3, &d__, &t);
i__2 = k + 1 + (k + 1) * a_dim1;
q__2.r = q__3.r * a[i__2].r - q__3.i * a[i__2].i, q__2.i = q__3.r * a[
i__2].i + q__3.i * a[i__2].r;
q__1.r = q__2.r - t.r, q__1.i = q__2.i - t.i;
d__.r = q__1.r, d__.i = q__1.i;
goto L20;
L10:
d__.r = t.r, d__.i = t.i;
t.r = 0.f, t.i = 0.f;
L20:
L30:
q__1.r = d__.r * det[1].r - d__.i * det[1].i, q__1.i = d__.r * det[1]
.i + d__.i * det[1].r;
det[1].r = q__1.r, det[1].i = q__1.i;
if ((r__1 = det[1].r, dabs(r__1)) + (r__2 = r_imag(&det[1]), dabs(
r__2)) == 0.f) {
goto L80;
}
L40:
if ((r__1 = det[1].r, dabs(r__1)) + (r__2 = r_imag(&det[1]), dabs(
r__2)) >= 1.f) {
goto L50;
}
q__2.r = ten, q__2.i = 0.f;
q__1.r = q__2.r * det[1].r - q__2.i * det[1].i, q__1.i = q__2.r * det[
1].i + q__2.i * det[1].r;
det[1].r = q__1.r, det[1].i = q__1.i;
q__1.r = det[2].r - 1.f, q__1.i = det[2].i - 0.f;
det[2].r = q__1.r, det[2].i = q__1.i;
goto L40;
L50:
L60:
if ((r__1 = det[1].r, dabs(r__1)) + (r__2 = r_imag(&det[1]), dabs(
r__2)) < ten) {
goto L70;
}
q__2.r = ten, q__2.i = 0.f;
c_div(&q__1, &det[1], &q__2);
det[1].r = q__1.r, det[1].i = q__1.i;
q__1.r = det[2].r + 1.f, q__1.i = det[2].i + 0.f;
det[2].r = q__1.r, det[2].i = q__1.i;
goto L60;
L70:
L80:
/* L90: */
;
}
L100:
/* COMPUTE INVERSE(A) */
if (noinv) {
goto L230;
}
k = 1;
L110:
if (k > *n) {
goto L220;
}
km1 = k - 1;
if (kpvt[k] < 0) {
goto L140;
}
/* 1 BY 1 */
i__1 = k + k * a_dim1;
c_div(&q__1, &c_b3, &a[k + k * a_dim1]);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
if (km1 < 1) {
goto L130;
}
ccopy_(&km1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = km1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
cdotu_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j - 1;
caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1],
&c__1);
/* L120: */
}
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
cdotu_(&q__2, &km1, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1);
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
L130:
kstep = 1;
goto L180;
L140:
/* 2 BY 2 */
i__1 = k + (k + 1) * a_dim1;
t.r = a[i__1].r, t.i = a[i__1].i;
c_div(&q__1, &a[k + k * a_dim1], &t);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &t);
akp1.r = q__1.r, akp1.i = q__1.i;
c_div(&q__1, &a[k + (k + 1) * a_dim1], &t);
akkp1.r = q__1.r, akkp1.i = q__1.i;
q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i + ak.i *
akp1.r;
q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i *
q__2.r;
d__.r = q__1.r, d__.i = q__1.i;
i__1 = k + k * a_dim1;
c_div(&q__1, &akp1, &d__);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = k + 1 + (k + 1) * a_dim1;
c_div(&q__1, &ak, &d__);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = k + (k + 1) * a_dim1;
q__2.r = -akkp1.r, q__2.i = -akkp1.i;
c_div(&q__1, &q__2, &d__);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
if (km1 < 1) {
goto L170;
}
ccopy_(&km1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = km1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + (k + 1) * a_dim1;
cdotu_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j - 1;
caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[(k + 1) *
a_dim1 + 1], &c__1);
/* L150: */
}
i__1 = k + 1 + (k + 1) * a_dim1;
i__2 = k + 1 + (k + 1) * a_dim1;
cdotu_(&q__2, &km1, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = k + (k + 1) * a_dim1;
i__2 = k + (k + 1) * a_dim1;
cdotu_(&q__2, &km1, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) * a_dim1 + 1], &
c__1);
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
ccopy_(&km1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
i__1 = km1;
for (j = 1; j <= i__1; ++j) {
i__2 = j + k * a_dim1;
cdotu_(&q__1, &j, &a[j * a_dim1 + 1], &c__1, &work[1], &c__1);
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
i__2 = j - 1;
caxpy_(&i__2, &work[j], &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1],
&c__1);
/* L160: */
}
i__1 = k + k * a_dim1;
i__2 = k + k * a_dim1;
cdotu_(&q__2, &km1, &work[1], &c__1, &a[k * a_dim1 + 1], &c__1);
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
L170:
kstep = 2;
L180:
/* SWAP */
ks = (i__1 = kpvt[k], abs(i__1));
if (ks == k) {
goto L210;
}
cswap_(&ks, &a[ks * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1);
i__1 = k;
for (jb = ks; jb <= i__1; ++jb) {
j = k + ks - jb;
i__2 = j + k * a_dim1;
temp.r = a[i__2].r, temp.i = a[i__2].i;
i__2 = j + k * a_dim1;
i__3 = ks + j * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = ks + j * a_dim1;
a[i__2].r = temp.r, a[i__2].i = temp.i;
/* L190: */
}
if (kstep == 1) {
goto L200;
}
i__1 = ks + (k + 1) * a_dim1;
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = ks + (k + 1) * a_dim1;
i__2 = k + (k + 1) * a_dim1;
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = k + (k + 1) * a_dim1;
a[i__1].r = temp.r, a[i__1].i = temp.i;
L200:
L210:
k += kstep;
goto L110;
L220:
L230:
return 0;
} /* csidi_ */
int csptri_(char *uplo, int *n, complex *ap, int *
ipiv, complex *work, int *info)
{
/* System generated locals */
int i__1, i__2, i__3;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
complex d__;
int j, k;
complex t, ak;
int kc, kp, kx, kpc, npp;
complex akp1, temp, akkp1;
extern int lsame_(char *, char *);
extern int ccopy_(int *, complex *, int *,
complex *, int *);
extern /* Complex */ VOID cdotu_(complex *, int *, complex *, int
*, complex *, int *);
extern int cswap_(int *, complex *, int *,
complex *, int *);
int kstep;
extern int cspmv_(char *, int *, complex *, complex *
, complex *, int *, complex *, complex *, int *);
int upper;
extern int xerbla_(char *, int *);
int kcnext;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSPTRI computes the inverse of a complex symmetric indefinite matrix */
/* A in packed storage using the factorization A = U*D*U**T or */
/* A = L*D*L**T computed by CSPTRF. */
/* 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**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the block diagonal matrix D and the multipliers */
/* used to obtain the factor U or L as computed by CSPTRF, */
/* stored as a packed triangular matrix. */
/* On exit, if INFO = 0, the (symmetric) inverse of the original */
/* matrix, stored as a packed triangular matrix. The j-th column */
/* of inv(A) is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
/* if UPLO = 'L', */
/* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by CSPTRF. */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--work;
--ipiv;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSPTRI", &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 */
kp = *n * (*n + 1) / 2;
for (*info = *n; *info >= 1; --(*info)) {
i__1 = kp;
if (ipiv[*info] > 0 && (ap[i__1].r == 0.f && ap[i__1].i == 0.f)) {
return 0;
}
kp -= *info;
/* L10: */
}
} else {
/* Lower triangular storage: examine D from top to bottom. */
kp = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = kp;
if (ipiv[*info] > 0 && (ap[i__2].r == 0.f && ap[i__2].i == 0.f)) {
return 0;
}
kp = kp + *n - *info + 1;
/* 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;
kc = 1;
L30:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
kcnext = kc + k;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
i__1 = kc + k - 1;
c_div(&q__1, &c_b1, &ap[kc + k - 1]);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kc], &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
i__1 = kcnext + k - 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
c_div(&q__1, &ap[kc + k - 1], &t);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &ap[kcnext + k], &t);
akp1.r = q__1.r, akp1.i = q__1.i;
c_div(&q__1, &ap[kcnext + k - 1], &t);
akkp1.r = q__1.r, akkp1.i = q__1.i;
q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i +
ak.i * akp1.r;
q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i
* q__2.r;
d__.r = q__1.r, d__.i = q__1.i;
i__1 = kc + k - 1;
c_div(&q__1, &akp1, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kcnext + k;
c_div(&q__1, &ak, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kcnext + k - 1;
q__2.r = -akkp1.r, q__2.i = -akkp1.i;
c_div(&q__1, &q__2, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
/* Compute columns K and K+1 of the inverse. */
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kc], &c__1);
i__1 = kc + k - 1;
i__2 = kc + k - 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kcnext + k - 1;
i__2 = kcnext + k - 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = k - 1;
ccopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[1], &work[1], &c__1, &c_b2, &
ap[kcnext], &c__1);
i__1 = kcnext + k;
i__2 = kcnext + k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
}
kstep = 2;
kcnext = kcnext + k + 1;
}
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) */
kpc = (kp - 1) * kp / 2 + 1;
i__1 = kp - 1;
cswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
kx = kpc + kp - 1;
i__1 = k - 1;
for (j = kp + 1; j <= i__1; ++j) {
kx = kx + j - 1;
i__2 = kc + j - 1;
temp.r = ap[i__2].r, temp.i = ap[i__2].i;
i__2 = kc + j - 1;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = temp.r, ap[i__2].i = temp.i;
/* L40: */
}
i__1 = kc + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc + k - 1;
i__2 = kpc + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
if (kstep == 2) {
i__1 = kc + k + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc + k + k - 1;
i__2 = kc + k + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc + k + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
}
}
k += kstep;
kc = kcnext;
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. */
npp = *n * (*n + 1) / 2;
k = *n;
kc = npp;
L60:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L80;
}
kcnext = kc - (*n - k + 2);
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Invert the diagonal block. */
i__1 = kc;
c_div(&q__1, &c_b1, &ap[kc]);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[kc + *n - k + 1], &work[1], &
c__1, &c_b2, &ap[kc + 1], &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block */
/* Invert the diagonal block. */
i__1 = kcnext + 1;
t.r = ap[i__1].r, t.i = ap[i__1].i;
c_div(&q__1, &ap[kcnext], &t);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &ap[kc], &t);
akp1.r = q__1.r, akp1.i = q__1.i;
c_div(&q__1, &ap[kcnext + 1], &t);
akkp1.r = q__1.r, akkp1.i = q__1.i;
q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i +
ak.i * akp1.r;
q__2.r = q__3.r - 1.f, q__2.i = q__3.i - 0.f;
q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i
* q__2.r;
d__.r = q__1.r, d__.i = q__1.i;
i__1 = kcnext;
c_div(&q__1, &akp1, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kc;
c_div(&q__1, &ak, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kcnext + 1;
q__2.r = -akkp1.r, q__2.i = -akkp1.i;
c_div(&q__1, &q__2, &d__);
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
/* Compute columns K-1 and K of the inverse. */
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[kc + (*n - k + 1)], &work[1], &
c__1, &c_b2, &ap[kc + 1], &c__1);
i__1 = kc;
i__2 = kc;
i__3 = *n - k;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = kcnext + 1;
i__2 = kcnext + 1;
i__3 = *n - k;
cdotu_(&q__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], &
c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
i__1 = *n - k;
ccopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cspmv_(uplo, &i__1, &q__1, &ap[kc + (*n - k + 1)], &work[1], &
c__1, &c_b2, &ap[kcnext + 2], &c__1);
i__1 = kcnext;
i__2 = kcnext;
i__3 = *n - k;
cdotu_(&q__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1);
q__1.r = ap[i__2].r - q__2.r, q__1.i = ap[i__2].i - q__2.i;
ap[i__1].r = q__1.r, ap[i__1].i = q__1.i;
}
kstep = 2;
kcnext -= *n - k + 3;
}
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) */
kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
if (kp < *n) {
i__1 = *n - kp;
cswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
c__1);
}
kx = kc + kp - k;
i__1 = kp - 1;
for (j = k + 1; j <= i__1; ++j) {
kx = kx + *n - j + 1;
i__2 = kc + j - k;
temp.r = ap[i__2].r, temp.i = ap[i__2].i;
i__2 = kc + j - k;
i__3 = kx;
ap[i__2].r = ap[i__3].r, ap[i__2].i = ap[i__3].i;
i__2 = kx;
ap[i__2].r = temp.r, ap[i__2].i = temp.i;
/* L70: */
}
i__1 = kc;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc;
i__2 = kpc;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kpc;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
if (kstep == 2) {
i__1 = kc - *n + k - 1;
temp.r = ap[i__1].r, temp.i = ap[i__1].i;
i__1 = kc - *n + k - 1;
i__2 = kc - *n + kp - 1;
ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i;
i__1 = kc - *n + kp - 1;
ap[i__1].r = temp.r, ap[i__1].i = temp.i;
}
}
k -= kstep;
kc = kcnext;
goto L60;
L80:
;
}
return 0;
/* End of CSPTRI */
} /* csptri_ */
/* DECK CSPSL */
/* Subroutine */ int cspsl_(complex *ap, integer *n, integer *kpvt, complex *
b)
{
/* System generated locals */
integer i__1, i__2, i__3;
complex q__1, q__2, q__3;
/* Local variables */
static integer k;
static complex ak, bk;
static integer ik, kk, kp;
static complex akm1, bkm1;
static integer ikm1, km1k, ikp1;
static complex temp;
static integer km1km1;
static complex denom;
extern /* Complex */ void cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
/* ***BEGIN PROLOGUE CSPSL */
/* ***PURPOSE Solve a complex symmetric system using the factors obtained */
/* from CSPFA. */
/* ***LIBRARY SLATEC (LINPACK) */
/* ***CATEGORY D2C1 */
/* ***TYPE COMPLEX (SSPSL-S, DSPSL-D, CHPSL-C, CSPSL-C) */
/* ***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, PACKED, SOLVE, SYMMETRIC */
/* ***AUTHOR Bunch, J., (UCSD) */
/* ***DESCRIPTION */
/* CSISL solves the complex symmetric system */
/* A * X = B */
/* using the factors computed by CSPFA. */
/* On Entry */
/* AP COMPLEX(N*(N+1)/2) */
/* the output from CSPFA. */
/* N INTEGER */
/* the order of the matrix A . */
/* KVPT INTEGER(N) */
/* the pivot vector from CSPFA. */
/* B COMPLEX(N) */
/* the right hand side vector. */
/* On Return */
/* B the solution vector X . */
/* Error Condition */
/* A division by zero may occur if CSPCO has set RCOND .EQ. 0.0 */
/* or CSPFA has set INFO .NE. 0 . */
/* To compute INVERSE(A) * C where C is a matrix */
/* with P columns */
/* CALL CSPFA(AP,N,KVPT,INFO) */
/* IF (INFO .NE. 0) GO TO ... */
/* DO 10 J = 1, P */
/* CALL CSPSL(AP,N,KVPT,C(1,J)) */
/* 10 CONTINUE */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CAXPY, CDOTU */
/* ***REVISION HISTORY (YYMMDD) */
/* 780814 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891107 Corrected category and modified routine equivalence */
/* list. (WRB) */
/* 891107 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CSPSL */
/* LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND */
/* D INVERSE TO B. */
/* ***FIRST EXECUTABLE STATEMENT CSPSL */
/* Parameter adjustments */
--b;
--kpvt;
--ap;
/* Function Body */
k = *n;
ik = *n * (*n - 1) / 2;
L10:
if (k == 0) {
goto L80;
}
kk = ik + k;
if (kpvt[k] < 0) {
goto L40;
}
/* 1 X 1 PIVOT BLOCK. */
if (k == 1) {
goto L30;
}
kp = kpvt[k];
if (kp == k) {
goto L20;
}
/* INTERCHANGE. */
i__1 = k;
temp.r = b[i__1].r, temp.i = b[i__1].i;
i__1 = k;
i__2 = kp;
b[i__1].r = b[i__2].r, b[i__1].i = b[i__2].i;
i__1 = kp;
b[i__1].r = temp.r, b[i__1].i = temp.i;
L20:
/* APPLY THE TRANSFORMATION. */
i__1 = k - 1;
caxpy_(&i__1, &b[k], &ap[ik + 1], &c__1, &b[1], &c__1);
L30:
/* APPLY D INVERSE. */
i__1 = k;
c_div(&q__1, &b[k], &ap[kk]);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
--k;
ik -= k;
goto L70;
L40:
/* 2 X 2 PIVOT BLOCK. */
ikm1 = ik - (k - 1);
if (k == 2) {
goto L60;
}
kp = (i__1 = kpvt[k], abs(i__1));
if (kp == k - 1) {
goto L50;
}
/* INTERCHANGE. */
i__1 = k - 1;
temp.r = b[i__1].r, temp.i = b[i__1].i;
i__1 = k - 1;
i__2 = kp;
b[i__1].r = b[i__2].r, b[i__1].i = b[i__2].i;
i__1 = kp;
b[i__1].r = temp.r, b[i__1].i = temp.i;
L50:
/* APPLY THE TRANSFORMATION. */
i__1 = k - 2;
caxpy_(&i__1, &b[k], &ap[ik + 1], &c__1, &b[1], &c__1);
i__1 = k - 2;
caxpy_(&i__1, &b[k - 1], &ap[ikm1 + 1], &c__1, &b[1], &c__1);
L60:
/* APPLY D INVERSE. */
km1k = ik + k - 1;
kk = ik + k;
c_div(&q__1, &ap[kk], &ap[km1k]);
ak.r = q__1.r, ak.i = q__1.i;
km1km1 = ikm1 + k - 1;
c_div(&q__1, &ap[km1km1], &ap[km1k]);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &b[k], &ap[km1k]);
bk.r = q__1.r, bk.i = q__1.i;
c_div(&q__1, &b[k - 1], &ap[km1k]);
bkm1.r = q__1.r, bkm1.i = q__1.i;
q__2.r = ak.r * akm1.r - ak.i * akm1.i, q__2.i = ak.r * akm1.i + ak.i *
akm1.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = k;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r * bk.i + akm1.i *
bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
i__1 = k - 1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r * bkm1.i + ak.i *
bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
k += -2;
ik = ik - (k + 1) - k;
L70:
goto L10;
L80:
/* LOOP FORWARD APPLYING THE TRANSFORMATIONS. */
k = 1;
ik = 0;
L90:
if (k > *n) {
goto L160;
}
if (kpvt[k] < 0) {
goto L120;
}
/* 1 X 1 PIVOT BLOCK. */
if (k == 1) {
goto L110;
}
/* APPLY THE TRANSFORMATION. */
i__1 = k;
i__2 = k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ik + 1], &c__1, &b[1], &c__1);
q__1.r = b[i__2].r + q__2.r, q__1.i = b[i__2].i + q__2.i;
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
kp = kpvt[k];
if (kp == k) {
goto L100;
}
/* INTERCHANGE. */
i__1 = k;
temp.r = b[i__1].r, temp.i = b[i__1].i;
i__1 = k;
i__2 = kp;
b[i__1].r = b[i__2].r, b[i__1].i = b[i__2].i;
i__1 = kp;
b[i__1].r = temp.r, b[i__1].i = temp.i;
L100:
L110:
ik += k;
++k;
goto L150;
L120:
/* 2 X 2 PIVOT BLOCK. */
if (k == 1) {
goto L140;
}
/* APPLY THE TRANSFORMATION. */
i__1 = k;
i__2 = k;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ik + 1], &c__1, &b[1], &c__1);
q__1.r = b[i__2].r + q__2.r, q__1.i = b[i__2].i + q__2.i;
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
ikp1 = ik + k;
i__1 = k + 1;
i__2 = k + 1;
i__3 = k - 1;
cdotu_(&q__2, &i__3, &ap[ikp1 + 1], &c__1, &b[1], &c__1);
q__1.r = b[i__2].r + q__2.r, q__1.i = b[i__2].i + q__2.i;
b[i__1].r = q__1.r, b[i__1].i = q__1.i;
kp = (i__1 = kpvt[k], abs(i__1));
if (kp == k) {
goto L130;
}
/* INTERCHANGE. */
i__1 = k;
temp.r = b[i__1].r, temp.i = b[i__1].i;
i__1 = k;
i__2 = kp;
b[i__1].r = b[i__2].r, b[i__1].i = b[i__2].i;
i__1 = kp;
b[i__1].r = temp.r, b[i__1].i = temp.i;
L130:
L140:
ik = ik + k + k + 1;
k += 2;
L150:
goto L90;
L160:
return 0;
} /* cspsl_ */
/* Subroutine */ int cspt03_(char *uplo, integer *n, complex *a, complex *
ainv, complex *work, integer *ldw, real *rwork, real *rcond, real *
resid)
{
/* System generated locals */
integer work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5;
complex q__1, q__2;
/* Local variables */
integer i__, j, k;
complex t;
real eps;
integer icol, jcol, kcol, nall;
real anorm;
real ainvnm;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSPT03 computes the residual for a complex symmetric packed matrix */
/* times its inverse: */
/* norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), */
/* where EPS is the machine epsilon. */
/* Arguments */
/* ========== */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* complex symmetric 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 (N*(N+1)/2) */
/* The original complex symmetric matrix A, stored as a packed */
/* triangular matrix. */
/* AINV (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The (symmetric) inverse of the matrix A, stored as a packed */
/* triangular matrix. */
/* WORK (workspace) COMPLEX array, dimension (LDWORK,N) */
/* LDWORK (input) INTEGER */
/* The leading dimension of the array WORK. LDWORK >= max(1,N). */
/* RWORK (workspace) REAL array, dimension (N) */
/* RCOND (output) REAL */
/* The reciprocal of the condition number of A, computed as */
/* ( 1/norm(A) ) / norm(AINV). */
/* RESID (output) REAL */
/* norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0. */
/* Parameter adjustments */
--a;
--ainv;
work_dim1 = *ldw;
work_offset = 1 + work_dim1;
work -= work_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*rcond = 1.f;
*resid = 0.f;
return 0;
}
/* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0. */
eps = slamch_("Epsilon");
anorm = clansp_("1", uplo, n, &a[1], &rwork[1]);
ainvnm = clansp_("1", uplo, n, &ainv[1], &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
*rcond = 0.f;
*resid = 1.f / eps;
return 0;
}
*rcond = 1.f / anorm / ainvnm;
/* Case where both A and AINV are upper triangular: */
/* Each element of - A * AINV is computed by taking the dot product */
/* of a row of A with a column of AINV. */
if (lsame_(uplo, "U")) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
icol = (i__ - 1) * i__ / 2 + 1;
/* Code when J <= I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
jcol = (j - 1) * j / 2 + 1;
cdotu_(&q__1, &j, &a[icol], &c__1, &ainv[jcol], &c__1);
t.r = q__1.r, t.i = q__1.i;
jcol = jcol + (j << 1) - 1;
kcol = icol - 1;
i__3 = i__;
for (k = j + 1; k <= i__3; ++k) {
i__4 = kcol + k;
i__5 = jcol;
q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
.i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
* ainv[i__5].r;
q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
t.r = q__1.r, t.i = q__1.i;
jcol += k;
/* L10: */
}
kcol += i__ << 1;
i__3 = *n;
for (k = i__ + 1; k <= i__3; ++k) {
i__4 = kcol;
i__5 = jcol;
q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
.i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
* ainv[i__5].r;
q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
t.r = q__1.r, t.i = q__1.i;
kcol += k;
jcol += k;
/* L20: */
}
i__3 = i__ + j * work_dim1;
q__1.r = -t.r, q__1.i = -t.i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L30: */
}
/* Code when J > I */
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
jcol = (j - 1) * j / 2 + 1;
cdotu_(&q__1, &i__, &a[icol], &c__1, &ainv[jcol], &c__1);
t.r = q__1.r, t.i = q__1.i;
--jcol;
kcol = icol + (i__ << 1) - 1;
i__3 = j;
for (k = i__ + 1; k <= i__3; ++k) {
i__4 = kcol;
i__5 = jcol + k;
q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
.i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
* ainv[i__5].r;
q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
t.r = q__1.r, t.i = q__1.i;
kcol += k;
/* L40: */
}
jcol += j << 1;
i__3 = *n;
for (k = j + 1; k <= i__3; ++k) {
i__4 = kcol;
i__5 = jcol;
q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
.i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
* ainv[i__5].r;
q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
t.r = q__1.r, t.i = q__1.i;
kcol += k;
jcol += k;
/* L50: */
}
i__3 = i__ + j * work_dim1;
q__1.r = -t.r, q__1.i = -t.i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L60: */
}
/* L70: */
}
} else {
/* Case where both A and AINV are lower triangular */
nall = *n * (*n + 1) / 2;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Code when J <= I */
icol = nall - (*n - i__ + 1) * (*n - i__ + 2) / 2 + 1;
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
jcol = nall - (*n - j) * (*n - j + 1) / 2 - (*n - i__);
i__3 = *n - i__ + 1;
cdotu_(&q__1, &i__3, &a[icol], &c__1, &ainv[jcol], &c__1);
t.r = q__1.r, t.i = q__1.i;
kcol = i__;
jcol = j;
i__3 = j - 1;
for (k = 1; k <= i__3; ++k) {
i__4 = kcol;
i__5 = jcol;
q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
.i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
* ainv[i__5].r;
q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
t.r = q__1.r, t.i = q__1.i;
jcol = jcol + *n - k;
kcol = kcol + *n - k;
/* L80: */
}
jcol -= j;
i__3 = i__ - 1;
for (k = j; k <= i__3; ++k) {
i__4 = kcol;
i__5 = jcol + k;
q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
.i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
* ainv[i__5].r;
q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
t.r = q__1.r, t.i = q__1.i;
kcol = kcol + *n - k;
/* L90: */
}
i__3 = i__ + j * work_dim1;
q__1.r = -t.r, q__1.i = -t.i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L100: */
}
/* Code when J > I */
icol = nall - (*n - i__) * (*n - i__ + 1) / 2;
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
jcol = nall - (*n - j + 1) * (*n - j + 2) / 2 + 1;
i__3 = *n - j + 1;
cdotu_(&q__1, &i__3, &a[icol - *n + j], &c__1, &ainv[jcol], &
c__1);
t.r = q__1.r, t.i = q__1.i;
kcol = i__;
jcol = j;
i__3 = i__ - 1;
for (k = 1; k <= i__3; ++k) {
i__4 = kcol;
i__5 = jcol;
q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
.i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
* ainv[i__5].r;
q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
t.r = q__1.r, t.i = q__1.i;
jcol = jcol + *n - k;
kcol = kcol + *n - k;
/* L110: */
}
kcol -= i__;
i__3 = j - 1;
for (k = i__; k <= i__3; ++k) {
i__4 = kcol + k;
i__5 = jcol;
q__2.r = a[i__4].r * ainv[i__5].r - a[i__4].i * ainv[i__5]
.i, q__2.i = a[i__4].r * ainv[i__5].i + a[i__4].i
* ainv[i__5].r;
q__1.r = t.r + q__2.r, q__1.i = t.i + q__2.i;
t.r = q__1.r, t.i = q__1.i;
jcol = jcol + *n - k;
/* L120: */
}
i__3 = i__ + j * work_dim1;
q__1.r = -t.r, q__1.i = -t.i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L130: */
}
/* L140: */
}
}
/* Add the identity matrix to WORK . */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * work_dim1;
i__3 = i__ + i__ * work_dim1;
q__1.r = work[i__3].r + 1.f, q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L150: */
}
/* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS) */
*resid = clange_("1", n, n, &work[work_offset], ldw, &rwork[1])
;
*resid = *resid * *rcond / eps / (real) (*n);
return 0;
/* End of CSPT03 */
} /* cspt03_ */
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer
*m, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *c__, integer *ldc, real *scale, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CTRSYL solves the complex Sylvester matrix equation:
op(A)*X + X*op(B) = scale*C or
op(A)*X - X*op(B) = scale*C,
where op(A) = A or A**H, and A and B are both upper triangular. A is
M-by-M and B is N-by-N; the right hand side C and the solution X are
M-by-N; and scale is an output scale factor, set <= 1 to avoid
overflow in X.
Arguments
=========
TRANA (input) CHARACTER*1
Specifies the option op(A):
= 'N': op(A) = A (No transpose)
= 'C': op(A) = A**H (Conjugate transpose)
TRANB (input) CHARACTER*1
Specifies the option op(B):
= 'N': op(B) = B (No transpose)
= 'C': op(B) = B**H (Conjugate transpose)
ISGN (input) INTEGER
Specifies the sign in the equation:
= +1: solve op(A)*X + X*op(B) = scale*C
= -1: solve op(A)*X - X*op(B) = scale*C
M (input) INTEGER
The order of the matrix A, and the number of rows in the
matrices X and C. M >= 0.
N (input) INTEGER
The order of the matrix B, and the number of columns in the
matrices X and C. N >= 0.
A (input) COMPLEX array, dimension (LDA,M)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input) COMPLEX array, dimension (LDB,N)
The upper triangular matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
C (input/output) COMPLEX array, dimension (LDC,N)
On entry, the M-by-N right hand side matrix C.
On exit, C is overwritten by the solution matrix X.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M)
SCALE (output) REAL
The scale factor, scale, set <= 1 to avoid overflow in X.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
= 1: A and B have common or very close eigenvalues; perturbed
values were used to solve the equation (but the matrices
A and B are unchanged).
=====================================================================
Decode and Test 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, c_dim1, c_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real smin;
static complex suml, sumr;
static integer j, k, l;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
static complex a11;
static real db;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static complex x11;
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
static real scaloc;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
static real bignum;
static logical notrna, notrnb;
static real smlnum, da11;
static complex vec;
static real dum[1], eps, sgn;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
/* Function Body */
notrna = lsame_(trana, "N");
notrnb = lsame_(tranb, "N");
*info = 0;
if (! notrna && ! lsame_(trana, "T") && ! lsame_(
trana, "C")) {
*info = -1;
} else if (! notrnb && ! lsame_(tranb, "T") && !
lsame_(tranb, "C")) {
*info = -2;
} else if (*isgn != 1 && *isgn != -1) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*m)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRSYL", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = smlnum * (real) (*m * *n) / eps;
bignum = 1.f / smlnum;
/* Computing MAX */
r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n,
&b[b_offset], ldb, dum);
smin = dmax(r__1,r__2);
*scale = 1.f;
sgn = (real) (*isgn);
if (notrna && notrnb) {
/* Solve A*X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
M L-1
R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
I=K+1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__2 = k + 1;
/* Computing MIN */
i__3 = k + 1;
i__4 = *m - k;
cdotu_(&q__1, &i__4, &a_ref(k, min(i__2,*m)), lda, &c___ref(
min(i__3,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__2 = l - 1;
cdotu_(&q__1, &i__2, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L10: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L20: */
}
/* L30: */
}
} else if (! notrna && notrnb) {
/* Solve A' *X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
upper-left corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
K-1 L-1
R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
I=1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
i__2 = *m;
for (k = 1; k <= i__2; ++k) {
i__3 = k - 1;
cdotc_(&q__1, &i__3, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__3 = l - 1;
cdotu_(&q__1, &i__3, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__3 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
r_cnjg(&q__2, &a_ref(k, k));
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L40: */
}
*scale *= scaloc;
}
i__3 = c___subscr(k, l);
c__[i__3].r = x11.r, c__[i__3].i = x11.i;
/* L50: */
}
/* L60: */
}
} else if (! notrna && ! notrnb) {
/* Solve A'*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
upper-right corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
K-1
R(K,L) = SUM [A'(I,K)*X(I,L)] +
I=1
N
ISGN*SUM [X(K,J)*B'(L,J)].
J=L+1 */
for (l = *n; l >= 1; --l) {
i__1 = *m;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
cdotc_(&q__1, &i__2, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__2 = l + 1;
/* Computing MIN */
i__3 = l + 1;
i__4 = *n - l;
cdotc_(&q__1, &i__4, &c___ref(k, min(i__2,*n)), ldc, &b_ref(l,
min(i__3,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i;
r_cnjg(&q__1, &q__2);
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L70: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L80: */
}
/* L90: */
}
} else if (notrna && ! notrnb) {
/* Solve A*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
M N
R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)]
I=K+1 J=L+1 */
for (l = *n; l >= 1; --l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__1 = k + 1;
/* Computing MIN */
i__2 = k + 1;
i__3 = *m - k;
cdotu_(&q__1, &i__3, &a_ref(k, min(i__1,*m)), lda, &c___ref(
min(i__2,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__1 = l + 1;
/* Computing MIN */
i__2 = l + 1;
i__3 = *n - l;
cdotc_(&q__1, &i__3, &c___ref(k, min(i__1,*n)), ldc, &b_ref(l,
min(i__2,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__1 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__1 = a_subscr(k, k);
r_cnjg(&q__3, &b_ref(l, l));
q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i;
q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L100: */
}
*scale *= scaloc;
}
i__1 = c___subscr(k, l);
c__[i__1].r = x11.r, c__[i__1].i = x11.i;
/* L110: */
}
/* L120: */
}
}
return 0;
/* End of CTRSYL */
} /* ctrsyl_ */
/* Subroutine */ int csytri_(char *uplo, integer *n, complex *a, integer *lda,
integer *ipiv, complex *work, 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
=======
CSYTRI computes the inverse of a complex symmetric indefinite matrix
A using the factorization A = U*D*U**T or A = L*D*L**T computed by
CSYTRF.
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**T;
= 'L': Lower triangular, form is A = L*D*L**T.
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 CSYTRF.
On exit, if INFO = 0, the (symmetric) 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 CSYTRF.
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
> 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 */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
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;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
static complex temp, akkp1, d__;
static integer k;
static complex t;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
static integer kstep;
static logical upper;
extern /* Subroutine */ int csymv_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, complex *, integer *
);
static complex ak;
static integer kp;
extern /* Subroutine */ int xerbla_(char *, integer *);
static complex akp1;
#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;
--ipiv;
--work;
/* 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_("CSYTRI", &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 = a_subscr(*info, *info);
if (ipiv[*info] > 0 && (a[i__1].r == 0.f && a[i__1].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 = a_subscr(*info, *info);
if (ipiv[*info] > 0 && (a[i__2].r == 0.f && a[i__2].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 L40;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
i__1 = a_subscr(k, k);
c_div(&q__1, &c_b1, &a_ref(k, k));
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
/* Compute column K of the inverse. */
if (k > 1) {
i__1 = k - 1;
ccopy_(&i__1, &a_ref(1, k), &c__1, &work[1], &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1,
&c_b2, &a_ref(1, k), &c__1);
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
i__3 = k - 1;
cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(1, k), &c__1);
q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
i__1 = a_subscr(k, k + 1);
t.r = a[i__1].r, t.i = a[i__1].i;
c_div(&q__1, &a_ref(k, k), &t);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &a_ref(k + 1, k + 1), &t);
akp1.r = q__1.r, akp1.i = q__1.i;
c_div(&q__1, &a_ref(k, k + 1), &t);
akkp1.r = q__1.r, akkp1.i = q__1.i;
q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i +
ak.i * akp1.r;
q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f;
q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i
* q__2.r;
d__.r = q__1.r, d__.i = q__1.i;
i__1 = a_subscr(k, k);
c_div(&q__1, &akp1, &d__);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = a_subscr(k + 1, k + 1);
c_div(&q__1, &ak, &d__);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = a_subscr(k, k + 1);
q__2.r = -akkp1.r, q__2.i = -akkp1.i;
c_div(&q__1, &q__2, &d__);
a[i__1].r = q__1.r, a[i__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_ref(1, k), &c__1, &work[1], &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1,
&c_b2, &a_ref(1, k), &c__1);
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
i__3 = k - 1;
cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(1, k), &c__1);
q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = a_subscr(k, k + 1);
i__2 = a_subscr(k, k + 1);
i__3 = k - 1;
cdotu_(&q__2, &i__3, &a_ref(1, k), &c__1, &a_ref(1, k + 1), &
c__1);
q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = k - 1;
ccopy_(&i__1, &a_ref(1, k + 1), &c__1, &work[1], &c__1);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
csymv_(uplo, &i__1, &q__1, &a[a_offset], lda, &work[1], &c__1,
&c_b2, &a_ref(1, k + 1), &c__1);
i__1 = a_subscr(k + 1, k + 1);
i__2 = a_subscr(k + 1, k + 1);
i__3 = k - 1;
cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(1, k + 1), &c__1)
;
q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
a[i__1].r = q__1.r, a[i__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_ref(1, k), &c__1, &a_ref(1, kp), &c__1);
i__1 = k - kp - 1;
cswap_(&i__1, &a_ref(kp + 1, k), &c__1, &a_ref(kp, kp + 1), lda);
i__1 = a_subscr(k, k);
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = a_subscr(k, k);
i__2 = a_subscr(kp, kp);
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = a_subscr(kp, kp);
a[i__1].r = temp.r, a[i__1].i = temp.i;
if (kstep == 2) {
i__1 = a_subscr(k, k + 1);
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = a_subscr(k, k + 1);
i__2 = a_subscr(kp, k + 1);
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = a_subscr(kp, k + 1);
a[i__1].r = temp.r, a[i__1].i = temp.i;
}
}
k += kstep;
goto L30;
L40:
;
} 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;
L50:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L60;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Invert the diagonal block. */
i__1 = a_subscr(k, k);
c_div(&q__1, &c_b1, &a_ref(k, k));
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
/* Compute column K of the inverse. */
if (k < *n) {
i__1 = *n - k;
ccopy_(&i__1, &a_ref(k + 1, k), &c__1, &work[1], &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
csymv_(uplo, &i__1, &q__1, &a_ref(k + 1, k + 1), lda, &work[1]
, &c__1, &c_b2, &a_ref(k + 1, k), &c__1);
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
i__3 = *n - k;
cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k), &c__1)
;
q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
}
kstep = 1;
} else {
/* 2 x 2 diagonal block
Invert the diagonal block. */
i__1 = a_subscr(k, k - 1);
t.r = a[i__1].r, t.i = a[i__1].i;
c_div(&q__1, &a_ref(k - 1, k - 1), &t);
ak.r = q__1.r, ak.i = q__1.i;
c_div(&q__1, &a_ref(k, k), &t);
akp1.r = q__1.r, akp1.i = q__1.i;
c_div(&q__1, &a_ref(k, k - 1), &t);
akkp1.r = q__1.r, akkp1.i = q__1.i;
q__3.r = ak.r * akp1.r - ak.i * akp1.i, q__3.i = ak.r * akp1.i +
ak.i * akp1.r;
q__2.r = q__3.r - 1.f, q__2.i = q__3.i + 0.f;
q__1.r = t.r * q__2.r - t.i * q__2.i, q__1.i = t.r * q__2.i + t.i
* q__2.r;
d__.r = q__1.r, d__.i = q__1.i;
i__1 = a_subscr(k - 1, k - 1);
c_div(&q__1, &akp1, &d__);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = a_subscr(k, k);
c_div(&q__1, &ak, &d__);
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = a_subscr(k, k - 1);
q__2.r = -akkp1.r, q__2.i = -akkp1.i;
c_div(&q__1, &q__2, &d__);
a[i__1].r = q__1.r, a[i__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_ref(k + 1, k), &c__1, &work[1], &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
csymv_(uplo, &i__1, &q__1, &a_ref(k + 1, k + 1), lda, &work[1]
, &c__1, &c_b2, &a_ref(k + 1, k), &c__1);
i__1 = a_subscr(k, k);
i__2 = a_subscr(k, k);
i__3 = *n - k;
cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k), &c__1)
;
q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = a_subscr(k, k - 1);
i__2 = a_subscr(k, k - 1);
i__3 = *n - k;
cdotu_(&q__2, &i__3, &a_ref(k + 1, k), &c__1, &a_ref(k + 1, k
- 1), &c__1);
q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
i__1 = *n - k;
ccopy_(&i__1, &a_ref(k + 1, k - 1), &c__1, &work[1], &c__1);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
csymv_(uplo, &i__1, &q__1, &a_ref(k + 1, k + 1), lda, &work[1]
, &c__1, &c_b2, &a_ref(k + 1, k - 1), &c__1);
i__1 = a_subscr(k - 1, k - 1);
i__2 = a_subscr(k - 1, k - 1);
i__3 = *n - k;
cdotu_(&q__2, &i__3, &work[1], &c__1, &a_ref(k + 1, k - 1), &
c__1);
q__1.r = a[i__2].r - q__2.r, q__1.i = a[i__2].i - q__2.i;
a[i__1].r = q__1.r, a[i__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_ref(kp + 1, k), &c__1, &a_ref(kp + 1, kp), &
c__1);
}
i__1 = kp - k - 1;
cswap_(&i__1, &a_ref(k + 1, k), &c__1, &a_ref(kp, k + 1), lda);
i__1 = a_subscr(k, k);
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = a_subscr(k, k);
i__2 = a_subscr(kp, kp);
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = a_subscr(kp, kp);
a[i__1].r = temp.r, a[i__1].i = temp.i;
if (kstep == 2) {
i__1 = a_subscr(k, k - 1);
temp.r = a[i__1].r, temp.i = a[i__1].i;
i__1 = a_subscr(k, k - 1);
i__2 = a_subscr(kp, k - 1);
a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i;
i__1 = a_subscr(kp, k - 1);
a[i__1].r = temp.r, a[i__1].i = temp.i;
}
}
k -= kstep;
goto L50;
L60:
;
}
return 0;
/* End of CSYTRI */
} /* csytri_ */
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer
*m, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *c__, integer *ldc, real *scale, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
integer j, k, l;
complex a11;
real db;
complex x11;
real da11;
complex vec;
real dum[1], eps, sgn, smin;
complex suml, sumr;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
real scaloc;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
real bignum;
logical notrna, notrnb;
real smlnum;
/* -- LAPACK routine (version 3.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTRSYL solves the complex Sylvester matrix equation: */
/* op(A)*X + X*op(B) = scale*C or */
/* op(A)*X - X*op(B) = scale*C, */
/* where op(A) = A or A**H, and A and B are both upper triangular. A is */
/* M-by-M and B is N-by-N; the right hand side C and the solution X are */
/* M-by-N; and scale is an output scale factor, set <= 1 to avoid */
/* overflow in X. */
/* Arguments */
/* ========= */
/* TRANA (input) CHARACTER*1 */
/* Specifies the option op(A): */
/* = 'N': op(A) = A (No transpose) */
/* = 'C': op(A) = A**H (Conjugate transpose) */
/* TRANB (input) CHARACTER*1 */
/* Specifies the option op(B): */
/* = 'N': op(B) = B (No transpose) */
/* = 'C': op(B) = B**H (Conjugate transpose) */
/* ISGN (input) INTEGER */
/* Specifies the sign in the equation: */
/* = +1: solve op(A)*X + X*op(B) = scale*C */
/* = -1: solve op(A)*X - X*op(B) = scale*C */
/* M (input) INTEGER */
/* The order of the matrix A, and the number of rows in the */
/* matrices X and C. M >= 0. */
/* N (input) INTEGER */
/* The order of the matrix B, and the number of columns in the */
/* matrices X and C. N >= 0. */
/* A (input) COMPLEX array, dimension (LDA,M) */
/* The upper triangular matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* The upper triangular matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* C (input/output) COMPLEX array, dimension (LDC,N) */
/* On entry, the M-by-N right hand side matrix C. */
/* On exit, C is overwritten by the solution matrix X. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M) */
/* SCALE (output) REAL */
/* The scale factor, scale, set <= 1 to avoid overflow in X. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* = 1: A and B have common or very close eigenvalues; perturbed */
/* values were used to solve the equation (but the matrices */
/* A and B are unchanged). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test 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_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
/* Function Body */
notrna = lsame_(trana, "N");
notrnb = lsame_(tranb, "N");
*info = 0;
if (! notrna && ! lsame_(trana, "C")) {
*info = -1;
} else if (! notrnb && ! lsame_(tranb, "C")) {
*info = -2;
} else if (*isgn != 1 && *isgn != -1) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*m)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRSYL", &i__1);
return 0;
}
/* Quick return if possible */
*scale = 1.f;
if (*m == 0 || *n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = smlnum * (real) (*m * *n) / eps;
bignum = 1.f / smlnum;
/* Computing MAX */
r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n,
&b[b_offset], ldb, dum);
smin = dmax(r__1,r__2);
sgn = (real) (*isgn);
if (notrna && notrnb) {
/* Solve A*X + ISGN*X*B = scale*C. */
/* The (K,L)th block of X is determined starting from */
/* bottom-left corner column by column by */
/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
/* Where */
/* M L-1 */
/* R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. */
/* I=K+1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
for (k = *m; k >= 1; --k) {
i__2 = *m - k;
/* Computing MIN */
i__3 = k + 1;
/* Computing MIN */
i__4 = k + 1;
cdotu_(&q__1, &i__2, &a[k + min(i__3, *m)* a_dim1], lda, &c__[
min(i__4, *m)+ l * c_dim1], &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__2 = l - 1;
cdotu_(&q__1, &i__2, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1]
, &c__1);
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = k + l * c_dim1;
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = k + k * a_dim1;
i__3 = l + l * b_dim1;
q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
/* L10: */
}
*scale *= scaloc;
}
i__2 = k + l * c_dim1;
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L20: */
}
/* L30: */
}
} else if (! notrna && notrnb) {
/* Solve A' *X + ISGN*X*B = scale*C. */
/* The (K,L)th block of X is determined starting from */
/* upper-left corner column by column by */
/* A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */
/* Where */
/* K-1 L-1 */
/* R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] */
/* I=1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
i__2 = *m;
for (k = 1; k <= i__2; ++k) {
i__3 = k - 1;
cdotc_(&q__1, &i__3, &a[k * a_dim1 + 1], &c__1, &c__[l *
c_dim1 + 1], &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__3 = l - 1;
cdotu_(&q__1, &i__3, &c__[k + c_dim1], ldc, &b[l * b_dim1 + 1]
, &c__1);
sumr.r = q__1.r, sumr.i = q__1.i;
i__3 = k + l * c_dim1;
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
r_cnjg(&q__2, &a[k + k * a_dim1]);
i__3 = l + l * b_dim1;
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
/* L40: */
}
*scale *= scaloc;
}
i__3 = k + l * c_dim1;
c__[i__3].r = x11.r, c__[i__3].i = x11.i;
/* L50: */
}
/* L60: */
}
} else if (! notrna && ! notrnb) {
/* Solve A'*X + ISGN*X*B' = C. */
/* The (K,L)th block of X is determined starting from */
/* upper-right corner column by column by */
/* A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) */
/* Where */
/* K-1 */
/* R(K,L) = SUM [A'(I,K)*X(I,L)] + */
/* I=1 */
/* N */
/* ISGN*SUM [X(K,J)*B'(L,J)]. */
/* J=L+1 */
for (l = *n; l >= 1; --l) {
i__1 = *m;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
cdotc_(&q__1, &i__2, &a[k * a_dim1 + 1], &c__1, &c__[l *
c_dim1 + 1], &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__2 = *n - l;
/* Computing MIN */
i__3 = l + 1;
/* Computing MIN */
i__4 = l + 1;
cdotc_(&q__1, &i__2, &c__[k + min(i__3, *n)* c_dim1], ldc, &b[
l + min(i__4, *n)* b_dim1], ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = k + l * c_dim1;
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = k + k * a_dim1;
i__3 = l + l * b_dim1;
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i;
r_cnjg(&q__1, &q__2);
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
/* L70: */
}
*scale *= scaloc;
}
i__2 = k + l * c_dim1;
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L80: */
}
/* L90: */
}
} else if (notrna && ! notrnb) {
/* Solve A*X + ISGN*X*B' = C. */
/* The (K,L)th block of X is determined starting from */
/* bottom-left corner column by column by */
/* A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) */
/* Where */
/* M N */
/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] */
/* I=K+1 J=L+1 */
for (l = *n; l >= 1; --l) {
for (k = *m; k >= 1; --k) {
i__1 = *m - k;
/* Computing MIN */
i__2 = k + 1;
/* Computing MIN */
i__3 = k + 1;
cdotu_(&q__1, &i__1, &a[k + min(i__2, *m)* a_dim1], lda, &c__[
min(i__3, *m)+ l * c_dim1], &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__1 = *n - l;
/* Computing MIN */
i__2 = l + 1;
/* Computing MIN */
i__3 = l + 1;
cdotc_(&q__1, &i__1, &c__[k + min(i__2, *n)* c_dim1], ldc, &b[
l + min(i__3, *n)* b_dim1], ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__1 = k + l * c_dim1;
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__1 = k + k * a_dim1;
r_cnjg(&q__3, &b[l + l * b_dim1]);
q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i;
q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1);
/* L100: */
}
*scale *= scaloc;
}
i__1 = k + l * c_dim1;
c__[i__1].r = x11.r, c__[i__1].i = x11.i;
/* L110: */
}
/* L120: */
}
}
return 0;
/* End of CTRSYL */
} /* ctrsyl_ */
/* Subroutine */ int clarrv_(integer *n, real *d__, real *l, integer *isplit,
integer *m, real *w, integer *iblock, real *gersch, real *tol,
complex *z__, integer *ldz, integer *isuppz, real *work, integer *
iwork, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer iend, jblk, iter, temp[1], ktot, itmp1, itmp2, i__, j, k,
p, q, indld;
static real sigma;
static integer ndone, iinfo, iindr;
static real resid;
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
static integer nclus;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), scopy_(integer *, real *,
integer *, real *, integer *);
static integer iindc1, iindc2, indin1, indin2;
extern /* Subroutine */ int clar1v_(integer *, integer *, integer *, real
*, real *, real *, real *, real *, real *, complex *, real *,
real *, integer *, integer *, real *);
extern doublereal scnrm2_(integer *, complex *, integer *);
static real lambda;
static integer im, in, ibegin, indgap, indlld;
extern doublereal slamch_(char *);
static real mingma;
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*);
static integer oldien, oldncl;
static real relgap;
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
static integer oldcls, ndepth, inderr, iindwk;
extern /* Subroutine */ int cstein_(integer *, real *, real *, integer *,
real *, integer *, integer *, complex *, integer *, real *,
integer *, integer *, integer *), slarrb_(integer *, real *, real
*, real *, real *, integer *, integer *, real *, real *, real *,
real *, real *, real *, integer *, integer *);
static logical mgscls;
static integer lsbdpt, newcls, oldfst;
static real minrgp;
static integer indwrk;
extern /* Subroutine */ int slarrf_(integer *, real *, real *, real *,
real *, integer *, integer *, real *, real *, real *, real *,
integer *, integer *);
static integer oldlst;
static real reltol;
static integer maxitr, newfrs, newftt;
static real mgstol;
static integer nsplit;
static real nrminv, rqcorr;
static integer newlst, newsiz;
static real gap, eps, ztz, tmp1;
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
/* -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count ..
Purpose
=======
CLARRV computes the eigenvectors of the tridiagonal matrix
T = L D L^T given L, D and the eigenvalues of L D L^T.
The input eigenvalues should have high relative accuracy with
respect to the entries of L and D. The desired accuracy of the
output can be specified by the input parameter TOL.
Arguments
=========
N (input) INTEGER
The order of the matrix. N >= 0.
D (input/output) REAL array, dimension (N)
On entry, the n diagonal elements of the diagonal matrix D.
On exit, D may be overwritten.
L (input/output) REAL array, dimension (N-1)
On entry, the (n-1) subdiagonal elements of the unit
bidiagonal matrix L in elements 1 to N-1 of L. L(N) need
not be set. On exit, L is overwritten.
ISPLIT (input) INTEGER array, dimension (N)
The splitting points, at which T breaks up into submatrices.
The first submatrix consists of rows/columns 1 to
ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
through ISPLIT( 2 ), etc.
TOL (input) REAL
The absolute error tolerance for the
eigenvalues/eigenvectors.
Errors in the input eigenvalues must be bounded by TOL.
The eigenvectors output have residual norms
bounded by TOL, and the dot products between different
eigenvectors are bounded by TOL. TOL must be at least
N*EPS*|T|, where EPS is the machine precision and |T| is
the 1-norm of the tridiagonal matrix.
M (input) INTEGER
The total number of eigenvalues found. 0 <= M <= N.
If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
W (input) REAL array, dimension (N)
The first M elements of W contain the eigenvalues for
which eigenvectors are to be computed. The eigenvalues
should be grouped by split-off block and ordered from
smallest to largest within the block ( The output array
W from SLARRE is expected here ).
Errors in W must be bounded by TOL (see above).
IBLOCK (input) INTEGER array, dimension (N)
The submatrix indices associated with the corresponding
eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
the first submatrix from the top, =2 if W(i) belongs to
the second submatrix, etc.
Z (output) COMPLEX array, dimension (LDZ, max(1,M) )
If JOBZ = 'V', then if INFO = 0, the first M columns of Z
contain the orthonormal eigenvectors of the matrix T
corresponding to the selected eigenvalues, with the i-th
column of Z holding the eigenvector associated with W(i).
If JOBZ = 'N', then Z is not referenced.
Note: the user must ensure that at least max(1,M) columns are
supplied in the array Z; if RANGE = 'V', the exact value of M
is not known in advance and an upper bound must be used.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= max(1,N).
ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
The support of the eigenvectors in Z, i.e., the indices
indicating the nonzero elements in Z. The i-th eigenvector
is nonzero only in elements ISUPPZ( 2*i-1 ) through
ISUPPZ( 2*i ).
WORK (workspace) REAL array, dimension (13*N)
IWORK (workspace) INTEGER array, dimension (6*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = 1, internal error in SLARRB
if INFO = 2, internal error in CSTEIN
Further Details
===============
Based on contributions by
Inderjit Dhillon, IBM Almaden, USA
Osni Marques, LBNL/NERSC, USA
Ken Stanley, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
--d__;
--l;
--isplit;
--w;
--iblock;
--gersch;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
inderr = *n + 1;
indld = *n << 1;
indlld = *n * 3;
indgap = *n << 2;
indin1 = *n * 5 + 1;
indin2 = *n * 6 + 1;
indwrk = *n * 7 + 1;
iindr = *n;
iindc1 = *n << 1;
iindc2 = *n * 3;
iindwk = (*n << 2) + 1;
eps = slamch_("Precision");
i__1 = *n << 1;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L10: */
}
latime_1.ops += (real) (*m + 1);
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
work[inderr + i__ - 1] = eps * (r__1 = w[i__], dabs(r__1));
/* L20: */
}
claset_("Full", n, n, &c_b1, &c_b1, &z__[z_offset], ldz);
mgstol = eps * 5.f;
nsplit = iblock[*m];
ibegin = 1;
i__1 = nsplit;
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = isplit[jblk];
/* Find the eigenvectors of the submatrix indexed IBEGIN
through IEND. */
if (ibegin == iend) {
i__2 = z___subscr(ibegin, ibegin);
z__[i__2].r = 1.f, z__[i__2].i = 0.f;
isuppz[(ibegin << 1) - 1] = ibegin;
isuppz[ibegin * 2] = ibegin;
ibegin = iend + 1;
goto L170;
}
oldien = ibegin - 1;
in = iend - oldien;
latime_1.ops += 1.f;
/* Computing MIN */
r__1 = .01f, r__2 = 1.f / (real) in;
reltol = dmin(r__1,r__2);
im = in;
scopy_(&im, &w[ibegin], &c__1, &work[1], &c__1);
latime_1.ops += (real) (in - 1);
i__2 = in - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
work[indgap + i__] = work[i__ + 1] - work[i__];
/* L30: */
}
/* Computing MAX */
r__2 = (r__1 = work[in], dabs(r__1));
work[indgap + in] = dmax(r__2,eps);
ndone = 0;
ndepth = 0;
lsbdpt = 1;
nclus = 1;
iwork[iindc1 + 1] = 1;
iwork[iindc1 + 2] = in;
/* While( NDONE.LT.IM ) do */
L40:
if (ndone < im) {
oldncl = nclus;
nclus = 0;
lsbdpt = 1 - lsbdpt;
i__2 = oldncl;
for (i__ = 1; i__ <= i__2; ++i__) {
if (lsbdpt == 0) {
oldcls = iindc1;
newcls = iindc2;
} else {
oldcls = iindc2;
newcls = iindc1;
}
/* If NDEPTH > 1, retrieve the relatively robust
representation (RRR) and perform limited bisection
(if necessary) to get approximate eigenvalues. */
j = oldcls + (i__ << 1);
oldfst = iwork[j - 1];
oldlst = iwork[j];
if (ndepth > 0) {
j = oldien + oldfst;
i__3 = in;
for (k = 1; k <= i__3; ++k) {
i__4 = z___subscr(ibegin + k - 1, oldien + oldfst);
d__[ibegin + k - 1] = z__[i__4].r;
i__4 = z___subscr(ibegin + k - 1, oldien + oldfst + 1)
;
l[ibegin + k - 1] = z__[i__4].r;
/* L45: */
}
sigma = l[iend];
}
k = ibegin;
latime_1.ops += (real) (in - 1 << 1);
i__3 = in - 1;
for (j = 1; j <= i__3; ++j) {
work[indld + j] = d__[k] * l[k];
work[indlld + j] = work[indld + j] * l[k];
++k;
/* L50: */
}
if (ndepth > 0) {
slarrb_(&in, &d__[ibegin], &l[ibegin], &work[indld + 1], &
work[indlld + 1], &oldfst, &oldlst, &sigma, &
reltol, &work[1], &work[indgap + 1], &work[inderr]
, &work[indwrk], &iwork[iindwk], &iinfo);
if (iinfo != 0) {
*info = 1;
return 0;
}
}
/* Classify eigenvalues of the current representation (RRR)
as (i) isolated, (ii) loosely clustered or (iii) tightly
clustered */
newfrs = oldfst;
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
latime_1.ops += 1.f;
if (j == oldlst || work[indgap + j] >= reltol * (r__1 =
work[j], dabs(r__1))) {
newlst = j;
} else {
/* continue (to the next loop) */
latime_1.ops += 1.f;
relgap = work[indgap + j] / (r__1 = work[j], dabs(
r__1));
if (j == newfrs) {
minrgp = relgap;
} else {
minrgp = dmin(minrgp,relgap);
}
goto L140;
}
newsiz = newlst - newfrs + 1;
maxitr = 10;
newftt = oldien + newfrs;
if (newsiz > 1) {
mgscls = newsiz <= 20 && minrgp >= mgstol;
if (! mgscls) {
i__4 = in;
for (k = 1; k <= i__4; ++k) {
i__5 = z___subscr(ibegin + k - 1, newftt);
work[indin1 + k - 1] = z__[i__5].r;
i__5 = z___subscr(ibegin + k - 1, newftt + 1);
work[indin2 + k - 1] = z__[i__5].r;
/* L55: */
}
slarrf_(&in, &d__[ibegin], &l[ibegin], &work[
indld + 1], &work[indlld + 1], &newfrs, &
newlst, &work[1], &work[indin1], &work[
indin2], &work[indwrk], &iwork[iindwk],
info);
if (*info == 0) {
++nclus;
k = newcls + (nclus << 1);
iwork[k - 1] = newfrs;
iwork[k] = newlst;
} else {
*info = 0;
if (minrgp >= mgstol) {
mgscls = TRUE_;
} else {
/* Call CSTEIN to process this tight cluster.
This happens only if MINRGP <= MGSTOL
and SLARRF returns INFO = 1. The latter
means that a new RRR to "break" the
cluster could not be found. */
work[indwrk] = d__[ibegin];
latime_1.ops += (real) (in - 1);
i__4 = in - 1;
for (k = 1; k <= i__4; ++k) {
work[indwrk + k] = d__[ibegin + k] +
work[indlld + k];
/* L60: */
}
i__4 = newsiz;
for (k = 1; k <= i__4; ++k) {
iwork[iindwk + k - 1] = 1;
/* L70: */
}
i__4 = newlst;
for (k = newfrs; k <= i__4; ++k) {
isuppz[(ibegin + k << 1) - 3] = 1;
isuppz[(ibegin + k << 1) - 2] = in;
/* L80: */
}
temp[0] = in;
cstein_(&in, &work[indwrk], &work[indld +
1], &newsiz, &work[newfrs], &
iwork[iindwk], temp, &z___ref(
ibegin, newftt), ldz, &work[
indwrk + in], &iwork[iindwk + in],
&iwork[iindwk + (in << 1)], &
iinfo);
if (iinfo != 0) {
*info = 2;
return 0;
}
ndone += newsiz;
}
}
}
} else {
mgscls = FALSE_;
}
if (newsiz == 1 || mgscls) {
ktot = newftt;
i__4 = newlst;
for (k = newfrs; k <= i__4; ++k) {
iter = 0;
L90:
lambda = work[k];
clar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &
l[ibegin], &work[indld + 1], &work[indlld
+ 1], &gersch[(oldien << 1) + 1], &
z___ref(ibegin, ktot), &ztz, &mingma, &
iwork[iindr + ktot], &isuppz[(ktot << 1)
- 1], &work[indwrk]);
latime_1.ops += 4.f;
tmp1 = 1.f / ztz;
nrminv = sqrt(tmp1);
resid = dabs(mingma) * nrminv;
rqcorr = mingma * tmp1;
if (k == in) {
gap = work[indgap + k - 1];
} else if (k == 1) {
gap = work[indgap + k];
} else {
/* Computing MIN */
r__1 = work[indgap + k - 1], r__2 = work[
indgap + k];
gap = dmin(r__1,r__2);
}
++iter;
latime_1.ops += 3.f;
if (resid > *tol * gap && dabs(rqcorr) > eps *
4.f * dabs(lambda)) {
latime_1.ops += 1.f;
work[k] = lambda + rqcorr;
if (iter < maxitr) {
goto L90;
}
}
iwork[ktot] = 1;
if (newsiz == 1) {
++ndone;
}
latime_1.ops += (real) (in << 1);
csscal_(&in, &nrminv, &z___ref(ibegin, ktot), &
c__1);
++ktot;
/* L100: */
}
if (newsiz > 1) {
itmp1 = isuppz[(newftt << 1) - 1];
itmp2 = isuppz[newftt * 2];
ktot = oldien + newlst;
i__4 = ktot;
for (p = newftt + 1; p <= i__4; ++p) {
i__5 = p - 1;
for (q = newftt; q <= i__5; ++q) {
latime_1.ops += (real) (in * 10);
cdotu_(&q__2, &in, &z___ref(ibegin, p), &
c__1, &z___ref(ibegin, q), &c__1);
q__1.r = -q__2.r, q__1.i = -q__2.i;
tmp1 = q__1.r;
q__1.r = tmp1, q__1.i = 0.f;
caxpy_(&in, &q__1, &z___ref(ibegin, q), &
c__1, &z___ref(ibegin, p), &c__1);
/* L110: */
}
latime_1.ops += (real) ((in << 3) + 1);
tmp1 = 1.f / scnrm2_(&in, &z___ref(ibegin, p),
&c__1);
csscal_(&in, &tmp1, &z___ref(ibegin, p), &
c__1);
/* Computing MIN */
i__5 = itmp1, i__6 = isuppz[(p << 1) - 1];
itmp1 = min(i__5,i__6);
/* Computing MAX */
i__5 = itmp2, i__6 = isuppz[p * 2];
itmp2 = max(i__5,i__6);
/* L120: */
}
i__4 = ktot;
for (p = newftt; p <= i__4; ++p) {
isuppz[(p << 1) - 1] = itmp1;
isuppz[p * 2] = itmp2;
/* L130: */
}
ndone += newsiz;
}
}
newfrs = j + 1;
L140:
;
}
/* L150: */
}
++ndepth;
goto L40;
}
j = ibegin << 1;
i__2 = iend;
for (i__ = ibegin; i__ <= i__2; ++i__) {
isuppz[j - 1] += oldien;
isuppz[j] += oldien;
j += 2;
/* L160: */
}
ibegin = iend + 1;
L170:
;
}
return 0;
/* End of CLARRV */
} /* clarrv_ */
