/* Subroutine */ int cpptrs_(char *uplo, integer *n, integer *nrhs, complex *
ap, complex *b, integer *ldb, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CPPTRS solves a system of linear equations A*X = B with a Hermitian
positive definite matrix A in packed storage using the Cholesky
factorization A = U**H*U or A = L*L**H computed by CPPTRF.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
AP (input) COMPLEX array, dimension (N*(N+1)/2)
The triangular factor U or L from the Cholesky factorization
A = U**H*U or A = L*L**H, packed columnwise in a linear
array. The j-th column of U or L is stored in the array AP
as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the right hand side matrix B.
On exit, the solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
static integer i;
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *), xerbla_(
char *, integer *);
#define AP(I) ap[(I)-1]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPPTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B where A = U'*U. */
i__1 = *nrhs;
for (i = 1; i <= *nrhs; ++i) {
/* Solve U'*X = B, overwriting B with X. */
ctpsv_("Upper", "Conjugate transpose", "Non-unit", n, &AP(1), &B(1,i), &c__1);
/* Solve U*X = B, overwriting B with X. */
ctpsv_("Upper", "No transpose", "Non-unit", n, &AP(1), &B(1,i), &c__1);
/* L10: */
}
} else {
/* Solve A*X = B where A = L*L'. */
i__1 = *nrhs;
for (i = 1; i <= *nrhs; ++i) {
/* Solve L*Y = B, overwriting B with X. */
ctpsv_("Lower", "No transpose", "Non-unit", n, &AP(1), &B(1,i), &c__1);
/* Solve L'*X = Y, overwriting B with X. */
ctpsv_("Lower", "Conjugate transpose", "Non-unit", n, &AP(1), &B(1,i), &c__1);
/* L20: */
}
}
return 0;
/* End of CPPTRS */
} /* cpptrs_ */
/* Subroutine */ int ctptrs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer j, jc;
logical upper;
logical nounit;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CTPTRS solves a triangular system of the form */
/* A * X = B, A**T * X = B, or A**H * X = B, */
/* where A is a triangular matrix of order N stored in packed format, */
/* and B is an N-by-NRHS matrix. A check is made to verify that A is */
/* nonsingular. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': A is upper triangular; */
/* = 'L': A is lower triangular. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose) */
/* DIAG (input) CHARACTER*1 */
/* = 'N': A is non-unit triangular; */
/* = 'U': A is unit triangular. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The upper or lower triangular matrix A, packed columnwise in */
/* a linear array. The j-th column of A is stored in the array */
/* AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, if INFO = 0, the solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, the i-th diagonal element of A is zero, */
/* indicating that the matrix is singular and the */
/* solutions X have not been computed. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! lsame_(trans, "N") && ! lsame_(trans,
"T") && ! lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTPTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check for singularity. */
if (nounit) {
if (upper) {
jc = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = jc + *info - 1;
if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
return 0;
}
jc += *info;
}
} else {
jc = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = jc;
if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
return 0;
}
jc = jc + *n - *info + 1;
}
}
}
*info = 0;
/* Solve A * x = b, A**T * x = b, or A**H * x = b. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ctpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1);
}
return 0;
/* End of CTPTRS */
} /* ctptrs_ */
/* Subroutine */ int chpgst_(integer *itype, char *uplo, integer *n, complex *
ap, complex *bp, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
static integer j, k, j1, k1, jj, kk;
static complex ct;
static real ajj;
static integer j1j1;
static real akk;
static integer k1k1;
static real bjj, bkk;
extern /* Subroutine */ int chpr2_(char *, integer *, complex *, complex *
, integer *, complex *, integer *, complex *, ftnlen);
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chpmv_(char *, integer *, complex *, complex *
, complex *, integer *, complex *, complex *, integer *, ftnlen),
caxpy_(integer *, complex *, complex *, integer *, complex *,
integer *), ctpmv_(char *, char *, char *, integer *, complex *,
complex *, integer *, ftnlen, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *, ftnlen, ftnlen, ftnlen), csscal_(
integer *, real *, complex *, integer *), xerbla_(char *, integer
*, ftnlen);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPGST reduces a complex Hermitian-definite generalized */
/* eigenproblem to standard form, using packed storage. */
/* If ITYPE = 1, the problem is A*x = lambda*B*x, */
/* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */
/* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
/* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */
/* B must have been previously factorized as U**H*U or L*L**H by CPPTRF. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */
/* = 2 or 3: compute U*A*U**H or L**H*A*L. */
/* UPLO (input) CHARACTER */
/* = 'U': Upper triangle of A is stored and B is factored as */
/* U**H*U; */
/* = 'L': Lower triangle of A is stored and B is factored as */
/* L*L**H. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, if INFO = 0, the transformed matrix, stored in the */
/* same format as A. */
/* BP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The triangular factor from the Cholesky factorization of B, */
/* stored in the same format as A, as returned by CPPTRF. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPGST", &i__1, (ftnlen)6);
return 0;
}
if (*itype == 1) {
if (upper) {
/* Compute inv(U')*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
i__2 = jj;
i__3 = jj;
r__1 = ap[i__3].r;
ap[i__2].r = r__1, ap[i__2].i = 0.f;
i__2 = jj;
bjj = bp[i__2].r;
ctpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], &
ap[j1], &c__1, (ftnlen)1, (ftnlen)19, (ftnlen)8);
i__2 = j - 1;
q__1.r = -1.f, q__1.i = -0.f;
chpmv_(uplo, &i__2, &q__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[
j1], &c__1, (ftnlen)1);
i__2 = j - 1;
r__1 = 1.f / bjj;
csscal_(&i__2, &r__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
cdotc_(&q__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
q__2.r = ap[i__3].r - q__3.r, q__2.i = ap[i__3].i - q__3.i;
q__1.r = q__2.r / bjj, q__1.i = q__2.i / bjj;
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
/* L10: */
}
} else {
/* Compute inv(L)*A*inv(L') */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = kk;
ap[i__2].r = akk, ap[i__2].i = 0.f;
if (k < *n) {
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
r__1 = akk * -.5f;
ct.r = r__1, ct.i = 0.f;
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
chpr2_(uplo, &i__2, &q__1, &ap[kk + 1], &c__1, &bp[kk + 1]
, &c__1, &ap[k1k1], (ftnlen)1);
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
;
i__2 = *n - k;
ctpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
&ap[kk + 1], &c__1, (ftnlen)1, (ftnlen)12, (
ftnlen)8);
}
kk = k1k1;
/* L20: */
}
}
} else {
if (upper) {
/* Compute U*A*U' */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
i__2 = k - 1;
ctpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
k1], &c__1, (ftnlen)1, (ftnlen)12, (ftnlen)8);
r__1 = akk * .5f;
ct.r = r__1, ct.i = 0.f;
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
chpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, &
ap[1], (ftnlen)1);
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
ap[i__2].r = r__1, ap[i__2].i = 0.f;
/* L30: */
}
} else {
/* Compute L'*A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
i__2 = jj;
ajj = ap[i__2].r;
i__2 = jj;
bjj = bp[i__2].r;
i__2 = jj;
r__1 = ajj * bjj;
i__3 = *n - j;
cdotc_(&q__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
q__1.r = r__1 + q__2.r, q__1.i = q__2.i;
ap[i__2].r = q__1.r, ap[i__2].i = q__1.i;
i__2 = *n - j;
csscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
chpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, &
c_b1, &ap[jj + 1], &c__1, (ftnlen)1);
i__2 = *n - j + 1;
ctpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj]
, &ap[jj], &c__1, (ftnlen)1, (ftnlen)19, (ftnlen)8);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of CHPGST */
} /* chpgst_ */
/* Subroutine */ int cpptrs_(char *uplo, integer *n, integer *nrhs, complex *
ap, complex *b, integer *ldb, integer *info, ftnlen uplo_len)
{
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
static integer i__;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *, ftnlen, ftnlen, ftnlen), xerbla_(
char *, integer *, ftnlen);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPPTRS solves a system of linear equations A*X = B with a Hermitian */
/* positive definite matrix A in packed storage using the Cholesky */
/* factorization A = U**H*U or A = L*L**H computed by CPPTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The triangular factor U or L from the Cholesky factorization */
/* A = U**H*U or A = L*L**H, packed columnwise in a linear */
/* array. The j-th column of U or L is stored in the array AP */
/* as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the right hand side matrix B. */
/* On exit, the solution matrix X. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*nrhs < 0) {
*info = -3;
} else if (*ldb < max(1,*n)) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPPTRS", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B where A = U'*U. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U'*X = B, overwriting B with X. */
ctpsv_("Upper", "Conjugate transpose", "Non-unit", n, &ap[1], &b[
i__ * b_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)19, (ftnlen)
8);
/* Solve U*X = B, overwriting B with X. */
ctpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ *
b_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8);
/* L10: */
}
} else {
/* Solve A*X = B where A = L*L'. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve L*Y = B, overwriting B with X. */
ctpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ *
b_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)12, (ftnlen)8);
/* Solve L'*X = Y, overwriting B with X. */
ctpsv_("Lower", "Conjugate transpose", "Non-unit", n, &ap[1], &b[
i__ * b_dim1 + 1], &c__1, (ftnlen)5, (ftnlen)19, (ftnlen)
8);
/* L20: */
}
}
return 0;
/* End of CPPTRS */
} /* cpptrs_ */
/* Subroutine */ int ctptrs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *ap, complex *b, integer *ldb, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CTPTRS solves a triangular system of the form
A * X = B, A**T * X = B, or A**H * X = B,
where A is a triangular matrix of order N stored in packed format,
and B is an N-by-NRHS matrix. A check is made to verify that A is
nonsingular.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose)
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
AP (input) COMPLEX array, dimension (N*(N+1)/2)
The upper or lower triangular matrix A, packed columnwise in
a linear array. The j-th column of A is stored in the array
AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
B (input/output) COMPLEX array, dimension (LDB,NRHS)
On entry, the right hand side matrix B.
On exit, if INFO = 0, the solution matrix X.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the i-th diagonal element of A is zero,
indicating that the matrix is singular and the
solutions X have not been computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *);
static integer jc;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical nounit;
#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)]
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! lsame_(trans, "N") && ! lsame_(trans,
"T") && ! lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTPTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check for singularity. */
if (nounit) {
if (upper) {
jc = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = jc + *info - 1;
if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
return 0;
}
jc += *info;
/* L10: */
}
} else {
jc = 1;
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
i__2 = jc;
if (ap[i__2].r == 0.f && ap[i__2].i == 0.f) {
return 0;
}
jc = jc + *n - *info + 1;
/* L20: */
}
}
}
*info = 0;
/* Solve A * x = b, A**T * x = b, or A**H * x = b. */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ctpsv_(uplo, trans, diag, n, &ap[1], &b_ref(1, j), &c__1);
/* L30: */
}
return 0;
/* End of CTPTRS */
} /* ctptrs_ */
/* Subroutine */
int cpptrs_(char *uplo, integer *n, integer *nrhs, complex * ap, complex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1;
/* Local variables */
integer i__;
extern logical lsame_(char *, char *);
logical upper;
extern /* Subroutine */
int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *), xerbla_( char *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L"))
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*nrhs < 0)
{
*info = -3;
}
else if (*ldb < max(1,*n))
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CPPTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0)
{
return 0;
}
if (upper)
{
/* Solve A*X = B where A = U**H * U. */
i__1 = *nrhs;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Solve U**H *X = B, overwriting B with X. */
ctpsv_("Upper", "Conjugate transpose", "Non-unit", n, &ap[1], &b[ i__ * b_dim1 + 1], &c__1);
/* Solve U*X = B, overwriting B with X. */
ctpsv_("Upper", "No transpose", "Non-unit", n, &ap[1], &b[i__ * b_dim1 + 1], &c__1);
/* L10: */
}
}
else
{
/* Solve A*X = B where A = L * L**H. */
i__1 = *nrhs;
for (i__ = 1;
i__ <= i__1;
++i__)
{
/* Solve L*Y = B, overwriting B with X. */
ctpsv_("Lower", "No transpose", "Non-unit", n, &ap[1], &b[i__ * b_dim1 + 1], &c__1);
/* Solve L**H *X = Y, overwriting B with X. */
ctpsv_("Lower", "Conjugate transpose", "Non-unit", n, &ap[1], &b[ i__ * b_dim1 + 1], &c__1);
/* L20: */
}
}
return 0;
/* End of CPPTRS */
}
/* Subroutine */ int cpptrf_(char *uplo, integer *n, complex *ap, 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
=======
CPPTRF computes the Cholesky factorization of a complex Hermitian
positive definite matrix A stored in packed format.
The factorization has the form
A = U**H * U, if UPLO = 'U', or
A = L * L**H, if UPLO = 'L',
where U is an upper triangular matrix and L is lower triangular.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': Upper triangle of A is stored;
= 'L': Lower triangle of A is stored.
N (input) INTEGER
The order of the matrix A. N >= 0.
AP (input/output) COMPLEX array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the Hermitian matrix
A, packed columnwise in a linear array. The j-th column of A
is stored in the array AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
See below for further details.
On exit, if INFO = 0, the triangular factor U or L from the
Cholesky factorization A = U**H*U or A = L*L**H, in the same
storage format as A.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the leading minor of order i is not
positive definite, and the factorization could not be
completed.
Further Details
===============
The packed storage scheme is illustrated by the following example
when N = 4, UPLO = 'U':
Two-dimensional storage of the Hermitian matrix A:
a11 a12 a13 a14
a22 a23 a24
a33 a34 (aij = conjg(aji))
a44
Packed storage of the upper triangle of A:
AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static real c_b16 = -1.f;
/* System generated locals */
integer i__1, i__2, i__3;
real r__1;
complex q__1, q__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
extern /* Subroutine */ int chpr_(char *, integer *, real *, complex *,
integer *, complex *);
static integer j;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *);
static integer jc, jj;
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
static real ajj;
--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_("CPPTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (upper) {
/* Compute the Cholesky factorization A = U'*U. */
jj = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
jc = jj + 1;
jj += j;
/* Compute elements 1:J-1 of column J. */
if (j > 1) {
i__2 = j - 1;
ctpsv_("Upper", "Conjugate transpose", "Non-unit", &i__2, &ap[
1], &ap[jc], &c__1);
}
/* Compute U(J,J) and test for non-positive-definiteness. */
i__2 = jj;
r__1 = ap[i__2].r;
i__3 = j - 1;
cdotc_(&q__2, &i__3, &ap[jc], &c__1, &ap[jc], &c__1);
q__1.r = r__1 - q__2.r, q__1.i = -q__2.i;
ajj = q__1.r;
if (ajj <= 0.f) {
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.f;
goto L30;
}
i__2 = jj;
r__1 = sqrt(ajj);
ap[i__2].r = r__1, ap[i__2].i = 0.f;
/* L10: */
}
} else {
/* Compute the Cholesky factorization A = L*L'. */
jj = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Compute L(J,J) and test for non-positive-definiteness. */
i__2 = jj;
ajj = ap[i__2].r;
if (ajj <= 0.f) {
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.f;
goto L30;
}
ajj = sqrt(ajj);
i__2 = jj;
ap[i__2].r = ajj, ap[i__2].i = 0.f;
/* Compute elements J+1:N of column J and update the trailing
submatrix. */
if (j < *n) {
i__2 = *n - j;
r__1 = 1.f / ajj;
csscal_(&i__2, &r__1, &ap[jj + 1], &c__1);
i__2 = *n - j;
chpr_("Lower", &i__2, &c_b16, &ap[jj + 1], &c__1, &ap[jj + *n
- j + 1]);
jj = jj + *n - j + 1;
}
/* L20: */
}
}
goto L40;
L30:
*info = j;
L40:
return 0;
/* End of CPPTRF */
} /* cpptrf_ */
/* Subroutine */ int chpgv_(integer *itype, char *jobz, char *uplo, integer *
n, complex *ap, complex *bp, real *w, complex *z__, integer *ldz,
complex *work, real *rwork, integer *info, ftnlen jobz_len, ftnlen
uplo_len)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
/* Local variables */
static integer j, neig;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int chpev_(char *, char *, integer *, complex *,
real *, complex *, integer *, complex *, real *, integer *,
ftnlen, ftnlen);
static char trans[1];
extern /* Subroutine */ int ctpmv_(char *, char *, char *, integer *,
complex *, complex *, integer *, ftnlen, ftnlen, ftnlen);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *, ftnlen, ftnlen, ftnlen);
static logical wantz;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), chpgst_(
integer *, char *, integer *, complex *, complex *, integer *,
ftnlen), cpptrf_(char *, integer *, complex *, integer *, ftnlen);
/* -- LAPACK driver routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHPGV computes all the eigenvalues and, optionally, the eigenvectors */
/* of a complex generalized Hermitian-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */
/* Here A and B are assumed to be Hermitian, stored in packed format, */
/* and B is also positive definite. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* A, packed columnwise in a linear array. The j-th column of A */
/* is stored in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, the contents of AP are destroyed. */
/* BP (input/output) COMPLEX array, dimension (N*(N+1)/2) */
/* On entry, the upper or lower triangle of the Hermitian matrix */
/* B, packed columnwise in a linear array. The j-th column of B */
/* is stored in the array BP as follows: */
/* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
/* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
/* On exit, the triangular factor U or L from the Cholesky */
/* factorization B = U**H*U or B = L*L**H, in the same storage */
/* format as B. */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) COMPLEX array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
/* eigenvectors. The eigenvectors are normalized as follows: */
/* if ITYPE = 1 or 2, Z**H*B*Z = I; */
/* if ITYPE = 3, Z**H*inv(B)*Z = I. */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1)) */
/* RWORK (workspace) REAL array, dimension (max(1, 3*N-2)) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: CPPTRF or CHPEV returned an error code: */
/* <= N: if INFO = i, CHPEV failed to converge; */
/* i off-diagonal elements of an intermediate */
/* tridiagonal form did not convergeto zero; */
/* > N: if INFO = N + i, for 1 <= i <= n, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--bp;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V", (ftnlen)1, (ftnlen)1);
upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
*info = 0;
if (*itype < 0 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N", (ftnlen)1, (ftnlen)1))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L", (ftnlen)1, (ftnlen)1))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHPGV ", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
cpptrf_(uplo, n, &bp[1], info, (ftnlen)1);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
chpgst_(itype, uplo, n, &ap[1], &bp[1], info, (ftnlen)1);
chpev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], &
rwork[1], info, (ftnlen)1, (ftnlen)1);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'C';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
ctpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
1], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)8);
/* L10: */
}
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'C';
} else {
*(unsigned char *)trans = 'N';
}
i__1 = neig;
for (j = 1; j <= i__1; ++j) {
ctpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 +
1], &c__1, (ftnlen)1, (ftnlen)1, (ftnlen)8);
/* L20: */
}
}
}
return 0;
/* End of CHPGV */
} /* chpgv_ */
/* Subroutine */
int clatps_(char *uplo, char *trans, char *diag, char * normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm, integer *info)
{
/* System generated locals */
integer 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, ip;
real xj, rec, tjj;
integer jinc, jlen;
real xbnd;
integer imax;
real tmax;
complex tjjs;
real xmax, grow;
extern /* Complex */
VOID cdotc_f2c_(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_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
complex csumj;
extern /* Subroutine */
int caxpy_(integer *, complex *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */
int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *), slabad_( real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Complex */
VOID cladiv_(complex *, complex *, complex *);
extern real slamch_(char *);
extern /* Subroutine */
int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
extern real scasum_(integer *, complex *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--cnorm;
--x;
--ap;
/* 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;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CLATPS", &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. */
ip = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
i__2 = j - 1;
cnorm[j] = scasum_(&i__2, &ap[ip], &c__1);
ip += j;
/* L10: */
}
}
else
{
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1;
j <= i__1;
++j)
{
i__2 = *n - j;
cnorm[j] = scasum_(&i__2, &ap[ip + 1], &c__1);
ip = ip + *n - j + 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 CTPSV 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, abs(r__1)) + (r__2 = r_imag(&x[j]) / 2.f, abs(r__2)); // , expr subst
xmax = max(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 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
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 = ip;
tjjs.r = ap[i__3].r;
tjjs.i = ap[i__3].i; // , expr subst
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( r__2));
if (tjj >= smlnum)
{
/* M(j) = G(j-1) / abs(A(j,j)) */
/* Computing MIN */
r__1 = xbnd;
r__2 = min(1.f,tjj) * grow; // , expr subst
xbnd = min(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;
}
ip += jinc * jlen;
--jlen;
/* 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 / max(xbnd,smlnum); // , expr subst
grow = min(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 / max(xbnd,smlnum);
xbnd = grow;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
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; // , expr subst
grow = min(r__1,r__2);
i__3 = ip;
tjjs.r = ap[i__3].r;
tjjs.i = ap[i__3].i; // , expr subst
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( 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;
}
++jlen;
ip += jinc * jlen;
/* L70: */
}
grow = min(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 / max(xbnd,smlnum); // , expr subst
grow = min(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. */
ctpsv_(uplo, trans, diag, n, &ap[1], &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 */
ip = jfirst * (jfirst + 1) / 2;
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, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
if (nounit)
{
i__3 = ip;
q__1.r = tscal * ap[i__3].r;
q__1.i = tscal * ap[i__3].i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
if (tscal == 1.f)
{
goto L105;
}
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs( 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; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(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; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(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; // , expr subst
/* L100: */
}
i__3 = j;
x[i__3].r = 1.f;
x[i__3].i = 0.f; // , expr subst
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; // , expr subst
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
caxpy_(&i__3, &q__1, &ap[ip - j + 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, abs(r__1)) + (r__2 = r_imag( &x[i__]), abs(r__2));
}
ip -= j;
}
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; // , expr subst
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
caxpy_(&i__3, &q__1, &ap[ip + 1], &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, abs(r__1)) + (r__2 = r_imag( &x[i__]), abs(r__2));
}
ip = ip + *n - j + 1;
}
/* L110: */
}
}
else if (lsame_(trans, "T"))
{
/* Solve A**T * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
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, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
uscal.r = tscal;
uscal.i = 0.f; // , expr subst
rec = 1.f / max(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 = ip;
q__1.r = tscal * ap[i__3].r;
q__1.i = tscal * ap[i__3] .i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(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; // , expr subst
rec = min(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r;
uscal.i = q__1.i; // , expr subst
}
if (rec < 1.f)
{
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f;
csumj.i = 0.f; // , expr subst
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_f2c_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
else if (j < *n)
{
i__3 = *n - j;
cdotu_f2c_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
}
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 = ip - j + i__;
q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
q__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
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; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L120: */
}
}
else if (j < *n)
{
i__3 = *n - j;
for (i__ = 1;
i__ <= i__3;
++i__)
{
i__4 = ip + i__;
q__3.r = ap[i__4].r * uscal.r - ap[i__4].i * uscal.i;
q__3.i = ap[i__4].r * uscal.i + ap[i__4].i * uscal.r; // , expr subst
i__5 = j + 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; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L130: */
}
}
}
q__1.r = tscal;
q__1.i = 0.f; // , expr subst
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; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
if (nounit)
{
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
i__3 = ip;
q__1.r = tscal * ap[i__3].r;
q__1.i = tscal * ap[i__3] .i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
if (tscal == 1.f)
{
goto L145;
}
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(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; // , expr subst
}
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; // , expr subst
}
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; // , expr subst
/* L140: */
}
i__3 = j;
x[i__3].r = 1.f;
x[i__3].i = 0.f; // , expr subst
*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; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
/* Computing MAX */
i__3 = j;
r__3 = xmax;
r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2)); // , expr subst
xmax = max(r__3,r__4);
++jlen;
ip += jinc * jlen;
/* L150: */
}
}
else
{
/* Solve A**H * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
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, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2));
uscal.r = tscal;
uscal.i = 0.f; // , expr subst
rec = 1.f / max(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, &ap[ip]);
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(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; // , expr subst
rec = min(r__1,r__2);
cladiv_(&q__1, &uscal, &tjjs);
uscal.r = q__1.r;
uscal.i = q__1.i; // , expr subst
}
if (rec < 1.f)
{
csscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
csumj.r = 0.f;
csumj.i = 0.f; // , expr subst
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_f2c_(&q__1, &i__3, &ap[ip - j + 1], &c__1, &x[1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
else if (j < *n)
{
i__3 = *n - j;
cdotc_f2c_(&q__1, &i__3, &ap[ip + 1], &c__1, &x[j + 1], & c__1);
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
}
}
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, &ap[ip - j + i__]);
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; // , expr subst
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; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L160: */
}
}
else if (j < *n)
{
i__3 = *n - j;
for (i__ = 1;
i__ <= i__3;
++i__)
{
r_cnjg(&q__4, &ap[ip + i__]);
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; // , expr subst
i__4 = j + 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; // , expr subst
q__1.r = csumj.r + q__2.r;
q__1.i = csumj.i + q__2.i; // , expr subst
csumj.r = q__1.r;
csumj.i = q__1.i; // , expr subst
/* L170: */
}
}
}
q__1.r = tscal;
q__1.i = 0.f; // , expr subst
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; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
i__3 = j;
xj = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]) , abs(r__2));
if (nounit)
{
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
r_cnjg(&q__2, &ap[ip]);
q__1.r = tscal * q__2.r;
q__1.i = tscal * q__2.i; // , expr subst
tjjs.r = q__1.r;
tjjs.i = q__1.i; // , expr subst
}
else
{
tjjs.r = tscal;
tjjs.i = 0.f; // , expr subst
if (tscal == 1.f)
{
goto L185;
}
}
tjj = (r__1 = tjjs.r, abs(r__1)) + (r__2 = r_imag(&tjjs), abs(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; // , expr subst
}
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; // , expr subst
}
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; // , expr subst
/* L180: */
}
i__3 = j;
x[i__3].r = 1.f;
x[i__3].i = 0.f; // , expr subst
*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; // , expr subst
x[i__3].r = q__1.r;
x[i__3].i = q__1.i; // , expr subst
}
/* Computing MAX */
i__3 = j;
r__3 = xmax;
r__4 = (r__1 = x[i__3].r, abs(r__1)) + (r__2 = r_imag(&x[j]), abs(r__2)); // , expr subst
xmax = max(r__3,r__4);
++jlen;
ip += jinc * jlen;
/* 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 CLATPS */
}
/* Subroutine */ int clatps_(char *uplo, char *trans, char *diag, char *
normin, integer *n, complex *ap, complex *x, real *scale, real *cnorm,
integer *info)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1992
Purpose
=======
CLATPS 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, where A is an upper or lower
triangular matrix stored in packed form. Here 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 CTPSV 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.
AP (input) COMPLEX array, dimension (N*(N+1)/2)
The upper or lower triangular matrix A, packed columnwise in
a linear array. The j-th column of A is stored in the array
AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=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, CTPSV
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 CTPSV 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 CTPSV if 1/M(n) and 1/G(n) are both greater
than max(underflow, 1/overflow).
=====================================================================
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static real c_b36 = .5f;
/* System generated locals */
integer 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 */
static integer jinc, jlen;
static real xbnd;
static integer imax;
static real tmax;
static complex tjjs;
static real xmax, grow;
static integer i__, j;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static real tscal;
static complex uscal;
static integer jlast;
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
static complex csumj;
extern /* Subroutine */ int caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *), slabad_(
real *, real *);
static integer ip;
static real xj;
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 *);
static real bignum;
extern integer isamax_(integer *, real *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
static logical notran;
static integer jfirst;
static real smlnum;
static logical nounit;
static real rec, tjj;
--cnorm;
--x;
--ap;
/* 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;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLATPS", &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. */
ip = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
cnorm[j] = scasum_(&i__2, &ap[ip], &c__1);
ip += j;
/* L10: */
}
} else {
/* A is lower triangular. */
ip = 1;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j;
cnorm[j] = scasum_(&i__2, &ap[ip + 1], &c__1);
ip = ip + *n - j + 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 CTPSV 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;
ip = jfirst * (jfirst + 1) / 2;
jlen = *n;
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 = ip;
tjjs.r = ap[i__3].r, tjjs.i = ap[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;
}
ip += jinc * jlen;
--jlen;
/* 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;
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
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 = ip;
tjjs.r = ap[i__3].r, tjjs.i = ap[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;
}
++jlen;
ip += jinc * jlen;
/* 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. */
ctpsv_(uplo, trans, diag, n, &ap[1], &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 */
ip = jfirst * (jfirst + 1) / 2;
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 = ip;
q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[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, &ap[ip - j + 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));
}
ip -= j;
} 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, &ap[ip + 1], &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));
}
ip = ip + *n - j + 1;
}
/* L110: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
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 = ip;
q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[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, &ap[ip - j + 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, &ap[ip + 1], &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 = ip - j + i__;
q__3.r = ap[i__4].r * uscal.r - ap[i__4].i *
uscal.i, q__3.i = ap[i__4].r * uscal.i +
ap[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 - j;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = ip + i__;
q__3.r = ap[i__4].r * uscal.r - ap[i__4].i *
uscal.i, q__3.i = ap[i__4].r * uscal.i +
ap[i__4].i * uscal.r;
i__5 = j + 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) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
i__3 = ip;
q__1.r = tscal * ap[i__3].r, q__1.i = tscal * ap[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;
}
}
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);
++jlen;
ip += jinc * jlen;
/* L150: */
}
} else {
/* Solve A**H * x = b */
ip = jfirst * (jfirst + 1) / 2;
jlen = 1;
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, &ap[ip]);
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, &ap[ip - j + 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, &ap[ip + 1], &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, &ap[ip - j + i__]);
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 - j;
for (i__ = 1; i__ <= i__3; ++i__) {
r_cnjg(&q__4, &ap[ip + i__]);
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 = j + 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) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
r_cnjg(&q__2, &ap[ip]);
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;
}
}
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);
++jlen;
ip += jinc * jlen;
/* 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 CLATPS */
} /* clatps_ */
/* Subroutine */
int chpgvx_(integer *itype, char *jobz, char *range, char * uplo, integer *n, complex *ap, complex *bp, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex * z__, integer *ldz, complex *work, real *rwork, integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1;
/* Local variables */
integer j;
extern logical lsame_(char *, char *);
char trans[1];
extern /* Subroutine */
int ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *);
logical upper;
extern /* Subroutine */
int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *);
logical wantz, alleig, indeig, valeig;
extern /* Subroutine */
int xerbla_(char *, integer *), chpgst_( integer *, char *, integer *, complex *, complex *, integer *), chpevx_(char *, char *, char *, integer *, complex *, real *, real *, integer *, integer *, real *, integer *, real *, complex *, integer *, complex *, real *, integer *, integer *, integer *), cpptrf_(char *, integer *, complex *, integer *);
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--ap;
--bp;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (*itype < 1 || *itype > 3)
{
*info = -1;
}
else if (! (wantz || lsame_(jobz, "N")))
{
*info = -2;
}
else if (! (alleig || valeig || indeig))
{
*info = -3;
}
else if (! (upper || lsame_(uplo, "L")))
{
*info = -4;
}
else if (*n < 0)
{
*info = -5;
}
else
{
if (valeig)
{
if (*n > 0 && *vu <= *vl)
{
*info = -9;
}
}
else if (indeig)
{
if (*il < 1)
{
*info = -10;
}
else if (*iu < min(*n,*il) || *iu > *n)
{
*info = -11;
}
}
}
if (*info == 0)
{
if (*ldz < 1 || wantz && *ldz < *n)
{
*info = -16;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CHPGVX", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Form a Cholesky factorization of B. */
cpptrf_(uplo, n, &bp[1], info);
if (*info != 0)
{
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
chpgst_(itype, uplo, n, &ap[1], &bp[1], info);
chpevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], & z__[z_offset], ldz, &work[1], &rwork[1], &iwork[1], &ifail[1], info);
if (wantz)
{
/* Backtransform eigenvectors to the original problem. */
if (*info > 0)
{
*m = *info - 1;
}
if (*itype == 1 || *itype == 2)
{
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
*/
/* backtransform eigenvectors: x = inv(L)**H*y or inv(U)*y */
if (upper)
{
*(unsigned char *)trans = 'N';
}
else
{
*(unsigned char *)trans = 'C';
}
i__1 = *m;
for (j = 1;
j <= i__1;
++j)
{
ctpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1);
/* L10: */
}
}
else if (*itype == 3)
{
/* For B*A*x=(lambda)*x;
*/
/* backtransform eigenvectors: x = L*y or U**H*y */
if (upper)
{
*(unsigned char *)trans = 'C';
}
else
{
*(unsigned char *)trans = 'N';
}
i__1 = *m;
for (j = 1;
j <= i__1;
++j)
{
ctpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 1], &c__1);
/* L20: */
}
}
}
return 0;
/* End of CHPGVX */
}
/* Subroutine */ int ctprfs_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *ap, complex *b, integer *ldb, complex *x,
integer *ldx, real *ferr, real *berr, complex *work, real *rwork,
integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
CTPRFS provides error bounds and backward error estimates for the
solution to a system of linear equations with a triangular packed
coefficient matrix.
The solution matrix X must be computed by CTPTRS or some other
means before entering this routine. CTPRFS does not do iterative
refinement because doing so cannot improve the backward error.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
TRANS (input) CHARACTER*1
Specifies the form of the system of equations:
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose)
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrices B and X. NRHS >= 0.
AP (input) COMPLEX array, dimension (N*(N+1)/2)
The upper or lower triangular matrix A, packed columnwise in
a linear array. The j-th column of A is stored in the array
AP as follows:
if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
If DIAG = 'U', the diagonal elements of A are not referenced
and are assumed to be 1.
B (input) COMPLEX array, dimension (LDB,NRHS)
The right hand side matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX array, dimension (LDX,NRHS)
The solution matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
FERR (output) REAL array, dimension (NRHS)
The estimated forward error bound for each solution vector
X(j) (the j-th column of the solution matrix X).
If XTRUE is the true solution corresponding to X(j), FERR(j)
is an estimated upper bound for the magnitude of the largest
element in (X(j) - XTRUE) divided by the magnitude of the
largest element in X(j). The estimate is as reliable as
the estimate for RCOND, and is almost always a slight
overestimate of the true error.
BERR (output) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector X(j) (i.e., the smallest relative change in
any element of A or B that makes X(j) an exact solution).
WORK (workspace) COMPLEX array, dimension (2*N)
RWORK (workspace) REAL array, dimension (N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static integer kase;
static real safe1, safe2;
static integer i__, j, k;
static real s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), caxpy_(integer *, complex *, complex *,
integer *, complex *, integer *), ctpmv_(char *, char *, char *,
integer *, complex *, complex *, integer *);
static logical upper;
extern /* Subroutine */ int ctpsv_(char *, char *, char *, integer *,
complex *, complex *, integer *);
static integer kc;
extern /* Subroutine */ int clacon_(integer *, complex *, complex *, real
*, integer *);
static real xk;
extern doublereal slamch_(char *);
static integer nz;
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
static char transn[1], transt[1];
static logical nounit;
static real lstres, eps;
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else if (*ldx < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTPRFS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] = 0.f;
berr[j] = 0.f;
/* L10: */
}
return 0;
}
if (notran) {
*(unsigned char *)transn = 'N';
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transn = 'C';
*(unsigned char *)transt = 'N';
}
/* NZ = maximum number of nonzero elements in each row of A, plus 1 */
nz = *n + 1;
eps = slamch_("Epsilon");
safmin = slamch_("Safe minimum");
safe1 = nz * safmin;
safe2 = safe1 / eps;
/* Do for each right hand side */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
/* Compute residual R = B - op(A) * X,
where op(A) = A, A**T, or A**H, depending on TRANS. */
ccopy_(n, &x_ref(1, j), &c__1, &work[1], &c__1);
ctpmv_(uplo, trans, diag, n, &ap[1], &work[1], &c__1);
q__1.r = -1.f, q__1.i = 0.f;
caxpy_(n, &q__1, &b_ref(1, j), &c__1, &work[1], &c__1);
/* Compute componentwise relative backward error from formula
max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
where abs(Z) is the componentwise absolute value of the matrix
or vector Z. If the i-th component of the denominator is less
than SAFE2, then SAFE1 is added to the i-th components of the
numerator and denominator before dividing. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
rwork[i__] = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
b_ref(i__, j)), dabs(r__2));
/* L20: */
}
if (notran) {
/* Compute abs(A)*abs(X) + abs(B). */
if (upper) {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - 1;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kc + i__ - 1]), dabs(
r__2))) * xk;
/* L30: */
}
kc += k;
/* L40: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - 1;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kc + i__ - 1]), dabs(
r__2))) * xk;
/* L50: */
}
rwork[k] += xk;
kc += k;
/* L60: */
}
}
} else {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
i__4 = kc + i__ - k;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kc + i__ - k]), dabs(
r__2))) * xk;
/* L70: */
}
kc = kc + *n - k + 1;
/* L80: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
xk = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - k;
rwork[i__] += ((r__1 = ap[i__4].r, dabs(r__1)) + (
r__2 = r_imag(&ap[kc + i__ - k]), dabs(
r__2))) * xk;
/* L90: */
}
rwork[k] += xk;
kc = kc + *n - k + 1;
/* L100: */
}
}
}
} else {
/* Compute abs(A**H)*abs(X) + abs(B). */
if (upper) {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = k;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - 1;
i__5 = x_subscr(i__, j);
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kc + i__ - 1]), dabs(r__2))) *
((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L110: */
}
rwork[k] += s;
kc += k;
/* L120: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = k - 1;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - 1;
i__5 = x_subscr(i__, j);
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kc + i__ - 1]), dabs(r__2))) *
((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L130: */
}
rwork[k] += s;
kc += k;
/* L140: */
}
}
} else {
kc = 1;
if (nounit) {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
s = 0.f;
i__3 = *n;
for (i__ = k; i__ <= i__3; ++i__) {
i__4 = kc + i__ - k;
i__5 = x_subscr(i__, j);
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kc + i__ - k]), dabs(r__2))) *
((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L150: */
}
rwork[k] += s;
kc = kc + *n - k + 1;
/* L160: */
}
} else {
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
i__3 = x_subscr(k, j);
s = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
x_ref(k, j)), dabs(r__2));
i__3 = *n;
for (i__ = k + 1; i__ <= i__3; ++i__) {
i__4 = kc + i__ - k;
i__5 = x_subscr(i__, j);
s += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&ap[kc + i__ - k]), dabs(r__2))) *
((r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x_ref(i__, j)), dabs(r__4)));
/* L170: */
}
rwork[k] += s;
kc = kc + *n - k + 1;
/* L180: */
}
}
}
}
s = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2))) / rwork[i__];
s = dmax(r__3,r__4);
} else {
/* Computing MAX */
i__3 = i__;
r__3 = s, r__4 = ((r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + safe1) / (rwork[i__]
+ safe1);
s = dmax(r__3,r__4);
}
/* L190: */
}
berr[j] = s;
/* Bound error from formula
norm(X - XTRUE) / norm(X) .le. FERR =
norm( abs(inv(op(A)))*
( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
where
norm(Z) is the magnitude of the largest component of Z
inv(op(A)) is the inverse of op(A)
abs(Z) is the componentwise absolute value of the matrix or
vector Z
NZ is the maximum number of nonzeros in any row of A, plus 1
EPS is machine epsilon
The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
is incremented by SAFE1 if the i-th component of
abs(op(A))*abs(X) + abs(B) is less than SAFE2.
Use CLACON to estimate the infinity-norm of the matrix
inv(op(A)) * diag(W),
where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
if (rwork[i__] > safe2) {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__];
} else {
i__3 = i__;
rwork[i__] = (r__1 = work[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&work[i__]), dabs(r__2)) + nz * eps * rwork[
i__] + safe1;
}
/* L200: */
}
kase = 0;
L210:
clacon_(n, &work[*n + 1], &work[1], &ferr[j], &kase);
if (kase != 0) {
if (kase == 1) {
/* Multiply by diag(W)*inv(op(A)**H). */
ctpsv_(uplo, transt, diag, n, &ap[1], &work[1], &c__1);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L220: */
}
} else {
/* Multiply by inv(op(A))*diag(W). */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__;
i__4 = i__;
i__5 = i__;
q__1.r = rwork[i__4] * work[i__5].r, q__1.i = rwork[i__4]
* work[i__5].i;
work[i__3].r = q__1.r, work[i__3].i = q__1.i;
/* L230: */
}
ctpsv_(uplo, transn, diag, n, &ap[1], &work[1], &c__1);
}
goto L210;
}
/* Normalize error. */
lstres = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
i__3 = x_subscr(i__, j);
r__3 = lstres, r__4 = (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x_ref(i__, j)), dabs(r__2));
lstres = dmax(r__3,r__4);
/* L240: */
}
if (lstres != 0.f) {
ferr[j] /= lstres;
}
/* L250: */
}
return 0;
/* End of CTPRFS */
} /* ctprfs_ */
void cblas_ctpsv(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
const enum CBLAS_TRANSPOSE TransA, const enum CBLAS_DIAG Diag,
const integer N, const void *Ap, void *X, const integer incX)
{
char TA;
char UL;
char DI;
#ifdef F77_CHAR
F77_CHAR F77_TA, F77_UL, F77_DI;
#else
#define F77_TA &TA
#define F77_UL &UL
#define F77_DI &DI
#endif
#define F77_N N
#define F77_incX incX
integer n, i=0, tincX;
float *st=0, *x=(float*)X;
extern integer CBLAS_CallFromC;
extern integer RowMajorStrg;
RowMajorStrg = 0;
CBLAS_CallFromC = 1;
if (order == CblasColMajor)
{
if (Uplo == CblasUpper) UL = 'U';
else if (Uplo == CblasLower) UL = 'L';
else
{
cblas_xerbla(2, "cblas_ctpsv","Illegal Uplo setting, %d\n", Uplo);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if (TransA == CblasNoTrans) TA = 'N';
else if (TransA == CblasTrans) TA = 'T';
else if (TransA == CblasConjTrans) TA = 'C';
else
{
cblas_xerbla(3, "cblas_ctpsv","Illegal TransA setting, %d\n", TransA);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if (Diag == CblasUnit) DI = 'U';
else if (Diag == CblasNonUnit) DI = 'N';
else
{
cblas_xerbla(4, "cblas_ctpsv","Illegal Diag setting, %d\n", Diag);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_TA = C2F_CHAR(&TA);
F77_DI = C2F_CHAR(&DI);
#endif
ctpsv_( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X, &F77_incX);
}
else if (order == CblasRowMajor)
{
RowMajorStrg = 1;
if (Uplo == CblasUpper) UL = 'L';
else if (Uplo == CblasLower) UL = 'U';
else
{
cblas_xerbla(2, "cblas_ctpsv","Illegal Uplo setting, %d\n", Uplo);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if (TransA == CblasNoTrans) TA = 'T';
else if (TransA == CblasTrans) TA = 'N';
else if (TransA == CblasConjTrans)
{
TA = 'N';
if ( N > 0)
{
if ( incX > 0 )
tincX = incX;
else
tincX = -incX;
n = N*2*(tincX);
x++;
st=x+n;
i = tincX << 1;
do
{
*x = -(*x);
x+=i;
}
while (x != st);
x -= n;
}
}
else
{
cblas_xerbla(3, "cblas_ctpsv","Illegal TransA setting, %d\n", TransA);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
if (Diag == CblasUnit) DI = 'U';
else if (Diag == CblasNonUnit) DI = 'N';
else
{
cblas_xerbla(4, "cblas_ctpsv","Illegal Diag setting, %d\n", Diag);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
#ifdef F77_CHAR
F77_UL = C2F_CHAR(&UL);
F77_TA = C2F_CHAR(&TA);
F77_DI = C2F_CHAR(&DI);
#endif
ctpsv_( F77_UL, F77_TA, F77_DI, &F77_N, Ap, X,&F77_incX);
if (TransA == CblasConjTrans)
{
if (N > 0)
{
do
{
*x = -(*x);
x += i;
}
while (x != st);
}
}
}
else cblas_xerbla(1, "cblas_ctpsv", "Illegal Order setting, %d\n", order);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
/* Subroutine */
int chpgst_(integer *itype, char *uplo, integer *n, complex * ap, complex *bp, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3;
/* Local variables */
integer j, k, j1, k1, jj, kk;
complex ct;
real ajj;
integer j1j1;
real akk;
integer k1k1;
real bjj, bkk;
extern /* Subroutine */
int chpr2_(char *, integer *, complex *, complex * , integer *, complex *, integer *, complex *);
extern /* Complex */
VOID cdotc_f2c_(complex *, integer *, complex *, integer *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */
int chpmv_(char *, integer *, complex *, complex * , complex *, integer *, complex *, complex *, integer *), caxpy_(integer *, complex *, complex *, integer *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *);
logical upper;
extern /* Subroutine */
int ctpsv_(char *, char *, char *, integer *, complex *, complex *, integer *), csscal_( integer *, real *, complex *, integer *), xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--bp;
--ap;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (*itype < 1 || *itype > 3)
{
*info = -1;
}
else if (! upper && ! lsame_(uplo, "L"))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CHPGST", &i__1);
return 0;
}
if (*itype == 1)
{
if (upper)
{
/* Compute inv(U**H)*A*inv(U) */
/* J1 and JJ are the indices of A(1,j) and A(j,j) */
jj = 0;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
j1 = jj + 1;
jj += j;
/* Compute the j-th column of the upper triangle of A */
i__2 = jj;
i__3 = jj;
r__1 = ap[i__3].r;
ap[i__2].r = r__1;
ap[i__2].i = 0.f; // , expr subst
i__2 = jj;
bjj = bp[i__2].r;
ctpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & ap[j1], &c__1);
i__2 = j - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
chpmv_(uplo, &i__2, &q__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ j1], &c__1);
i__2 = j - 1;
r__1 = 1.f / bjj;
csscal_(&i__2, &r__1, &ap[j1], &c__1);
i__2 = jj;
i__3 = jj;
i__4 = j - 1;
cdotc_f2c_(&q__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1);
q__2.r = ap[i__3].r - q__3.r;
q__2.i = ap[i__3].i - q__3.i; // , expr subst
q__1.r = q__2.r / bjj;
q__1.i = q__2.i / bjj; // , expr subst
ap[i__2].r = q__1.r;
ap[i__2].i = q__1.i; // , expr subst
/* L10: */
}
}
else
{
/* Compute inv(L)*A*inv(L**H) */
/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
kk = 1;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
k1k1 = kk + *n - k + 1;
/* Update the lower triangle of A(k:n,k:n) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
/* Computing 2nd power */
r__1 = bkk;
akk /= r__1 * r__1;
i__2 = kk;
ap[i__2].r = akk;
ap[i__2].i = 0.f; // , expr subst
if (k < *n)
{
i__2 = *n - k;
r__1 = 1.f / bkk;
csscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
r__1 = akk * -.5f;
ct.r = r__1;
ct.i = 0.f; // , expr subst
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ;
i__2 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
chpr2_(uplo, &i__2, &q__1, &ap[kk + 1], &c__1, &bp[kk + 1] , &c__1, &ap[k1k1]);
i__2 = *n - k;
caxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) ;
i__2 = *n - k;
ctpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], &ap[kk + 1], &c__1);
}
kk = k1k1;
/* L20: */
}
}
}
else
{
if (upper)
{
/* Compute U*A*U**H */
/* K1 and KK are the indices of A(1,k) and A(k,k) */
kk = 0;
i__1 = *n;
for (k = 1;
k <= i__1;
++k)
{
k1 = kk + 1;
kk += k;
/* Update the upper triangle of A(1:k,1:k) */
i__2 = kk;
akk = ap[i__2].r;
i__2 = kk;
bkk = bp[i__2].r;
i__2 = k - 1;
ctpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ k1], &c__1);
r__1 = akk * .5f;
ct.r = r__1;
ct.i = 0.f; // , expr subst
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
chpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & ap[1]);
i__2 = k - 1;
caxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
i__2 = k - 1;
csscal_(&i__2, &bkk, &ap[k1], &c__1);
i__2 = kk;
/* Computing 2nd power */
r__2 = bkk;
r__1 = akk * (r__2 * r__2);
ap[i__2].r = r__1;
ap[i__2].i = 0.f; // , expr subst
/* L30: */
}
}
else
{
/* Compute L**H *A*L */
/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
jj = 1;
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
j1j1 = jj + *n - j + 1;
/* Compute the j-th column of the lower triangle of A */
i__2 = jj;
ajj = ap[i__2].r;
i__2 = jj;
bjj = bp[i__2].r;
i__2 = jj;
r__1 = ajj * bjj;
i__3 = *n - j;
cdotc_f2c_(&q__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1);
q__1.r = r__1 + q__2.r;
q__1.i = q__2.i; // , expr subst
ap[i__2].r = q__1.r;
ap[i__2].i = q__1.i; // , expr subst
i__2 = *n - j;
csscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
i__2 = *n - j;
chpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & c_b1, &ap[jj + 1], &c__1);
i__2 = *n - j + 1;
ctpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] , &ap[jj], &c__1);
jj = j1j1;
/* L40: */
}
}
}
return 0;
/* End of CHPGST */
}