int
f2c_cgeru(integer* M, integer* N,
complex* alpha,
complex* X, integer* incX,
complex* Y, integer* incY,
complex* A, integer* lda)
{
cgeru_(M, N, alpha,
X, incX, Y, incY, A, lda);
return 0;
}
/* Subroutine */ int clarz_(char *side, integer *m, integer *n, integer *l,
complex *v, integer *incv, complex *tau, complex *c__, integer *ldc,
complex *work)
{
/* System generated locals */
integer c_dim1, c_offset;
complex q__1;
/* Local variables */
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cgemv_(char *, integer *, integer *, complex *, complex *,
integer *, complex *, integer *, complex *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
ccopy_(integer *, complex *, integer *, complex *, integer *),
caxpy_(integer *, complex *, complex *, integer *, complex *,
integer *), clacgv_(integer *, complex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLARZ applies a complex elementary reflector H to a complex */
/* M-by-N matrix C, from either the left or the right. H is represented */
/* in the form */
/* H = I - tau * v * v' */
/* where tau is a complex scalar and v is a complex vector. */
/* If tau = 0, then H is taken to be the unit matrix. */
/* To apply H' (the conjugate transpose of H), supply conjg(tau) instead */
/* tau. */
/* H is a product of k elementary reflectors as returned by CTZRZF. */
/* Arguments */
/* ========= */
/* SIDE (input) CHARACTER*1 */
/* = 'L': form H * C */
/* = 'R': form C * H */
/* M (input) INTEGER */
/* The number of rows of the matrix C. */
/* N (input) INTEGER */
/* The number of columns of the matrix C. */
/* L (input) INTEGER */
/* The number of entries of the vector V containing */
/* the meaningful part of the Householder vectors. */
/* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */
/* V (input) COMPLEX array, dimension (1+(L-1)*abs(INCV)) */
/* The vector v in the representation of H as returned by */
/* CTZRZF. V is not used if TAU = 0. */
/* INCV (input) INTEGER */
/* The increment between elements of v. INCV <> 0. */
/* TAU (input) COMPLEX */
/* The value tau in the representation of H. */
/* C (input/output) COMPLEX array, dimension (LDC,N) */
/* On entry, the M-by-N matrix C. */
/* On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
/* or C * H if SIDE = 'R'. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* WORK (workspace) COMPLEX array, dimension */
/* (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
if (lsame_(side, "L")) {
/* Form H * C */
if (tau->r != 0.f || tau->i != 0.f) {
/* w( 1:n ) = conjg( C( 1, 1:n ) ) */
ccopy_(n, &c__[c_offset], ldc, &work[1], &c__1);
clacgv_(n, &work[1], &c__1);
/* w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) ) */
cgemv_("Conjugate transpose", l, n, &c_b1, &c__[*m - *l + 1 +
c_dim1], ldc, &v[1], incv, &c_b1, &work[1], &c__1);
clacgv_(n, &work[1], &c__1);
/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */
q__1.r = -tau->r, q__1.i = -tau->i;
caxpy_(n, &q__1, &work[1], &c__1, &c__[c_offset], ldc);
/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */
/* tau * v( 1:l ) * conjg( w( 1:n )' ) */
q__1.r = -tau->r, q__1.i = -tau->i;
cgeru_(l, n, &q__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l +
1 + c_dim1], ldc);
}
} else {
/* Form C * H */
if (tau->r != 0.f || tau->i != 0.f) {
/* w( 1:m ) = C( 1:m, 1 ) */
ccopy_(m, &c__[c_offset], &c__1, &work[1], &c__1);
/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */
cgemv_("No transpose", m, l, &c_b1, &c__[(*n - *l + 1) * c_dim1 +
1], ldc, &v[1], incv, &c_b1, &work[1], &c__1);
/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */
q__1.r = -tau->r, q__1.i = -tau->i;
caxpy_(m, &q__1, &work[1], &c__1, &c__[c_offset], &c__1);
/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */
/* tau * w( 1:m ) * v( 1:l )' */
q__1.r = -tau->r, q__1.i = -tau->i;
cgerc_(m, l, &q__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l +
1) * c_dim1 + 1], ldc);
}
}
return 0;
/* End of CLARZ */
} /* clarz_ */
/* Subroutine */ int csytrs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *
info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
integer j, k;
complex ak, bk;
integer kp;
complex akm1, bkm1, akm1k;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
complex denom;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CSYTRS solves a system of linear equations A*X = B with a complex */
/* symmetric matrix A using the factorization A = U*D*U**T or */
/* A = L*D*L**T computed by CSYTRF. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the details of the factorization are stored */
/* as an upper or lower triangular matrix. */
/* = 'U': Upper triangular, form is A = U*D*U**T; */
/* = 'L': Lower triangular, form is A = L*D*L**T. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by CSYTRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by CSYTRF. */
/* 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 */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
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 (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CSYTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'. */
/* First solve U*D*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
--k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K-1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k - 1) {
cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in columns K-1 and K of A. */
i__1 = k - 2;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
i__1 = k - 2;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k
- 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = k - 1 + k * a_dim1;
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &a[k + k * a_dim1], &akm1k);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
c_div(&q__1, &b[k - 1 + j * b_dim1], &akm1k);
bkm1.r = q__1.r, bkm1.i = q__1.i;
c_div(&q__1, &b[k + j * b_dim1], &akm1k);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = k - 1 + j * b_dim1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = k + j * b_dim1;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(U'(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[k *
a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb)
;
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
++k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(U'(K+1)), where U(K+1) is the transformation */
/* stored in columns K and K+1 of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[k *
a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb)
;
i__1 = k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[(k
+ 1) * a_dim1 + 1], &c__1, &c_b1, &b[k + 1 + b_dim1], ldb);
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'. */
/* First solve L*D*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k + 1 + k * a_dim1], &c__1, &b[
k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
++k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + k * a_dim1], &c__1, &b[
k + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + (k + 1) * a_dim1], &
c__1, &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1],
ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = k + 1 + k * a_dim1;
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
c_div(&q__1, &a[k + k * a_dim1], &akm1k);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i - 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
c_div(&q__1, &b[k + j * b_dim1], &akm1k);
bkm1.r = q__1.r, bkm1.i = q__1.i;
c_div(&q__1, &b[k + 1 + j * b_dim1], &akm1k);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = k + j * b_dim1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = k + 1 + j * b_dim1;
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L70: */
}
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Multiply by inv(L'(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
} else {
/* 2 x 2 diagonal block */
/* Multiply by inv(L'(K-1)), where L(K-1) is the transformation */
/* stored in columns K-1 and K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1],
ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b1, &b[k
- 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of CSYTRS */
} /* csytrs_ */
void
cgeru(int m, int n, complex *alpha, complex *x, int incx, complex *y, int incy, complex *a, int lda)
{
cgeru_( &m, &n, alpha, x, &incx, y, &incy, a, &lda);
}
/* Subroutine */ int chetrs_(char *uplo, integer *n, integer *nrhs, complex *
a, integer *lda, integer *ipiv, 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
=======
CHETRS solves a system of linear equations A*X = B with a complex
Hermitian matrix A using the factorization A = U*D*U**H or
A = L*D*L**H computed by CHETRF.
Arguments
=========
UPLO (input) CHARACTER*1
Specifies whether the details of the factorization are stored
as an upper or lower triangular matrix.
= 'U': Upper triangular, form is A = U*D*U**H;
= 'L': Lower triangular, form is A = L*D*L**H.
N (input) INTEGER
The order of the matrix A. N >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The block diagonal matrix D and the multipliers used to
obtain the factor U or L as computed by CHETRF.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
IPIV (input) INTEGER array, dimension (N)
Details of the interchanges and the block structure of D
as determined by CHETRF.
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
=====================================================================
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *), r_cnjg(complex *, complex *);
/* Local variables */
static complex akm1k;
static integer j, k;
static real s;
extern logical lsame_(char *, char *);
static complex denom;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *);
static logical upper;
static complex ak, bk;
static integer kp;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
csscal_(integer *, real *, complex *, integer *), xerbla_(char *,
integer *);
static complex akm1, bkm1;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
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 (*lda < max(1,*n)) {
*info = -5;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHETRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (upper) {
/* Solve A*X = B, where A = U*D*U'.
First solve U*D*X = B, overwriting B with X.
K is the main loop index, decreasing from N to 1 in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation
stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k), &c__1, &b_ref(k, 1), ldb,
&b_ref(1, 1), ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = a_subscr(k, k);
s = 1.f / a[i__1].r;
csscal_(nrhs, &s, &b_ref(k, 1), ldb);
--k;
} else {
/* 2 x 2 diagonal block
Interchange rows K-1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k - 1) {
cswap_(nrhs, &b_ref(k - 1, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation
stored in columns K-1 and K of A. */
i__1 = k - 2;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k), &c__1, &b_ref(k, 1), ldb,
&b_ref(1, 1), ldb);
i__1 = k - 2;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(1, k - 1), &c__1, &b_ref(k - 1,
1), ldb, &b_ref(1, 1), ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = a_subscr(k - 1, k);
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
c_div(&q__1, &a_ref(k - 1, k - 1), &akm1k);
akm1.r = q__1.r, akm1.i = q__1.i;
r_cnjg(&q__2, &akm1k);
c_div(&q__1, &a_ref(k, k), &q__2);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i + 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
c_div(&q__1, &b_ref(k - 1, j), &akm1k);
bkm1.r = q__1.r, bkm1.i = q__1.i;
r_cnjg(&q__2, &akm1k);
c_div(&q__1, &b_ref(k, j), &q__2);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = b_subscr(k - 1, j);
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(k, j);
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
k += -2;
}
goto L10;
L30:
/* Next solve U'*X = B, overwriting B with X.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L40:
/* If K > N, exit from loop. */
if (k > *n) {
goto L50;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Multiply by inv(U'(K)), where U(K) is the transformation
stored in column K of A. */
if (k > 1) {
clacgv_(nrhs, &b_ref(k, 1), ldb);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
, ldb, &a_ref(1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
clacgv_(nrhs, &b_ref(k, 1), ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
++k;
} else {
/* 2 x 2 diagonal block
Multiply by inv(U'(K+1)), where U(K+1) is the transformation
stored in columns K and K+1 of A. */
if (k > 1) {
clacgv_(nrhs, &b_ref(k, 1), ldb);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
, ldb, &a_ref(1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
clacgv_(nrhs, &b_ref(k, 1), ldb);
clacgv_(nrhs, &b_ref(k + 1, 1), ldb);
i__1 = k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b[b_offset]
, ldb, &a_ref(1, k + 1), &c__1, &c_b1, &b_ref(k + 1,
1), ldb);
clacgv_(nrhs, &b_ref(k + 1, 1), ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
k += 2;
}
goto L40;
L50:
;
} else {
/* Solve A*X = B, where A = L*D*L'.
First solve L*D*X = B, overwriting B with X.
K is the main loop index, increasing from 1 to N in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L60:
/* If K > N, exit from loop. */
if (k > *n) {
goto L80;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation
stored in column K of A. */
if (k < *n) {
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 1, k), &c__1, &b_ref(k,
1), ldb, &b_ref(k + 1, 1), ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = a_subscr(k, k);
s = 1.f / a[i__1].r;
csscal_(nrhs, &s, &b_ref(k, 1), ldb);
++k;
} else {
/* 2 x 2 diagonal block
Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
cswap_(nrhs, &b_ref(k + 1, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation
stored in columns K and K+1 of A. */
if (k < *n - 1) {
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 2, k), &c__1, &b_ref(k,
1), ldb, &b_ref(k + 2, 1), ldb);
i__1 = *n - k - 1;
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&i__1, nrhs, &q__1, &a_ref(k + 2, k + 1), &c__1, &
b_ref(k + 1, 1), ldb, &b_ref(k + 2, 1), ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = a_subscr(k + 1, k);
akm1k.r = a[i__1].r, akm1k.i = a[i__1].i;
r_cnjg(&q__2, &akm1k);
c_div(&q__1, &a_ref(k, k), &q__2);
akm1.r = q__1.r, akm1.i = q__1.i;
c_div(&q__1, &a_ref(k + 1, k + 1), &akm1k);
ak.r = q__1.r, ak.i = q__1.i;
q__2.r = akm1.r * ak.r - akm1.i * ak.i, q__2.i = akm1.r * ak.i +
akm1.i * ak.r;
q__1.r = q__2.r - 1.f, q__1.i = q__2.i + 0.f;
denom.r = q__1.r, denom.i = q__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
r_cnjg(&q__2, &akm1k);
c_div(&q__1, &b_ref(k, j), &q__2);
bkm1.r = q__1.r, bkm1.i = q__1.i;
c_div(&q__1, &b_ref(k + 1, j), &akm1k);
bk.r = q__1.r, bk.i = q__1.i;
i__2 = b_subscr(k, j);
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i, q__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
q__2.r = q__3.r - bk.r, q__2.i = q__3.i - bk.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = b_subscr(k + 1, j);
q__3.r = akm1.r * bk.r - akm1.i * bk.i, q__3.i = akm1.r *
bk.i + akm1.i * bk.r;
q__2.r = q__3.r - bkm1.r, q__2.i = q__3.i - bkm1.i;
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L70: */
}
k += 2;
}
goto L60;
L80:
/* Next solve L'*X = B, overwriting B with X.
K is the main loop index, decreasing from N to 1 in steps of
1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block
Multiply by inv(L'(K)), where L(K) is the transformation
stored in column K of A. */
if (k < *n) {
clacgv_(nrhs, &b_ref(k, 1), ldb);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b_ref(k +
1, 1), ldb, &a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k,
1), ldb);
clacgv_(nrhs, &b_ref(k, 1), ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
--k;
} else {
/* 2 x 2 diagonal block
Multiply by inv(L'(K-1)), where L(K-1) is the transformation
stored in columns K-1 and K of A. */
if (k < *n) {
clacgv_(nrhs, &b_ref(k, 1), ldb);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b_ref(k +
1, 1), ldb, &a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k,
1), ldb);
clacgv_(nrhs, &b_ref(k, 1), ldb);
clacgv_(nrhs, &b_ref(k - 1, 1), ldb);
i__1 = *n - k;
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &i__1, nrhs, &q__1, &b_ref(k +
1, 1), ldb, &a_ref(k + 1, k - 1), &c__1, &c_b1, &
b_ref(k - 1, 1), ldb);
clacgv_(nrhs, &b_ref(k - 1, 1), ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
cswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of CHETRS */
} /* chetrs_ */
/* Subroutine */ int cgetf2_(integer *m, integer *n, complex *a, integer *lda,
integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
integer i__, j, jp;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgeru_(integer *, integer *, complex *, complex *,
integer *, complex *, integer *, complex *, integer *);
real sfmin;
extern /* Subroutine */ int cswap_(integer *, complex *, integer *,
complex *, integer *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGETF2 computes an LU factorization of a general m-by-n matrix A */
/* using partial pivoting with row interchanges. */
/* The factorization has the form */
/* A = P * L * U */
/* where P is a permutation matrix, L is lower triangular with unit */
/* diagonal elements (lower trapezoidal if m > n), and U is upper */
/* triangular (upper trapezoidal if m < n). */
/* This is the right-looking Level 2 BLAS version of the algorithm. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the m by n matrix to be factored. */
/* On exit, the factors L and U from the factorization */
/* A = P*L*U; the unit diagonal elements of L are not stored. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* > 0: if INFO = k, U(k,k) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGETF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = slamch_("S");
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Find pivot and test for singularity. */
i__2 = *m - j + 1;
jp = j - 1 + icamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
i__2 = jp + j * a_dim1;
if (a[i__2].r != 0.f || a[i__2].i != 0.f) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
cswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
if (c_abs(&a[j + j * a_dim1]) >= sfmin) {
i__2 = *m - j;
c_div(&q__1, &c_b1, &a[j + j * a_dim1]);
cscal_(&i__2, &q__1, &a[j + 1 + j * a_dim1], &c__1);
} else {
i__2 = *m - j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = j + i__ + j * a_dim1;
c_div(&q__1, &a[j + i__ + j * a_dim1], &a[j + j *
a_dim1]);
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L20: */
}
}
}
} else if (*info == 0) {
*info = j;
}
if (j < min(*m,*n)) {
/* Update trailing submatrix. */
i__2 = *m - j;
i__3 = *n - j;
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&i__2, &i__3, &q__1, &a[j + 1 + j * a_dim1], &c__1, &a[j +
(j + 1) * a_dim1], lda, &a[j + 1 + (j + 1) * a_dim1], lda)
;
}
/* L10: */
}
return 0;
/* End of CGETF2 */
} /* cgetf2_ */
/* Subroutine */
int cgbtf2_(integer *m, integer *n, integer *kl, integer *ku, complex *ab, integer *ldab, integer *ipiv, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
integer i__, j, km, jp, ju, kv;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *), cgeru_(integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, integer *), cswap_( integer *, complex *, integer *, complex *, integer *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *);
/* -- LAPACK computational routine (version 3.4.2) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* September 2012 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* KV is the number of superdiagonals in the factor U, allowing for */
/* fill-in. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0)
{
*info = -1;
}
else if (*n < 0)
{
*info = -2;
}
else if (*kl < 0)
{
*info = -3;
}
else if (*ku < 0)
{
*info = -4;
}
else if (*ldab < *kl + kv + 1)
{
*info = -6;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CGBTF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0)
{
return 0;
}
/* Gaussian elimination with partial pivoting */
/* Set fill-in elements in columns KU+2 to KV to zero. */
i__1 = min(kv,*n);
for (j = *ku + 2;
j <= i__1;
++j)
{
i__2 = *kl;
for (i__ = kv - j + 2;
i__ <= i__2;
++i__)
{
i__3 = i__ + j * ab_dim1;
ab[i__3].r = 0.f;
ab[i__3].i = 0.f; // , expr subst
/* L10: */
}
/* L20: */
}
/* JU is the index of the last column affected by the current stage */
/* of the factorization. */
ju = 1;
i__1 = min(*m,*n);
for (j = 1;
j <= i__1;
++j)
{
/* Set fill-in elements in column J+KV to zero. */
if (j + kv <= *n)
{
i__2 = *kl;
for (i__ = 1;
i__ <= i__2;
++i__)
{
i__3 = i__ + (j + kv) * ab_dim1;
ab[i__3].r = 0.f;
ab[i__3].i = 0.f; // , expr subst
/* L30: */
}
}
/* Find pivot and test for singularity. KM is the number of */
/* subdiagonal elements in the current column. */
/* Computing MIN */
i__2 = *kl;
i__3 = *m - j; // , expr subst
km = min(i__2,i__3);
i__2 = km + 1;
jp = icamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1);
ipiv[j] = jp + j - 1;
i__2 = kv + jp + j * ab_dim1;
if (ab[i__2].r != 0.f || ab[i__2].i != 0.f)
{
/* Computing MAX */
/* Computing MIN */
i__4 = j + *ku + jp - 1;
i__2 = ju;
i__3 = min(i__4,*n); // , expr subst
ju = max(i__2,i__3);
/* Apply interchange to columns J to JU. */
if (jp != 1)
{
i__2 = ju - j + 1;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
cswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 + j * ab_dim1], &i__4);
}
if (km > 0)
{
/* Compute multipliers. */
c_div(&q__1, &c_b1, &ab[kv + 1 + j * ab_dim1]);
cscal_(&km, &q__1, &ab[kv + 2 + j * ab_dim1], &c__1);
/* Update trailing submatrix within the band. */
if (ju > j)
{
i__2 = ju - j;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
i__3 = *ldab - 1;
i__4 = *ldab - 1;
cgeru_(&km, &i__2, &q__1, &ab[kv + 2 + j * ab_dim1], & c__1, &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv + 1 + (j + 1) * ab_dim1], &i__4);
}
}
}
else
{
/* If pivot is zero, set INFO to the index of the pivot */
/* unless a zero pivot has already been found. */
if (*info == 0)
{
*info = j;
}
}
/* L40: */
}
return 0;
/* End of CGBTF2 */
}
/* Subroutine */ int cgbtrs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, complex *ab, integer *ldab, integer *ipiv, complex
*b, integer *ldb, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
complex q__1;
/* Local variables */
integer i__, j, l, kd, lm;
logical lnoti;
logical notran;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CGBTRS solves a system of linear equations */
/* A * X = B, A**T * X = B, or A**H * X = B */
/* with a general band matrix A using the LU factorization computed */
/* by CGBTRF. */
/* Arguments */
/* ========= */
/* 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) */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrix B. NRHS >= 0. */
/* AB (input) COMPLEX array, dimension (LDAB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by CGBTRF. U is stored as an upper triangular band */
/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */
/* the multipliers used during the factorization are stored in */
/* rows KL+KU+2 to 2*KL+KU+1. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices; for 1 <= i <= N, row i of the matrix was */
/* interchanged with row IPIV(i). */
/* 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 */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldab < (*kl << 1) + *ku + 1) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
kd = *ku + *kl + 1;
lnoti = *kl > 0;
if (notran) {
/* Solve A*X = B. */
/* Solve L*X = B, overwriting B with X. */
/* L is represented as a product of permutations and unit lower */
/* where each transformation L(i) is a rank-one modification of */
/* the identity matrix. */
if (lnoti) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kl, i__3 = *n - j;
lm = min(i__2,i__3);
l = ipiv[j];
if (l != j) {
cswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
}
q__1.r = -1.f, q__1.i = -0.f;
cgeru_(&lm, nrhs, &q__1, &ab[kd + 1 + j * ab_dim1], &c__1, &b[
j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb);
}
}
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U*X = B, overwriting B with X. */
i__2 = *kl + *ku;
ctbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[
ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1);
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * X = B. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U**T * X = B, overwriting B with X. */
i__2 = *kl + *ku;
ctbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset],
ldab, &b[i__ * b_dim1 + 1], &c__1);
}
/* Solve L**T * X = B, overwriting B with X. */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Transpose", &lm, nrhs, &q__1, &b[j + 1 + b_dim1], ldb,
&ab[kd + 1 + j * ab_dim1], &c__1, &c_b1, &b[j +
b_dim1], ldb);
l = ipiv[j];
if (l != j) {
cswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
}
}
}
} else {
/* Solve A**H * X = B. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U**H * X = B, overwriting B with X. */
i__2 = *kl + *ku;
ctbsv_("Upper", "Conjugate transpose", "Non-unit", n, &i__2, &ab[
ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1);
}
/* Solve L**H * X = B, overwriting B with X. */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
clacgv_(nrhs, &b[j + b_dim1], ldb);
q__1.r = -1.f, q__1.i = -0.f;
cgemv_("Conjugate transpose", &lm, nrhs, &q__1, &b[j + 1 +
b_dim1], ldb, &ab[kd + 1 + j * ab_dim1], &c__1, &c_b1,
&b[j + b_dim1], ldb);
clacgv_(nrhs, &b[j + b_dim1], ldb);
l = ipiv[j];
if (l != j) {
cswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
}
}
}
}
return 0;
/* End of CGBTRS */
} /* cgbtrs_ */
/* Subroutine */ int clatzm_(char *side, integer *m, integer *n, complex *v,
integer *incv, complex *tau, complex *c1, complex *c2, integer *ldc,
complex *work)
{
/* -- 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
=======
This routine is deprecated and has been replaced by routine CUNMRZ.
CLATZM applies a Householder matrix generated by CTZRQF to a matrix.
Let P = I - tau*u*u', u = ( 1 ),
( v )
where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if
SIDE = 'R'.
If SIDE equals 'L', let
C = [ C1 ] 1
[ C2 ] m-1
n
Then C is overwritten by P*C.
If SIDE equals 'R', let
C = [ C1, C2 ] m
1 n-1
Then C is overwritten by C*P.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': form P * C
= 'R': form C * P
M (input) INTEGER
The number of rows of the matrix C.
N (input) INTEGER
The number of columns of the matrix C.
V (input) COMPLEX array, dimension
(1 + (M-1)*abs(INCV)) if SIDE = 'L'
(1 + (N-1)*abs(INCV)) if SIDE = 'R'
The vector v in the representation of P. V is not used
if TAU = 0.
INCV (input) INTEGER
The increment between elements of v. INCV <> 0
TAU (input) COMPLEX
The value tau in the representation of P.
C1 (input/output) COMPLEX array, dimension
(LDC,N) if SIDE = 'L'
(M,1) if SIDE = 'R'
On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1
if SIDE = 'R'.
On exit, the first row of P*C if SIDE = 'L', or the first
column of C*P if SIDE = 'R'.
C2 (input/output) COMPLEX array, dimension
(LDC, N) if SIDE = 'L'
(LDC, N-1) if SIDE = 'R'
On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the
m x (n - 1) matrix C2 if SIDE = 'R'.
On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P
if SIDE = 'R'.
LDC (input) INTEGER
The leading dimension of the arrays C1 and C2.
LDC >= max(1,M).
WORK (workspace) COMPLEX array, dimension
(N) if SIDE = 'L'
(M) if SIDE = 'R'
=====================================================================
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
complex q__1;
/* Local variables */
extern /* Subroutine */ int cgerc_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cgemv_(char *, integer *, integer *, complex *, complex *,
integer *, complex *, integer *, complex *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
ccopy_(integer *, complex *, integer *, complex *, integer *),
caxpy_(integer *, complex *, complex *, integer *, complex *,
integer *), clacgv_(integer *, complex *, integer *);
--v;
c2_dim1 = *ldc;
c2_offset = 1 + c2_dim1 * 1;
c2 -= c2_offset;
c1_dim1 = *ldc;
c1_offset = 1 + c1_dim1 * 1;
c1 -= c1_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0 || tau->r == 0.f && tau->i == 0.f) {
return 0;
}
if (lsame_(side, "L")) {
/* w := conjg( C1 + v' * C2 ) */
ccopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
clacgv_(n, &work[1], &c__1);
i__1 = *m - 1;
cgemv_("Conjugate transpose", &i__1, n, &c_b1, &c2[c2_offset], ldc, &
v[1], incv, &c_b1, &work[1], &c__1);
/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
[ C2 ] [ C2 ] [ v ] */
clacgv_(n, &work[1], &c__1);
q__1.r = -tau->r, q__1.i = -tau->i;
caxpy_(n, &q__1, &work[1], &c__1, &c1[c1_offset], ldc);
i__1 = *m - 1;
q__1.r = -tau->r, q__1.i = -tau->i;
cgeru_(&i__1, n, &q__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset],
ldc);
} else if (lsame_(side, "R")) {
/* w := C1 + C2 * v */
ccopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
i__1 = *n - 1;
cgemv_("No transpose", m, &i__1, &c_b1, &c2[c2_offset], ldc, &v[1],
incv, &c_b1, &work[1], &c__1);
/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */
q__1.r = -tau->r, q__1.i = -tau->i;
caxpy_(m, &q__1, &work[1], &c__1, &c1[c1_offset], &c__1);
i__1 = *n - 1;
q__1.r = -tau->r, q__1.i = -tau->i;
cgerc_(m, &i__1, &q__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset],
ldc);
}
return 0;
/* End of CLATZM */
} /* clatzm_ */
/* Subroutine */
int csytrs_rook_(char *uplo, integer *n, integer *nrhs, complex *a, integer *lda, integer *ipiv, complex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
complex q__1, q__2, q__3;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
integer j, k;
complex ak, bk;
integer kp;
complex akm1, bkm1, akm1k;
extern /* Subroutine */
int cscal_(integer *, complex *, complex *, integer *);
extern logical lsame_(char *, char *);
complex denom;
extern /* Subroutine */
int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), cgeru_(integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, integer *), cswap_(integer *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */
int 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 Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
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 (*lda < max(1,*n))
{
*info = -5;
}
else if (*ldb < max(1,*n))
{
*info = -8;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CSYTRS_ROOK", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0)
{
return 0;
}
if (upper)
{
/* Solve A*X = B, where A = U*D*U**T. */
/* First solve U*D*X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L10: /* If K < 1, exit from loop. */
if (k < 1)
{
goto L30;
}
if (ipiv[k] > 0)
{
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k)
{
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in column K of A. */
i__1 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
--k;
}
else
{
/* 2 x 2 diagonal block */
/* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) */
kp = -ipiv[k];
if (kp != k)
{
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kp = -ipiv[k - 1];
if (kp != k - 1)
{
cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(U(K)), where U(K) is the transformation */
/* stored in columns K-1 and K of A. */
if (k > 2)
{
i__1 = k - 2;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgeru_(&i__1, nrhs, &q__1, &a[k * a_dim1 + 1], &c__1, &b[k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
i__1 = k - 2;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgeru_(&i__1, nrhs, &q__1, &a[(k - 1) * a_dim1 + 1], &c__1, & b[k - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = k - 1 + k * a_dim1;
akm1k.r = a[i__1].r;
akm1k.i = a[i__1].i; // , expr subst
c_div(&q__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k);
akm1.r = q__1.r;
akm1.i = q__1.i; // , expr subst
c_div(&q__1, &a[k + k * a_dim1], &akm1k);
ak.r = q__1.r;
ak.i = q__1.i; // , expr subst
q__2.r = akm1.r * ak.r - akm1.i * ak.i;
q__2.i = akm1.r * ak.i + akm1.i * ak.r; // , expr subst
q__1.r = q__2.r - 1.f;
q__1.i = q__2.i - 0.f; // , expr subst
denom.r = q__1.r;
denom.i = q__1.i; // , expr subst
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
c_div(&q__1, &b[k - 1 + j * b_dim1], &akm1k);
bkm1.r = q__1.r;
bkm1.i = q__1.i; // , expr subst
c_div(&q__1, &b[k + j * b_dim1], &akm1k);
bk.r = q__1.r;
bk.i = q__1.i; // , expr subst
i__2 = k - 1 + j * b_dim1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i;
q__3.i = ak.r * bkm1.i + ak.i * bkm1.r; // , expr subst
q__2.r = q__3.r - bk.r;
q__2.i = q__3.i - bk.i; // , expr subst
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r;
b[i__2].i = q__1.i; // , expr subst
i__2 = k + j * b_dim1;
q__3.r = akm1.r * bk.r - akm1.i * bk.i;
q__3.i = akm1.r * bk.i + akm1.i * bk.r; // , expr subst
q__2.r = q__3.r - bkm1.r;
q__2.i = q__3.i - bkm1.i; // , expr subst
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r;
b[i__2].i = q__1.i; // , expr subst
/* L20: */
}
k += -2;
}
goto L10;
L30: /* Next solve U**T *X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L40: /* If K > N, exit from loop. */
if (k > *n)
{
goto L50;
}
if (ipiv[k] > 0)
{
/* 1 x 1 diagonal block */
/* Multiply by inv(U**T(K)), where U(K) is the transformation */
/* stored in column K of A. */
if (k > 1)
{
i__1 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[ k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k)
{
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
++k;
}
else
{
/* 2 x 2 diagonal block */
/* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation */
/* stored in columns K and K+1 of A. */
if (k > 1)
{
i__1 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[ k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb);
i__1 = k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[b_offset], ldb, &a[ (k + 1) * a_dim1 + 1], &c__1, &c_b1, &b[k + 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1). */
kp = -ipiv[k];
if (kp != k)
{
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kp = -ipiv[k + 1];
if (kp != k + 1)
{
cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += 2;
}
goto L40;
L50:
;
}
else
{
/* Solve A*X = B, where A = L*D*L**T. */
/* First solve L*D*X = B, overwriting B with X. */
/* K is the main loop index, increasing from 1 to N in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = 1;
L60: /* If K > N, exit from loop. */
if (k > *n)
{
goto L80;
}
if (ipiv[k] > 0)
{
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k)
{
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n)
{
i__1 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgeru_(&i__1, nrhs, &q__1, &a[k + 1 + k * a_dim1], &c__1, &b[ k + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
c_div(&q__1, &c_b1, &a[k + k * a_dim1]);
cscal_(nrhs, &q__1, &b[k + b_dim1], ldb);
++k;
}
else
{
/* 2 x 2 diagonal block */
/* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1) */
kp = -ipiv[k];
if (kp != k)
{
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kp = -ipiv[k + 1];
if (kp != k + 1)
{
cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
/* Multiply by inv(L(K)), where L(K) is the transformation */
/* stored in columns K and K+1 of A. */
if (k < *n - 1)
{
i__1 = *n - k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + k * a_dim1], &c__1, &b[ k + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
i__1 = *n - k - 1;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgeru_(&i__1, nrhs, &q__1, &a[k + 2 + (k + 1) * a_dim1], & c__1, &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = k + 1 + k * a_dim1;
akm1k.r = a[i__1].r;
akm1k.i = a[i__1].i; // , expr subst
c_div(&q__1, &a[k + k * a_dim1], &akm1k);
akm1.r = q__1.r;
akm1.i = q__1.i; // , expr subst
c_div(&q__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k);
ak.r = q__1.r;
ak.i = q__1.i; // , expr subst
q__2.r = akm1.r * ak.r - akm1.i * ak.i;
q__2.i = akm1.r * ak.i + akm1.i * ak.r; // , expr subst
q__1.r = q__2.r - 1.f;
q__1.i = q__2.i - 0.f; // , expr subst
denom.r = q__1.r;
denom.i = q__1.i; // , expr subst
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
c_div(&q__1, &b[k + j * b_dim1], &akm1k);
bkm1.r = q__1.r;
bkm1.i = q__1.i; // , expr subst
c_div(&q__1, &b[k + 1 + j * b_dim1], &akm1k);
bk.r = q__1.r;
bk.i = q__1.i; // , expr subst
i__2 = k + j * b_dim1;
q__3.r = ak.r * bkm1.r - ak.i * bkm1.i;
q__3.i = ak.r * bkm1.i + ak.i * bkm1.r; // , expr subst
q__2.r = q__3.r - bk.r;
q__2.i = q__3.i - bk.i; // , expr subst
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r;
b[i__2].i = q__1.i; // , expr subst
i__2 = k + 1 + j * b_dim1;
q__3.r = akm1.r * bk.r - akm1.i * bk.i;
q__3.i = akm1.r * bk.i + akm1.i * bk.r; // , expr subst
q__2.r = q__3.r - bkm1.r;
q__2.i = q__3.i - bkm1.i; // , expr subst
c_div(&q__1, &q__2, &denom);
b[i__2].r = q__1.r;
b[i__2].i = q__1.i; // , expr subst
/* L70: */
}
k += 2;
}
goto L60;
L80: /* Next solve L**T *X = B, overwriting B with X. */
/* K is the main loop index, decreasing from N to 1 in steps of */
/* 1 or 2, depending on the size of the diagonal blocks. */
k = *n;
L90: /* If K < 1, exit from loop. */
if (k < 1)
{
goto L100;
}
if (ipiv[k] > 0)
{
/* 1 x 1 diagonal block */
/* Multiply by inv(L**T(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n)
{
i__1 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k)
{
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
}
else
{
/* 2 x 2 diagonal block */
/* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation */
/* stored in columns K-1 and K of A. */
if (k < *n)
{
i__1 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, &b[k + b_dim1], ldb);
i__1 = *n - k;
q__1.r = -1.f;
q__1.i = -0.f; // , expr subst
cgemv_("Transpose", &i__1, nrhs, &q__1, &b[k + 1 + b_dim1], ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b1, &b[k - 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) */
kp = -ipiv[k];
if (kp != k)
{
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kp = -ipiv[k - 1];
if (kp != k - 1)
{
cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of CSYTRS_ROOK */
}
/* Subroutine */ int cgetc2_(integer *n, complex *a, integer *lda, integer *
ipiv, integer *jpiv, 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
June 30, 1999
Purpose
=======
CGETC2 computes an LU factorization, using complete pivoting, of the
n-by-n matrix A. The factorization has the form A = P * L * U * Q,
where P and Q are permutation matrices, L is lower triangular with
unit diagonal elements and U is upper triangular.
This is a level 1 BLAS version of the algorithm.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) COMPLEX array, dimension (LDA, N)
On entry, the n-by-n matrix to be factored.
On exit, the factors L and U from the factorization
A = P*L*U*Q; the unit diagonal elements of L are not stored.
If U(k, k) appears to be less than SMIN, U(k, k) is given the
value of SMIN, giving a nonsingular perturbed system.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1, N).
IPIV (output) INTEGER array, dimension (N).
The pivot indices; for 1 <= i <= N, row i of the
matrix has been interchanged with row IPIV(i).
JPIV (output) INTEGER array, dimension (N).
The pivot indices; for 1 <= j <= N, column j of the
matrix has been interchanged with column JPIV(j).
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = k, U(k, k) is likely to produce overflow if
one tries to solve for x in Ax = b. So U is perturbed
to avoid the overflow.
Further Details
===============
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
=====================================================================
Set constants to control overflow
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static complex c_b10 = {-1.f,0.f};
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
real r__1;
complex q__1;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
static real smin, xmax;
static integer i__, j;
extern /* Subroutine */ int cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *),
slabad_(real *, real *);
static integer ip, jp;
extern doublereal slamch_(char *);
static real bignum, smlnum, eps;
static integer ipv, jpv;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--ipiv;
--jpiv;
/* Function Body */
*info = 0;
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Factorize A using complete pivoting.
Set pivots less than SMIN to SMIN */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Find max element in matrix A */
xmax = 0.f;
i__2 = *n;
for (ip = i__; ip <= i__2; ++ip) {
i__3 = *n;
for (jp = i__; jp <= i__3; ++jp) {
if (c_abs(&a_ref(ip, jp)) >= xmax) {
xmax = c_abs(&a_ref(ip, jp));
ipv = ip;
jpv = jp;
}
/* L10: */
}
/* L20: */
}
if (i__ == 1) {
/* Computing MAX */
r__1 = eps * xmax;
smin = dmax(r__1,smlnum);
}
/* Swap rows */
if (ipv != i__) {
cswap_(n, &a_ref(ipv, 1), lda, &a_ref(i__, 1), lda);
}
ipiv[i__] = ipv;
/* Swap columns */
if (jpv != i__) {
cswap_(n, &a_ref(1, jpv), &c__1, &a_ref(1, i__), &c__1);
}
jpiv[i__] = jpv;
/* Check for singularity */
if (c_abs(&a_ref(i__, i__)) < smin) {
*info = i__;
i__2 = a_subscr(i__, i__);
q__1.r = smin, q__1.i = 0.f;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = a_subscr(j, i__);
c_div(&q__1, &a_ref(j, i__), &a_ref(i__, i__));
a[i__3].r = q__1.r, a[i__3].i = q__1.i;
/* L30: */
}
i__2 = *n - i__;
i__3 = *n - i__;
cgeru_(&i__2, &i__3, &c_b10, &a_ref(i__ + 1, i__), &c__1, &a_ref(i__,
i__ + 1), lda, &a_ref(i__ + 1, i__ + 1), lda);
/* L40: */
}
if (c_abs(&a_ref(*n, *n)) < smin) {
*info = *n;
i__1 = a_subscr(*n, *n);
q__1.r = smin, q__1.i = 0.f;
a[i__1].r = q__1.r, a[i__1].i = q__1.i;
}
return 0;
/* End of CGETC2 */
} /* cgetc2_ */
/* Subroutine */ int cgbtrs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, complex *ab, integer *ldab, integer *ipiv, 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
=======
CGBTRS solves a system of linear equations
A * X = B, A**T * X = B, or A**H * X = B
with a general band matrix A using the LU factorization computed
by CGBTRF.
Arguments
=========
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)
N (input) INTEGER
The order of the matrix A. N >= 0.
KL (input) INTEGER
The number of subdiagonals within the band of A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals within the band of A. KU >= 0.
NRHS (input) INTEGER
The number of right hand sides, i.e., the number of columns
of the matrix B. NRHS >= 0.
AB (input) COMPLEX array, dimension (LDAB,N)
Details of the LU factorization of the band matrix A, as
computed by CGBTRF. U is stored as an upper triangular band
matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
the multipliers used during the factorization are stored in
rows KL+KU+2 to 2*KL+KU+1.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
IPIV (input) INTEGER array, dimension (N)
The pivot indices; for 1 <= i <= N, row i of the matrix was
interchanged with row IPIV(i).
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 */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
complex q__1;
/* Local variables */
static integer i__, j, l;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *),
ctbsv_(char *, char *, char *, integer *, integer *, complex *,
integer *, complex *, integer *);
static logical lnoti;
static integer kd, lm;
extern /* Subroutine */ int clacgv_(integer *, complex *, integer *),
xerbla_(char *, integer *);
static logical notran;
#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 ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
/* Function Body */
*info = 0;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*nrhs < 0) {
*info = -5;
} else if (*ldab < (*kl << 1) + *ku + 1) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -10;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBTRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
kd = *ku + *kl + 1;
lnoti = *kl > 0;
if (notran) {
/* Solve A*X = B.
Solve L*X = B, overwriting B with X.
L is represented as a product of permutations and unit lower
triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
where each transformation L(i) is a rank-one modification of
the identity matrix. */
if (lnoti) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kl, i__3 = *n - j;
lm = min(i__2,i__3);
l = ipiv[j];
if (l != j) {
cswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb);
}
q__1.r = -1.f, q__1.i = 0.f;
cgeru_(&lm, nrhs, &q__1, &ab_ref(kd + 1, j), &c__1, &b_ref(j,
1), ldb, &b_ref(j + 1, 1), ldb);
/* L10: */
}
}
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U*X = B, overwriting B with X. */
i__2 = *kl + *ku;
ctbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[
ab_offset], ldab, &b_ref(1, i__), &c__1);
/* L20: */
}
} else if (lsame_(trans, "T")) {
/* Solve A**T * X = B. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U**T * X = B, overwriting B with X. */
i__2 = *kl + *ku;
ctbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset],
ldab, &b_ref(1, i__), &c__1);
/* L30: */
}
/* Solve L**T * X = B, overwriting B with X. */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Transpose", &lm, nrhs, &q__1, &b_ref(j + 1, 1), ldb, &
ab_ref(kd + 1, j), &c__1, &c_b1, &b_ref(j, 1), ldb);
l = ipiv[j];
if (l != j) {
cswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb);
}
/* L40: */
}
}
} else {
/* Solve A**H * X = B. */
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U**H * X = B, overwriting B with X. */
i__2 = *kl + *ku;
ctbsv_("Upper", "Conjugate transpose", "Non-unit", n, &i__2, &ab[
ab_offset], ldab, &b_ref(1, i__), &c__1);
/* L50: */
}
/* Solve L**H * X = B, overwriting B with X. */
if (lnoti) {
for (j = *n - 1; j >= 1; --j) {
/* Computing MIN */
i__1 = *kl, i__2 = *n - j;
lm = min(i__1,i__2);
clacgv_(nrhs, &b_ref(j, 1), ldb);
q__1.r = -1.f, q__1.i = 0.f;
cgemv_("Conjugate transpose", &lm, nrhs, &q__1, &b_ref(j + 1,
1), ldb, &ab_ref(kd + 1, j), &c__1, &c_b1, &b_ref(j,
1), ldb);
clacgv_(nrhs, &b_ref(j, 1), ldb);
l = ipiv[j];
if (l != j) {
cswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb);
}
/* L60: */
}
}
}
return 0;
/* End of CGBTRS */
} /* cgbtrs_ */
/* Subroutine */ int cgbtrf_(integer *m, integer *n, integer *kl, integer *ku,
complex *ab, integer *ldab, integer *ipiv, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6;
complex q__1;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
integer i__, j, i2, i3, j2, j3, k2, jb, nb, ii, jj, jm, ip, jp, km, ju,
kv, nw;
complex temp;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgemm_(char *, char *, integer *, integer *, integer *
, complex *, complex *, integer *, complex *, integer *, complex *
, complex *, integer *), cgeru_(integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, integer *), ccopy_(integer *, complex *, integer *,
complex *, integer *), cswap_(integer *, complex *, integer *,
complex *, integer *);
#ifdef LAPACK_DISABLE_MEMORY_HOGS
complex work13[1] /* was [65][64] */, work31[1] /*
was [65][64] */;
/** This function uses too much memory, so we stopped allocating the memory
* above and assert false here. */
assert(0 && "cgbtrf_ was called. This function allocates too much"
" memory and has been disabled.");
#else
complex work13[4160] /* was [65][64] */, work31[4160] /*
was [65][64] */;
#endif
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *), cgbtf2_(integer *,
integer *, integer *, integer *, complex *, integer *, integer *,
integer *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int claswp_(integer *, complex *, integer *,
integer *, integer *, integer *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGBTRF computes an LU factorization of a complex m-by-n band matrix A */
/* using partial pivoting with row interchanges. */
/* This is the blocked version of the algorithm, calling Level 3 BLAS. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
/* On entry, the matrix A in band storage, in rows KL+1 to */
/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
/* On exit, details of the factorization: U is stored as an */
/* upper triangular band matrix with KL+KU superdiagonals in */
/* rows 1 to KL+KU+1, and the multipliers used during the */
/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
/* See below for further details. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* M = N = 6, KL = 2, KU = 1: */
/* On entry: On exit: */
/* * * * + + + * * * u14 u25 u36 */
/* * * + + + + * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
/* Array elements marked * are not used by the routine; elements marked */
/* + need not be set on entry, but are required by the routine to store */
/* elements of U because of fill-in resulting from the row interchanges. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* KV is the number of superdiagonals in the factor U, allowing for */
/* fill-in */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < *kl + kv + 1) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBTRF", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Determine the block size for this environment */
nb = ilaenv_(&c__1, "CGBTRF", " ", m, n, kl, ku);
/* The block size must not exceed the limit set by the size of the */
/* local arrays WORK13 and WORK31. */
nb = min(nb,64);
if (nb <= 1 || nb > *kl) {
/* Use unblocked code */
cgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info);
} else {
/* Use blocked code */
/* Zero the superdiagonal elements of the work array WORK13 */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = j - 1;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 65 - 66;
work13[i__3].r = 0.f, work13[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
/* Zero the subdiagonal elements of the work array WORK31 */
i__1 = nb;
for (j = 1; j <= i__1; ++j) {
i__2 = nb;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * 65 - 66;
work31[i__3].r = 0.f, work31[i__3].i = 0.f;
/* L30: */
}
/* L40: */
}
/* Gaussian elimination with partial pivoting */
/* Set fill-in elements in columns KU+2 to KV to zero */
i__1 = min(kv,*n);
for (j = *ku + 2; j <= i__1; ++j) {
i__2 = *kl;
for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * ab_dim1;
ab[i__3].r = 0.f, ab[i__3].i = 0.f;
/* L50: */
}
/* L60: */
}
/* JU is the index of the last column affected by the current */
/* stage of the factorization */
ju = 1;
i__1 = min(*m,*n);
i__2 = nb;
for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = min(*m,*n) - j + 1;
jb = min(i__3,i__4);
/* The active part of the matrix is partitioned */
/* A11 A12 A13 */
/* A21 A22 A23 */
/* A31 A32 A33 */
/* Here A11, A21 and A31 denote the current block of JB columns */
/* which is about to be factorized. The number of rows in the */
/* partitioning are JB, I2, I3 respectively, and the numbers */
/* of columns are JB, J2, J3. The superdiagonal elements of A13 */
/* and the subdiagonal elements of A31 lie outside the band. */
/* Computing MIN */
i__3 = *kl - jb, i__4 = *m - j - jb + 1;
i2 = min(i__3,i__4);
/* Computing MIN */
i__3 = jb, i__4 = *m - j - *kl + 1;
i3 = min(i__3,i__4);
/* J2 and J3 are computed after JU has been updated. */
/* Factorize the current block of JB columns */
i__3 = j + jb - 1;
for (jj = j; jj <= i__3; ++jj) {
/* Set fill-in elements in column JJ+KV to zero */
if (jj + kv <= *n) {
i__4 = *kl;
for (i__ = 1; i__ <= i__4; ++i__) {
i__5 = i__ + (jj + kv) * ab_dim1;
ab[i__5].r = 0.f, ab[i__5].i = 0.f;
/* L70: */
}
}
/* Find pivot and test for singularity. KM is the number of */
/* subdiagonal elements in the current column. */
/* Computing MIN */
i__4 = *kl, i__5 = *m - jj;
km = min(i__4,i__5);
i__4 = km + 1;
jp = icamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1);
ipiv[jj] = jp + jj - j;
i__4 = kv + jp + jj * ab_dim1;
if (ab[i__4].r != 0.f || ab[i__4].i != 0.f) {
/* Computing MAX */
/* Computing MIN */
i__6 = jj + *ku + jp - 1;
i__4 = ju, i__5 = min(i__6,*n);
ju = max(i__4,i__5);
if (jp != 1) {
/* Apply interchange to columns J to J+JB-1 */
if (jp + jj - 1 < j + *kl) {
i__4 = *ldab - 1;
i__5 = *ldab - 1;
cswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__4, &ab[kv + jp + jj - j + j * ab_dim1],
&i__5);
} else {
/* The interchange affects columns J to JJ-1 of A31 */
/* which are stored in the work array WORK31 */
i__4 = jj - j;
i__5 = *ldab - 1;
cswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1],
&i__5, &work31[jp + jj - j - *kl - 1], &
c__65);
i__4 = j + jb - jj;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
cswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, &
ab[kv + jp + jj * ab_dim1], &i__6);
}
}
/* Compute multipliers */
c_div(&q__1, &c_b1, &ab[kv + 1 + jj * ab_dim1]);
cscal_(&km, &q__1, &ab[kv + 2 + jj * ab_dim1], &c__1);
/* Update trailing submatrix within the band and within */
/* the current block. JM is the index of the last column */
/* which needs to be updated. */
/* Computing MIN */
i__4 = ju, i__5 = j + jb - 1;
jm = min(i__4,i__5);
if (jm > jj) {
i__4 = jm - jj;
q__1.r = -1.f, q__1.i = -0.f;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
cgeru_(&km, &i__4, &q__1, &ab[kv + 2 + jj * ab_dim1],
&c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, &
ab[kv + 1 + (jj + 1) * ab_dim1], &i__6);
}
} else {
/* If pivot is zero, set INFO to the index of the pivot */
/* unless a zero pivot has already been found. */
if (*info == 0) {
*info = jj;
}
}
/* Copy current column of A31 into the work array WORK31 */
/* Computing MIN */
i__4 = jj - j + 1;
nw = min(i__4,i3);
if (nw > 0) {
ccopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], &
c__1, &work31[(jj - j + 1) * 65 - 65], &c__1);
}
/* L80: */
}
if (j + jb <= *n) {
/* Apply the row interchanges to the other blocks. */
/* Computing MIN */
i__3 = ju - j + 1;
j2 = min(i__3,kv) - jb;
/* Computing MAX */
i__3 = 0, i__4 = ju - j - kv + 1;
j3 = max(i__3,i__4);
/* Use CLASWP to apply the row interchanges to A12, A22, and */
/* A32. */
i__3 = *ldab - 1;
claswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, &
c__1, &jb, &ipiv[j], &c__1);
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = ipiv[i__] + j - 1;
/* L90: */
}
/* Apply the row interchanges to A13, A23, and A33 */
/* columnwise. */
k2 = j - 1 + jb + j2;
i__3 = j3;
for (i__ = 1; i__ <= i__3; ++i__) {
jj = k2 + i__;
i__4 = j + jb - 1;
for (ii = j + i__ - 1; ii <= i__4; ++ii) {
ip = ipiv[ii];
if (ip != ii) {
i__5 = kv + 1 + ii - jj + jj * ab_dim1;
temp.r = ab[i__5].r, temp.i = ab[i__5].i;
i__5 = kv + 1 + ii - jj + jj * ab_dim1;
i__6 = kv + 1 + ip - jj + jj * ab_dim1;
ab[i__5].r = ab[i__6].r, ab[i__5].i = ab[i__6].i;
i__5 = kv + 1 + ip - jj + jj * ab_dim1;
ab[i__5].r = temp.r, ab[i__5].i = temp.i;
}
/* L100: */
}
/* L110: */
}
/* Update the relevant part of the trailing submatrix */
if (j2 > 0) {
/* Update A12 */
i__3 = *ldab - 1;
i__4 = *ldab - 1;
ctrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2,
&c_b1, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv +
1 - jb + (j + jb) * ab_dim1], &i__4);
if (i2 > 0) {
/* Update A22 */
q__1.r = -1.f, q__1.i = -0.f;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
i__5 = *ldab - 1;
cgemm_("No transpose", "No transpose", &i2, &j2, &jb,
&q__1, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
&ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4,
&c_b1, &ab[kv + 1 + (j + jb) * ab_dim1], &
i__5);
}
if (i3 > 0) {
/* Update A32 */
q__1.r = -1.f, q__1.i = -0.f;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
cgemm_("No transpose", "No transpose", &i3, &j2, &jb,
&q__1, work31, &c__65, &ab[kv + 1 - jb + (j +
jb) * ab_dim1], &i__3, &c_b1, &ab[kv + *kl +
1 - jb + (j + jb) * ab_dim1], &i__4);
}
}
if (j3 > 0) {
/* Copy the lower triangle of A13 into the work array */
/* WORK13 */
i__3 = j3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= i__4; ++ii) {
i__5 = ii + jj * 65 - 66;
i__6 = ii - jj + 1 + (jj + j + kv - 1) * ab_dim1;
work13[i__5].r = ab[i__6].r, work13[i__5].i = ab[
i__6].i;
/* L120: */
}
/* L130: */
}
/* Update A13 in the work array */
i__3 = *ldab - 1;
ctrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3,
&c_b1, &ab[kv + 1 + j * ab_dim1], &i__3, work13, &
c__65);
if (i2 > 0) {
/* Update A23 */
q__1.r = -1.f, q__1.i = -0.f;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
cgemm_("No transpose", "No transpose", &i2, &j3, &jb,
&q__1, &ab[kv + 1 + jb + j * ab_dim1], &i__3,
work13, &c__65, &c_b1, &ab[jb + 1 + (j + kv) *
ab_dim1], &i__4);
}
if (i3 > 0) {
/* Update A33 */
q__1.r = -1.f, q__1.i = -0.f;
i__3 = *ldab - 1;
cgemm_("No transpose", "No transpose", &i3, &j3, &jb,
&q__1, work31, &c__65, work13, &c__65, &c_b1,
&ab[*kl + 1 + (j + kv) * ab_dim1], &i__3);
}
/* Copy the lower triangle of A13 back into place */
i__3 = j3;
for (jj = 1; jj <= i__3; ++jj) {
i__4 = jb;
for (ii = jj; ii <= i__4; ++ii) {
i__5 = ii - jj + 1 + (jj + j + kv - 1) * ab_dim1;
i__6 = ii + jj * 65 - 66;
ab[i__5].r = work13[i__6].r, ab[i__5].i = work13[
i__6].i;
/* L140: */
}
/* L150: */
}
}
} else {
/* Adjust the pivot indices. */
i__3 = j + jb - 1;
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = ipiv[i__] + j - 1;
/* L160: */
}
}
/* Partially undo the interchanges in the current block to */
/* restore the upper triangular form of A31 and copy the upper */
/* triangle of A31 back into place */
i__3 = j;
for (jj = j + jb - 1; jj >= i__3; --jj) {
jp = ipiv[jj] - jj + 1;
if (jp != 1) {
/* Apply interchange to columns J to JJ-1 */
if (jp + jj - 1 < j + *kl) {
/* The interchange does not affect A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
i__6 = *ldab - 1;
cswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__5, &ab[kv + jp + jj - j + j * ab_dim1], &
i__6);
} else {
/* The interchange does affect A31 */
i__4 = jj - j;
i__5 = *ldab - 1;
cswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], &
i__5, &work31[jp + jj - j - *kl - 1], &c__65);
}
}
/* Copy the current column of A31 back into place */
/* Computing MIN */
i__4 = i3, i__5 = jj - j + 1;
nw = min(i__4,i__5);
if (nw > 0) {
ccopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[
kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1);
}
/* L170: */
}
/* L180: */
}
}
return 0;
/* End of CGBTRF */
} /* cgbtrf_ */
/* Subroutine */ int cgbtf2_(integer *m, integer *n, integer *kl, integer *ku,
complex *ab, integer *ldab, integer *ipiv, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Builtin functions */
void c_div(complex *, complex *, complex *);
/* Local variables */
static integer i__, j, km, jp, ju, kv;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), cgeru_(integer *, integer *, complex *, complex *,
integer *, complex *, integer *, complex *, integer *), cswap_(
integer *, complex *, integer *, complex *, integer *);
extern integer icamax_(integer *, complex *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGBTF2 computes an LU factorization of a complex m-by-n band matrix */
/* A using partial pivoting with row interchanges. */
/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of subdiagonals within the band of A. KL >= 0. */
/* KU (input) INTEGER */
/* The number of superdiagonals within the band of A. KU >= 0. */
/* AB (input/output) COMPLEX array, dimension (LDAB,N) */
/* On entry, the matrix A in band storage, in rows KL+1 to */
/* 2*KL+KU+1; rows 1 to KL of the array need not be set. */
/* The j-th column of A is stored in the j-th column of the */
/* array AB as follows: */
/* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) */
/* On exit, details of the factorization: U is stored as an */
/* upper triangular band matrix with KL+KU superdiagonals in */
/* rows 1 to KL+KU+1, and the multipliers used during the */
/* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */
/* See below for further details. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */
/* IPIV (output) INTEGER array, dimension (min(M,N)) */
/* The pivot indices; for 1 <= i <= min(M,N), row i of the */
/* matrix was interchanged with row IPIV(i). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly */
/* singular, and division by zero will occur if it is used */
/* to solve a system of equations. */
/* Further Details */
/* =============== */
/* The band storage scheme is illustrated by the following example, when */
/* M = N = 6, KL = 2, KU = 1: */
/* On entry: On exit: */
/* * * * + + + * * * u14 u25 u36 */
/* * * + + + + * * u13 u24 u35 u46 */
/* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */
/* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */
/* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */
/* a31 a42 a53 a64 * * m31 m42 m53 m64 * * */
/* Array elements marked * are not used by the routine; elements marked */
/* + need not be set on entry, but are required by the routine to store */
/* elements of U, because of fill-in resulting from the row */
/* interchanges. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* KV is the number of superdiagonals in the factor U, allowing for */
/* fill-in. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--ipiv;
/* Function Body */
kv = *ku + *kl;
/* Test the input parameters. */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0) {
*info = -3;
} else if (*ku < 0) {
*info = -4;
} else if (*ldab < *kl + kv + 1) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGBTF2", &i__1, (ftnlen)6);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Gaussian elimination with partial pivoting */
/* Set fill-in elements in columns KU+2 to KV to zero. */
i__1 = min(kv,*n);
for (j = *ku + 2; j <= i__1; ++j) {
i__2 = *kl;
for (i__ = kv - j + 2; i__ <= i__2; ++i__) {
i__3 = i__ + j * ab_dim1;
ab[i__3].r = 0.f, ab[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
/* JU is the index of the last column affected by the current stage */
/* of the factorization. */
ju = 1;
i__1 = min(*m,*n);
for (j = 1; j <= i__1; ++j) {
/* Set fill-in elements in column J+KV to zero. */
if (j + kv <= *n) {
i__2 = *kl;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + (j + kv) * ab_dim1;
ab[i__3].r = 0.f, ab[i__3].i = 0.f;
/* L30: */
}
}
/* Find pivot and test for singularity. KM is the number of */
/* subdiagonal elements in the current column. */
/* Computing MIN */
i__2 = *kl, i__3 = *m - j;
km = min(i__2,i__3);
i__2 = km + 1;
jp = icamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1);
ipiv[j] = jp + j - 1;
i__2 = kv + jp + j * ab_dim1;
if (ab[i__2].r != 0.f || ab[i__2].i != 0.f) {
/* Computing MAX */
/* Computing MIN */
i__4 = j + *ku + jp - 1;
i__2 = ju, i__3 = min(i__4,*n);
ju = max(i__2,i__3);
/* Apply interchange to columns J to JU. */
if (jp != 1) {
i__2 = ju - j + 1;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
cswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 +
j * ab_dim1], &i__4);
}
if (km > 0) {
/* Compute multipliers. */
c_div(&q__1, &c_b1, &ab[kv + 1 + j * ab_dim1]);
cscal_(&km, &q__1, &ab[kv + 2 + j * ab_dim1], &c__1);
/* Update trailing submatrix within the band. */
if (ju > j) {
i__2 = ju - j;
q__1.r = -1.f, q__1.i = -0.f;
i__3 = *ldab - 1;
i__4 = *ldab - 1;
cgeru_(&km, &i__2, &q__1, &ab[kv + 2 + j * ab_dim1], &
c__1, &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv
+ 1 + (j + 1) * ab_dim1], &i__4);
}
}
} else {
/* If pivot is zero, set INFO to the index of the pivot */
/* unless a zero pivot has already been found. */
if (*info == 0) {
*info = j;
}
}
/* L40: */
}
return 0;
/* End of CGBTF2 */
} /* cgbtf2_ */
/* Subroutine */ int clavsp_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *a, integer *ipiv, complex *b, integer *ldb,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
complex q__1, q__2, q__3;
/* Local variables */
integer j, k;
complex t1, t2, d11, d12, d21, d22;
integer kc, kp;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *), cgeru_(integer *, integer *, complex *,
complex *, integer *, complex *, integer *, complex *, integer *),
cswap_(integer *, complex *, integer *, complex *, integer *),
xerbla_(char *, integer *);
integer kcnext;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAVSP performs one of the matrix-vector operations */
/* x := A*x or x := A^T*x, */
/* where x is an N element vector and A is one of the factors */
/* from the symmetric factorization computed by CSPTRF. */
/* CSPTRF produces a factorization of the form */
/* U * D * U^T or L * D * L^T, */
/* where U (or L) is a product of permutation and unit upper (lower) */
/* triangular matrices, U^T (or L^T) is the transpose of */
/* U (or L), and D is symmetric and block diagonal with 1 x 1 and */
/* 2 x 2 diagonal blocks. The multipliers for the transformations */
/* and the upper or lower triangular parts of the diagonal blocks */
/* are stored columnwise in packed format in the linear array A. */
/* If TRANS = 'N' or 'n', CLAVSP multiplies either by U or U * D */
/* (or L or L * D). */
/* If TRANS = 'C' or 'c', CLAVSP multiplies either by U^T or D * U^T */
/* (or L^T or D * L^T ). */
/* Arguments */
/* ========== */
/* UPLO - CHARACTER*1 */
/* On entry, UPLO specifies whether the triangular matrix */
/* stored in A is upper or lower triangular. */
/* UPLO = 'U' or 'u' The matrix is upper triangular. */
/* UPLO = 'L' or 'l' The matrix is lower triangular. */
/* Unchanged on exit. */
/* TRANS - CHARACTER*1 */
/* On entry, TRANS specifies the operation to be performed as */
/* follows: */
/* TRANS = 'N' or 'n' x := A*x. */
/* TRANS = 'T' or 't' x := A^T*x. */
/* Unchanged on exit. */
/* DIAG - CHARACTER*1 */
/* On entry, DIAG specifies whether the diagonal blocks are */
/* assumed to be unit matrices, as follows: */
/* DIAG = 'U' or 'u' Diagonal blocks are unit matrices. */
/* DIAG = 'N' or 'n' Diagonal blocks are non-unit. */
/* Unchanged on exit. */
/* N - INTEGER */
/* On entry, N specifies the order of the matrix A. */
/* N must be at least zero. */
/* Unchanged on exit. */
/* NRHS - INTEGER */
/* On entry, NRHS specifies the number of right hand sides, */
/* i.e., the number of vectors x to be multiplied by A. */
/* NRHS must be at least zero. */
/* Unchanged on exit. */
/* A - COMPLEX array, dimension( N*(N+1)/2 ) */
/* On entry, A contains a block diagonal matrix and the */
/* multipliers of the transformations used to obtain it, */
/* stored as a packed triangular matrix. */
/* Unchanged on exit. */
/* IPIV - INTEGER array, dimension( N ) */
/* On entry, IPIV contains the vector of pivot indices as */
/* determined by CSPTRF. */
/* If IPIV( K ) = K, no interchange was done. */
/* If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter- */
/* changed with row IPIV( K ) and a 1 x 1 pivot block was used. */
/* If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged */
/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
/* If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged */
/* with row | IPIV( K ) | and a 2 x 2 pivot block was used. */
/* B - COMPLEX array, dimension( LDB, NRHS ) */
/* On entry, B contains NRHS vectors of length N. */
/* On exit, B is overwritten with the product A * B. */
/* LDB - INTEGER */
/* On entry, LDB contains the leading dimension of B as */
/* declared in the calling program. LDB must be at least */
/* max( 1, N ). */
/* Unchanged on exit. */
/* INFO - INTEGER */
/* INFO is the error flag. */
/* On exit, a value of 0 indicates a successful exit. */
/* A negative value, say -K, indicates that the K-th argument */
/* has an illegal value. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
--a;
--ipiv;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
/* Function Body */
*info = 0;
if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! lsame_(trans, "N") && ! lsame_(trans,
"T")) {
*info = -2;
} else if (! lsame_(diag, "U") && ! lsame_(diag,
"N")) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ldb < max(1,*n)) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CLAVSP ", &i__1);
return 0;
}
/* Quick return if possible. */
if (*n == 0) {
return 0;
}
nounit = lsame_(diag, "N");
/* ------------------------------------------ */
/* Compute B := A * B (No transpose) */
/* ------------------------------------------ */
if (lsame_(trans, "N")) {
/* Compute B := U*B */
/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
if (lsame_(uplo, "U")) {
/* Loop forward applying the transformations. */
k = 1;
kc = 1;
L10:
if (k > *n) {
goto L30;
}
/* 1 x 1 pivot block */
if (ipiv[k] > 0) {
/* Multiply by the diagonal element if forming U * D. */
if (nounit) {
cscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
}
/* Multiply by P(K) * inv(U(K)) if K > 1. */
if (k > 1) {
/* Apply the transformation. */
i__1 = k - 1;
cgeru_(&i__1, nrhs, &c_b1, &a[kc], &c__1, &b[k + b_dim1],
ldb, &b[b_dim1 + 1], ldb);
/* Interchange if P(K) != I. */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
kc += k;
++k;
} else {
/* 2 x 2 pivot block */
kcnext = kc + k;
/* Multiply by the diagonal block if forming U * D. */
if (nounit) {
i__1 = kcnext - 1;
d11.r = a[i__1].r, d11.i = a[i__1].i;
i__1 = kcnext + k;
d22.r = a[i__1].r, d22.i = a[i__1].i;
i__1 = kcnext + k - 1;
d12.r = a[i__1].r, d12.i = a[i__1].i;
d21.r = d12.r, d21.i = d12.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * b_dim1;
t1.r = b[i__2].r, t1.i = b[i__2].i;
i__2 = k + 1 + j * b_dim1;
t2.r = b[i__2].r, t2.i = b[i__2].i;
i__2 = k + j * b_dim1;
q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
t1.i + d11.i * t1.r;
q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
t2.i + d12.i * t2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = k + 1 + j * b_dim1;
q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
t1.i + d21.i * t1.r;
q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
t2.i + d22.i * t2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L20: */
}
}
/* Multiply by P(K) * inv(U(K)) if K > 1. */
if (k > 1) {
/* Apply the transformations. */
i__1 = k - 1;
cgeru_(&i__1, nrhs, &c_b1, &a[kc], &c__1, &b[k + b_dim1],
ldb, &b[b_dim1 + 1], ldb);
i__1 = k - 1;
cgeru_(&i__1, nrhs, &c_b1, &a[kcnext], &c__1, &b[k + 1 +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Interchange if P(K) != I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
kc = kcnext + k + 1;
k += 2;
}
goto L10;
L30:
/* Compute B := L*B */
/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) . */
;
} else {
/* Loop backward applying the transformations to B. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L40:
if (k < 1) {
goto L60;
}
kc -= *n - k + 1;
/* Test the pivot index. If greater than zero, a 1 x 1 */
/* pivot was used, otherwise a 2 x 2 pivot was used. */
if (ipiv[k] > 0) {
/* 1 x 1 pivot block: */
/* Multiply by the diagonal element if forming L * D. */
if (nounit) {
cscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
}
/* Multiply by P(K) * inv(L(K)) if K < N. */
if (k != *n) {
kp = ipiv[k];
/* Apply the transformation. */
i__1 = *n - k;
cgeru_(&i__1, nrhs, &c_b1, &a[kc + 1], &c__1, &b[k +
b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
/* Interchange if a permutation was applied at the */
/* K-th step of the factorization. */
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
--k;
} else {
/* 2 x 2 pivot block: */
kcnext = kc - (*n - k + 2);
/* Multiply by the diagonal block if forming L * D. */
if (nounit) {
i__1 = kcnext;
d11.r = a[i__1].r, d11.i = a[i__1].i;
i__1 = kc;
d22.r = a[i__1].r, d22.i = a[i__1].i;
i__1 = kcnext + 1;
d21.r = a[i__1].r, d21.i = a[i__1].i;
d12.r = d21.r, d12.i = d21.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = k - 1 + j * b_dim1;
t1.r = b[i__2].r, t1.i = b[i__2].i;
i__2 = k + j * b_dim1;
t2.r = b[i__2].r, t2.i = b[i__2].i;
i__2 = k - 1 + j * b_dim1;
q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
t1.i + d11.i * t1.r;
q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
t2.i + d12.i * t2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = k + j * b_dim1;
q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
t1.i + d21.i * t1.r;
q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
t2.i + d22.i * t2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L50: */
}
}
/* Multiply by P(K) * inv(L(K)) if K < N. */
if (k != *n) {
/* Apply the transformation. */
i__1 = *n - k;
cgeru_(&i__1, nrhs, &c_b1, &a[kc + 1], &c__1, &b[k +
b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
i__1 = *n - k;
cgeru_(&i__1, nrhs, &c_b1, &a[kcnext + 2], &c__1, &b[k -
1 + b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
/* Interchange if a permutation was applied at the */
/* K-th step of the factorization. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
}
kc = kcnext;
k += -2;
}
goto L40;
L60:
;
}
/* ------------------------------------------------- */
/* Compute B := A^T * B (transpose) */
/* ------------------------------------------------- */
} else {
/* Form B := U^T*B */
/* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1)) */
/* and U^T = inv(U^T(1))*P(1)* ... *inv(U^T(m))*P(m) */
if (lsame_(uplo, "U")) {
/* Loop backward applying the transformations. */
k = *n;
kc = *n * (*n + 1) / 2 + 1;
L70:
if (k < 1) {
goto L90;
}
kc -= k;
/* 1 x 1 pivot block. */
if (ipiv[k] > 0) {
if (k > 1) {
/* Interchange if P(K) != I. */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformation: */
/* y := y - B' * conjg(x) */
/* where x is a column of A and y is a row of B. */
i__1 = k - 1;
cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
&a[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
}
if (nounit) {
cscal_(nrhs, &a[kc + k - 1], &b[k + b_dim1], ldb);
}
--k;
/* 2 x 2 pivot block. */
} else {
kcnext = kc - (k - 1);
if (k > 2) {
/* Interchange if P(K) != I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k - 1) {
cswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformations. */
i__1 = k - 2;
cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
&a[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
i__1 = k - 2;
cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
&a[kcnext], &c__1, &c_b1, &b[k - 1 + b_dim1],
ldb);
}
/* Multiply by the diagonal block if non-unit. */
if (nounit) {
i__1 = kc - 1;
d11.r = a[i__1].r, d11.i = a[i__1].i;
i__1 = kc + k - 1;
d22.r = a[i__1].r, d22.i = a[i__1].i;
i__1 = kc + k - 2;
d12.r = a[i__1].r, d12.i = a[i__1].i;
d21.r = d12.r, d21.i = d12.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = k - 1 + j * b_dim1;
t1.r = b[i__2].r, t1.i = b[i__2].i;
i__2 = k + j * b_dim1;
t2.r = b[i__2].r, t2.i = b[i__2].i;
i__2 = k - 1 + j * b_dim1;
q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
t1.i + d11.i * t1.r;
q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
t2.i + d12.i * t2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = k + j * b_dim1;
q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
t1.i + d21.i * t1.r;
q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
t2.i + d22.i * t2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L80: */
}
}
kc = kcnext;
k += -2;
}
goto L70;
L90:
/* Form B := L^T*B */
/* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) */
/* and L^T = inv(L(m))*P(m)* ... *inv(L(1))*P(1) */
;
} else {
/* Loop forward applying the L-transformations. */
k = 1;
kc = 1;
L100:
if (k > *n) {
goto L120;
}
/* 1 x 1 pivot block */
if (ipiv[k] > 0) {
if (k < *n) {
/* Interchange if P(K) != I. */
kp = ipiv[k];
if (kp != k) {
cswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformation */
i__1 = *n - k;
cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 1 + b_dim1]
, ldb, &a[kc + 1], &c__1, &c_b1, &b[k + b_dim1],
ldb);
}
if (nounit) {
cscal_(nrhs, &a[kc], &b[k + b_dim1], ldb);
}
kc = kc + *n - k + 1;
++k;
/* 2 x 2 pivot block. */
} else {
kcnext = kc + *n - k + 1;
if (k < *n - 1) {
/* Interchange if P(K) != I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k + 1) {
cswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1],
ldb);
}
/* Apply the transformation */
i__1 = *n - k - 1;
cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
, ldb, &a[kcnext + 1], &c__1, &c_b1, &b[k + 1 +
b_dim1], ldb);
i__1 = *n - k - 1;
cgemv_("Transpose", &i__1, nrhs, &c_b1, &b[k + 2 + b_dim1]
, ldb, &a[kc + 2], &c__1, &c_b1, &b[k + b_dim1],
ldb);
}
/* Multiply by the diagonal block if non-unit. */
if (nounit) {
i__1 = kc;
d11.r = a[i__1].r, d11.i = a[i__1].i;
i__1 = kcnext;
d22.r = a[i__1].r, d22.i = a[i__1].i;
i__1 = kc + 1;
d21.r = a[i__1].r, d21.i = a[i__1].i;
d12.r = d21.r, d12.i = d21.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = k + j * b_dim1;
t1.r = b[i__2].r, t1.i = b[i__2].i;
i__2 = k + 1 + j * b_dim1;
t2.r = b[i__2].r, t2.i = b[i__2].i;
i__2 = k + j * b_dim1;
q__2.r = d11.r * t1.r - d11.i * t1.i, q__2.i = d11.r *
t1.i + d11.i * t1.r;
q__3.r = d12.r * t2.r - d12.i * t2.i, q__3.i = d12.r *
t2.i + d12.i * t2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
i__2 = k + 1 + j * b_dim1;
q__2.r = d21.r * t1.r - d21.i * t1.i, q__2.i = d21.r *
t1.i + d21.i * t1.r;
q__3.r = d22.r * t2.r - d22.i * t2.i, q__3.i = d22.r *
t2.i + d22.i * t2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
b[i__2].r = q__1.r, b[i__2].i = q__1.i;
/* L110: */
}
}
kc = kcnext + (*n - k);
k += 2;
}
goto L100;
L120:
;
}
}
return 0;
/* End of CLAVSP */
} /* clavsp_ */
