/* Subroutine */ int cgetrf_(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, i__4, i__5;
complex q__1;
/* Local variables */
integer i__, j, jb, nb;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
integer iinfo;
extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *), cgetf2_(integer *,
integer *, complex *, integer *, integer *, integer *), 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.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* March 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGETRF 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 Crout Level 3 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 = -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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--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_("CGETRF", &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, "CGETRF", " ", m, n, &c_n1, &c_n1);
if (nb <= 1 || nb >= min(*m,*n)) {
/* Use unblocked code. */
cgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info);
} else {
/* Use blocked code. */
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 = min(*m,*n) - j + 1;
jb = min(i__3,nb);
/* Update current block. */
i__3 = *m - j + 1;
i__4 = j - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("No transpose", "No transpose", &i__3, &jb, &i__4, &q__1, &
a[j + a_dim1], lda, &a[j * a_dim1 + 1], lda, &c_b1, &a[j
+ j * a_dim1], lda);
/* Factor diagonal and subdiagonal blocks and test for exact */
/* singularity. */
i__3 = *m - j + 1;
cgetf2_(&i__3, &jb, &a[j + j * a_dim1], lda, &ipiv[j], &iinfo);
/* Adjust INFO and the pivot indices. */
if (*info == 0 && iinfo > 0) {
*info = iinfo + j - 1;
}
/* Computing MIN */
i__4 = *m, i__5 = j + jb - 1;
i__3 = min(i__4,i__5);
for (i__ = j; i__ <= i__3; ++i__) {
ipiv[i__] = j - 1 + ipiv[i__];
/* L10: */
}
/* Apply interchanges to column 1:J-1 */
i__3 = j - 1;
i__4 = j + jb - 1;
claswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1);
if (j + jb <= *n) {
/* Apply interchanges to column J+JB:N */
i__3 = *n - j - jb + 1;
i__4 = j + jb - 1;
claswp_(&i__3, &a[(j + jb) * a_dim1 + 1], lda, &j, &i__4, &
ipiv[1], &c__1);
i__3 = *n - j - jb + 1;
i__4 = j - 1;
q__1.r = -1.f, q__1.i = -0.f;
cgemm_("No transpose", "No transpose", &jb, &i__3, &i__4, &
q__1, &a[j + a_dim1], lda, &a[(j + jb) * a_dim1 + 1],
lda, &c_b1, &a[j + (j + jb) * a_dim1], lda);
/* Compute block row of U. */
i__3 = *n - j - jb + 1;
ctrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, &
c_b1, &a[j + j * a_dim1], lda, &a[j + (j + jb) *
a_dim1], lda);
}
/* L20: */
}
}
return 0;
/* End of CGETRF */
} /* cgetrf_ */
/* Subroutine */ int cgesc2_(integer *n, complex *a, integer *lda, complex *
rhs, integer *ipiv, integer *jpiv, real *scale)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1;
complex q__1, q__2, q__3;
/* Local variables */
integer i__, j;
real eps;
complex temp;
real bignum;
real smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CGESC2 solves a system of linear equations */
/* A * X = scale* RHS */
/* with a general N-by-N matrix A using the LU factorization with */
/* complete pivoting computed by CGETC2. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The number of columns of the matrix A. */
/* A (input) COMPLEX array, dimension (LDA, N) */
/* On entry, the LU part of the factorization of the n-by-n */
/* matrix A computed by CGETC2: A = P * L * U * Q */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1, N). */
/* RHS (input/output) COMPLEX array, dimension N. */
/* On entry, the right hand side vector b. */
/* On exit, the solution vector X. */
/* IPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= i <= N, row i of the */
/* matrix has been interchanged with row IPIV(i). */
/* JPIV (input) INTEGER array, dimension (N). */
/* The pivot indices; for 1 <= j <= N, column j of the */
/* matrix has been interchanged with column JPIV(j). */
/* SCALE (output) REAL */
/* On exit, SCALE contains the scale factor. SCALE is chosen */
/* 0 <= SCALE <= 1 to prevent owerflow in the solution. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Bo Kagstrom and Peter Poromaa, Department of Computing Science, */
/* Umea University, S-901 87 Umea, Sweden. */
/* ===================================================================== */
/* Set constant to control overflow */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
claswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L part */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j;
i__4 = j;
i__5 = j + i__ * a_dim1;
i__6 = i__;
q__2.r = a[i__5].r * rhs[i__6].r - a[i__5].i * rhs[i__6].i,
q__2.i = a[i__5].r * rhs[i__6].i + a[i__5].i * rhs[i__6]
.r;
q__1.r = rhs[i__4].r - q__2.r, q__1.i = rhs[i__4].i - q__2.i;
rhs[i__3].r = q__1.r, rhs[i__3].i = q__1.i;
}
}
/* Solve for U part */
*scale = 1.f;
/* Check for scaling */
i__ = icamax_(n, &rhs[1], &c__1);
if (smlnum * 2.f * c_abs(&rhs[i__]) > c_abs(&a[*n + *n * a_dim1])) {
r__1 = c_abs(&rhs[i__]);
q__1.r = .5f / r__1, q__1.i = 0.f / r__1;
temp.r = q__1.r, temp.i = q__1.i;
cscal_(n, &temp, &rhs[1], &c__1);
*scale *= temp.r;
}
for (i__ = *n; i__ >= 1; --i__) {
c_div(&q__1, &c_b13, &a[i__ + i__ * a_dim1]);
temp.r = q__1.r, temp.i = q__1.i;
i__1 = i__;
i__2 = i__;
q__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, q__1.i = rhs[
i__2].r * temp.i + rhs[i__2].i * temp.r;
rhs[i__1].r = q__1.r, rhs[i__1].i = q__1.i;
i__1 = *n;
for (j = i__ + 1; j <= i__1; ++j) {
i__2 = i__;
i__3 = i__;
i__4 = j;
i__5 = i__ + j * a_dim1;
q__3.r = a[i__5].r * temp.r - a[i__5].i * temp.i, q__3.i = a[i__5]
.r * temp.i + a[i__5].i * temp.r;
q__2.r = rhs[i__4].r * q__3.r - rhs[i__4].i * q__3.i, q__2.i =
rhs[i__4].r * q__3.i + rhs[i__4].i * q__3.r;
q__1.r = rhs[i__3].r - q__2.r, q__1.i = rhs[i__3].i - q__2.i;
rhs[i__2].r = q__1.r, rhs[i__2].i = q__1.i;
}
}
/* Apply permutations JPIV to the solution (RHS) */
i__1 = *n - 1;
claswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1);
return 0;
/* End of CGESC2 */
} /* cgesc2_ */
/* Subroutine */ int cgetrs_(char *trans, 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;
/* Local variables */
logical notran;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CGETRS solves a system of linear equations */
/* A * X = B, A**T * X = B, or A**H * X = B */
/* with a general N-by-N matrix A using the LU factorization computed */
/* by CGETRF. */
/* 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. */
/* 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 factors L and U from the factorization A = P*L*U */
/* as computed by CGETRF. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* IPIV (input) INTEGER array, dimension (N) */
/* The pivot indices from CGETRF; 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 */
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;
notran = lsame_(trans, "N");
if (! notran && ! lsame_(trans, "T") && ! lsame_(
trans, "C")) {
*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_("CGETRS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0 || *nrhs == 0) {
return 0;
}
if (notran) {
/* Solve A * X = B. */
/* Apply row interchanges to the right hand sides. */
claswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1);
/* Solve L*X = B, overwriting B with X. */
ctrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b1, &a[
a_offset], lda, &b[b_offset], ldb);
/* Solve U*X = B, overwriting B with X. */
ctrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, &
a[a_offset], lda, &b[b_offset], ldb);
} else {
/* Solve A**T * X = B or A**H * X = B. */
/* Solve U'*X = B, overwriting B with X. */
ctrsm_("Left", "Upper", trans, "Non-unit", n, nrhs, &c_b1, &a[
a_offset], lda, &b[b_offset], ldb);
/* Solve L'*X = B, overwriting B with X. */
ctrsm_("Left", "Lower", trans, "Unit", n, nrhs, &c_b1, &a[a_offset],
lda, &b[b_offset], ldb);
/* Apply row interchanges to the solution vectors. */
claswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1);
}
return 0;
/* End of CGETRS */
} /* cgetrs_ */
/* 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 cgesc2_(integer *n, complex *a, integer *lda, complex *
rhs, integer *ipiv, integer *jpiv, real *scale)
{
/* -- 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
=======
CGESC2 solves a system of linear equations
A * X = scale* RHS
with a general N-by-N matrix A using the LU factorization with
complete pivoting computed by CGETC2.
Arguments
=========
N (input) INTEGER
The number of columns of the matrix A.
A (input) COMPLEX array, dimension (LDA, N)
On entry, the LU part of the factorization of the n-by-n
matrix A computed by CGETC2: A = P * L * U * Q
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1, N).
RHS (input/output) COMPLEX array, dimension N.
On entry, the right hand side vector b.
On exit, the solution vector X.
IPIV (iput) INTEGER array, dimension (N).
The pivot indices; for 1 <= i <= N, row i of the
matrix has been interchanged with row IPIV(i).
JPIV (iput) INTEGER array, dimension (N).
The pivot indices; for 1 <= j <= N, column j of the
matrix has been interchanged with column JPIV(j).
SCALE (output) REAL
On exit, SCALE contains the scale factor. SCALE is chosen
0 <= SCALE <= 1 to prevent owerflow in the solution.
Further Details
===============
Based on contributions by
Bo Kagstrom and Peter Poromaa, Department of Computing Science,
Umea University, S-901 87 Umea, Sweden.
=====================================================================
Set constant to control overflow
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static complex c_b13 = {1.f,0.f};
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
real r__1;
complex q__1, q__2, q__3;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
static complex temp;
static integer i__, j;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), slabad_(real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
static real bignum;
extern /* Subroutine */ int claswp_(integer *, complex *, integer *,
integer *, integer *, integer *, integer *);
static real smlnum, eps;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--rhs;
--ipiv;
--jpiv;
/* Function Body */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Apply permutations IPIV to RHS */
i__1 = *n - 1;
claswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &ipiv[1], &c__1);
/* Solve for L part */
i__1 = *n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j;
i__4 = j;
i__5 = a_subscr(j, i__);
i__6 = i__;
q__2.r = a[i__5].r * rhs[i__6].r - a[i__5].i * rhs[i__6].i,
q__2.i = a[i__5].r * rhs[i__6].i + a[i__5].i * rhs[i__6]
.r;
q__1.r = rhs[i__4].r - q__2.r, q__1.i = rhs[i__4].i - q__2.i;
rhs[i__3].r = q__1.r, rhs[i__3].i = q__1.i;
/* L10: */
}
/* L20: */
}
/* Solve for U part */
*scale = 1.f;
/* Check for scaling */
i__ = icamax_(n, &rhs[1], &c__1);
if (smlnum * 2.f * c_abs(&rhs[i__]) > c_abs(&a_ref(*n, *n))) {
r__1 = c_abs(&rhs[i__]);
q__1.r = .5f / r__1, q__1.i = 0.f / r__1;
temp.r = q__1.r, temp.i = q__1.i;
cscal_(n, &temp, &rhs[1], &c__1);
*scale *= temp.r;
}
for (i__ = *n; i__ >= 1; --i__) {
c_div(&q__1, &c_b13, &a_ref(i__, i__));
temp.r = q__1.r, temp.i = q__1.i;
i__1 = i__;
i__2 = i__;
q__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, q__1.i = rhs[
i__2].r * temp.i + rhs[i__2].i * temp.r;
rhs[i__1].r = q__1.r, rhs[i__1].i = q__1.i;
i__1 = *n;
for (j = i__ + 1; j <= i__1; ++j) {
i__2 = i__;
i__3 = i__;
i__4 = j;
i__5 = a_subscr(i__, j);
q__3.r = a[i__5].r * temp.r - a[i__5].i * temp.i, q__3.i = a[i__5]
.r * temp.i + a[i__5].i * temp.r;
q__2.r = rhs[i__4].r * q__3.r - rhs[i__4].i * q__3.i, q__2.i =
rhs[i__4].r * q__3.i + rhs[i__4].i * q__3.r;
q__1.r = rhs[i__3].r - q__2.r, q__1.i = rhs[i__3].i - q__2.i;
rhs[i__2].r = q__1.r, rhs[i__2].i = q__1.i;
/* L30: */
}
/* L40: */
}
/* Apply permutations JPIV to the solution (RHS) */
i__1 = *n - 1;
claswp_(&c__1, &rhs[1], lda, &c__1, &i__1, &jpiv[1], &c_n1);
return 0;
/* End of CGESC2 */
} /* cgesc2_ */
