void cblas_zgeru(const enum CBLAS_ORDER order, const integer M, const integer N,
const void *alpha, const void *X, const integer incX,
const void *Y, const integer incY, void *A, const integer lda)
{
#define F77_M M
#define F77_N N
#define F77_incX incX
#define F77_incY incY
#define F77_lda lda
extern integer CBLAS_CallFromC;
extern integer RowMajorStrg;
RowMajorStrg = 0;
CBLAS_CallFromC = 1;
if (order == CblasColMajor)
{
zgeru_( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A,
&F77_lda);
}
else if (order == CblasRowMajor)
{
RowMajorStrg = 1;
zgeru_( &F77_N, &F77_M, alpha, Y, &F77_incY, X, &F77_incX, A,
&F77_lda);
}
else cblas_xerbla(1, "cblas_zgeru", "Illegal Order setting, %d\n", order);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
int
f2c_zgeru(integer* M, integer* N,
doublecomplex* alpha,
doublecomplex* X, integer* incX,
doublecomplex* Y, integer* incY,
doublecomplex* A, integer* lda)
{
zgeru_(M, N, alpha,
X, incX, Y, incY, A, lda);
return 0;
}
/* Subroutine */ int zgetf2_(integer *m, integer *n, doublecomplex *a,
integer *lda, integer *ipiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, j, jp;
doublereal sfmin;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgeru_(integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *), zswap_(integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer izamax_(integer *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGETF2 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*16 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_("ZGETF2", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Compute machine safe minimum */
sfmin = dlamch_("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 + izamax_(&i__2, &a[j + j * a_dim1], &c__1);
ipiv[j] = jp;
i__2 = jp + j * a_dim1;
if (a[i__2].r != 0. || a[i__2].i != 0.) {
/* Apply the interchange to columns 1:N. */
if (jp != j) {
zswap_(n, &a[j + a_dim1], lda, &a[jp + a_dim1], lda);
}
/* Compute elements J+1:M of J-th column. */
if (j < *m) {
if (z_abs(&a[j + j * a_dim1]) >= sfmin) {
i__2 = *m - j;
z_div(&z__1, &c_b1, &a[j + j * a_dim1]);
zscal_(&i__2, &z__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;
z_div(&z__1, &a[j + i__ + j * a_dim1], &a[j + j *
a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__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;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__2, &i__3, &z__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 ZGETF2 */
} /* zgetf2_ */
/* Subroutine */ int zlatzm_(char *side, integer *m, integer *n,
doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
c1, doublecomplex *c2, integer *ldc, doublecomplex *work)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLATZM applies a Householder matrix generated by ZTZRQF 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*16 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*16
The value tau in the representation of P.
C1 (input/output) COMPLEX*16 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*16 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*16 array, dimension
(N) if SIDE = 'L'
(M) if SIDE = 'R'
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
doublecomplex z__1;
/* Local variables */
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
, zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), zlacgv_(integer *,
doublecomplex *, integer *);
#define V(I) v[(I)-1]
#define WORK(I) work[(I)-1]
#define C2(I,J) c2[(I)-1 + ((J)-1)* ( *ldc)]
#define C1(I,J) c1[(I)-1 + ((J)-1)* ( *ldc)]
if (min(*m,*n) == 0 || tau->r == 0. && tau->i == 0.) {
return 0;
}
if (lsame_(side, "L")) {
/* w := conjg( C1 + v' * C2 ) */
zcopy_(n, &C1(1,1), ldc, &WORK(1), &c__1);
zlacgv_(n, &WORK(1), &c__1);
i__1 = *m - 1;
zgemv_("Conjugate transpose", &i__1, n, &c_b1, &C2(1,1), ldc, &
V(1), incv, &c_b1, &WORK(1), &c__1);
/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
[ C2 ] [ C2 ] [ v ] */
zlacgv_(n, &WORK(1), &c__1);
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(n, &z__1, &WORK(1), &c__1, &C1(1,1), ldc);
i__1 = *m - 1;
z__1.r = -tau->r, z__1.i = -tau->i;
zgeru_(&i__1, n, &z__1, &V(1), incv, &WORK(1), &c__1, &C2(1,1),
ldc);
} else if (lsame_(side, "R")) {
/* w := C1 + C2 * v */
zcopy_(m, &C1(1,1), &c__1, &WORK(1), &c__1);
i__1 = *n - 1;
zgemv_("No transpose", m, &i__1, &c_b1, &C2(1,1), ldc, &V(1),
incv, &c_b1, &WORK(1), &c__1);
/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(m, &z__1, &WORK(1), &c__1, &C1(1,1), &c__1);
i__1 = *n - 1;
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, &i__1, &z__1, &WORK(1), &c__1, &V(1), incv, &C2(1,1),
ldc);
}
return 0;
/* End of ZLATZM */
} /* zlatzm_ */
/* Subroutine */ int zgetc2_(integer *n, doublecomplex *a, integer *lda,
integer *ipiv, integer *jpiv, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__, j, ip, jp;
static doublereal eps;
static integer ipv, jpv;
static doublereal smin, xmax;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), dlabad_(doublereal *,
doublereal *);
extern doublereal dlamch_(char *, ftnlen);
static doublereal bignum, smlnum;
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGETC2 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*16 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Set constants to control overflow */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipiv;
--jpiv;
/* Function Body */
*info = 0;
eps = dlamch_("P", (ftnlen)1);
smlnum = dlamch_("S", (ftnlen)1) / eps;
bignum = 1. / smlnum;
dlabad_(&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.;
i__2 = *n;
for (ip = i__; ip <= i__2; ++ip) {
i__3 = *n;
for (jp = i__; jp <= i__3; ++jp) {
if (z_abs(&a[ip + jp * a_dim1]) >= xmax) {
xmax = z_abs(&a[ip + jp * a_dim1]);
ipv = ip;
jpv = jp;
}
/* L10: */
}
/* L20: */
}
if (i__ == 1) {
/* Computing MAX */
d__1 = eps * xmax;
smin = max(d__1,smlnum);
}
/* Swap rows */
if (ipv != i__) {
zswap_(n, &a[ipv + a_dim1], lda, &a[i__ + a_dim1], lda);
}
ipiv[i__] = ipv;
/* Swap columns */
if (jpv != i__) {
zswap_(n, &a[jpv * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], &
c__1);
}
jpiv[i__] = jpv;
/* Check for singularity */
if (z_abs(&a[i__ + i__ * a_dim1]) < smin) {
*info = i__;
i__2 = i__ + i__ * a_dim1;
z__1.r = smin, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
i__2 = *n;
for (j = i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
z_div(&z__1, &a[j + i__ * a_dim1], &a[i__ + i__ * a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L30: */
}
i__2 = *n - i__;
i__3 = *n - i__;
zgeru_(&i__2, &i__3, &c_b10, &a[i__ + 1 + i__ * a_dim1], &c__1, &a[
i__ + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + (i__ + 1) *
a_dim1], lda);
/* L40: */
}
if (z_abs(&a[*n + *n * a_dim1]) < smin) {
*info = *n;
i__1 = *n + *n * a_dim1;
z__1.r = smin, z__1.i = 0.;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
}
return 0;
/* End of ZGETC2 */
} /* zgetc2_ */
void
zgeru(int m, int n, doublecomplex *alpha, doublecomplex *x, int incx, doublecomplex *y, int incy, doublecomplex *a, int lda)
{
zgeru_( &m, &n, alpha, x, &incx, y, &incy, a, &lda);
}
/* Subroutine */ int zlavsy_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv,
doublecomplex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
static integer j, k;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
, zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static doublecomplex t1, t2, d11, d12, d21, d22;
static integer kp;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical nounit;
#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)]
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZLAVSY performs one of the matrix-vector operations
x := A*x or x := A'*x,
where x is an N element vector and A is one of the factors
from the symmetric factorization computed by ZSYTRF.
ZSYTRF produces a factorization of the form
U * D * U' or L * D * L' ,
where U (or L) is a product of permutation and unit upper (lower)
triangular matrices, U' (or L') 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 in the leading upper or lower triangle of the 2-D
array A.
If TRANS = 'N' or 'n', ZLAVSY multiplies either by U or U * D
(or L or L * D).
If TRANS = 'T' or 't', ZLAVSY multiplies either by U' or D * U'
(or L' or D * L' ).
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'*x.
Unchanged on exit.
DIAG - CHARACTER*1
On entry, DIAG specifies whether the diagonal blocks are
assumed to be unit matrices:
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*16 array, dimension( LDA, N )
On entry, A contains a block diagonal matrix and the
multipliers of the transformations used to obtain it,
stored as a 2-D triangular matrix.
Unchanged on exit.
LDA - INTEGER
On entry, LDA specifies the first dimension of A as declared
in the calling ( sub ) program. LDA must be at least
max( 1, N ).
Unchanged on exit.
IPIV - INTEGER array, dimension( N )
On entry, IPIV contains the vector of pivot indices as
determined by ZSYTRF or ZHETRF.
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*16 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.
=====================================================================
Test the input parameters.
Parameter adjustments */
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;
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 (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLAVSY ", &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;
L10:
if (k > *n) {
goto L30;
}
if (ipiv[k] > 0) {
/* 1 x 1 pivot block
Multiply by the diagonal element if forming U * D. */
if (nounit) {
zscal_(nrhs, &a_ref(k, k), &b_ref(k, 1), ldb);
}
/* Multiply by P(K) * inv(U(K)) if K > 1. */
if (k > 1) {
/* Apply the transformation. */
i__1 = k - 1;
zgeru_(&i__1, nrhs, &c_b1, &a_ref(1, k), &c__1, &b_ref(k,
1), ldb, &b_ref(1, 1), ldb);
/* Interchange if P(K) != I. */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
}
++k;
} else {
/* 2 x 2 pivot block
Multiply by the diagonal block if forming U * D. */
if (nounit) {
i__1 = a_subscr(k, k);
d11.r = a[i__1].r, d11.i = a[i__1].i;
i__1 = a_subscr(k + 1, k + 1);
d22.r = a[i__1].r, d22.i = a[i__1].i;
i__1 = a_subscr(k, 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 = b_subscr(k, j);
t1.r = b[i__2].r, t1.i = b[i__2].i;
i__2 = b_subscr(k + 1, j);
t2.r = b[i__2].r, t2.i = b[i__2].i;
i__2 = b_subscr(k, j);
z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
t1.i + d11.i * t1.r;
z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
t2.i + d12.i * t2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(k + 1, j);
z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
t1.i + d21.i * t1.r;
z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
t2.i + d22.i * t2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L20: */
}
}
/* Multiply by P(K) * inv(U(K)) if K > 1. */
if (k > 1) {
/* Apply the transformations. */
i__1 = k - 1;
zgeru_(&i__1, nrhs, &c_b1, &a_ref(1, k), &c__1, &b_ref(k,
1), ldb, &b_ref(1, 1), ldb);
i__1 = k - 1;
zgeru_(&i__1, nrhs, &c_b1, &a_ref(1, k + 1), &c__1, &
b_ref(k + 1, 1), ldb, &b_ref(1, 1), ldb);
/* Interchange if P(K) != I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k) {
zswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
}
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;
L40:
if (k < 1) {
goto L60;
}
/* 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) {
zscal_(nrhs, &a_ref(k, k), &b_ref(k, 1), ldb);
}
/* Multiply by P(K) * inv(L(K)) if K < N. */
if (k != *n) {
kp = ipiv[k];
/* Apply the transformation. */
i__1 = *n - k;
zgeru_(&i__1, nrhs, &c_b1, &a_ref(k + 1, k), &c__1, &
b_ref(k, 1), ldb, &b_ref(k + 1, 1), ldb);
/* Interchange if a permutation was applied at the
K-th step of the factorization. */
if (kp != k) {
zswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
}
--k;
} else {
/* 2 x 2 pivot block:
Multiply by the diagonal block if forming L * D. */
if (nounit) {
i__1 = a_subscr(k - 1, k - 1);
d11.r = a[i__1].r, d11.i = a[i__1].i;
i__1 = a_subscr(k, k);
d22.r = a[i__1].r, d22.i = a[i__1].i;
i__1 = a_subscr(k, k - 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 = b_subscr(k - 1, j);
t1.r = b[i__2].r, t1.i = b[i__2].i;
i__2 = b_subscr(k, j);
t2.r = b[i__2].r, t2.i = b[i__2].i;
i__2 = b_subscr(k - 1, j);
z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
t1.i + d11.i * t1.r;
z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
t2.i + d12.i * t2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(k, j);
z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
t1.i + d21.i * t1.r;
z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
t2.i + d22.i * t2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L50: */
}
}
/* Multiply by P(K) * inv(L(K)) if K < N. */
if (k != *n) {
/* Apply the transformation. */
i__1 = *n - k;
zgeru_(&i__1, nrhs, &c_b1, &a_ref(k + 1, k), &c__1, &
b_ref(k, 1), ldb, &b_ref(k + 1, 1), ldb);
i__1 = *n - k;
zgeru_(&i__1, nrhs, &c_b1, &a_ref(k + 1, k - 1), &c__1, &
b_ref(k - 1, 1), ldb, &b_ref(k + 1, 1), 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) {
zswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
}
k += -2;
}
goto L40;
L60:
;
}
/* ----------------------------------------
Compute B := A' * B (transpose)
---------------------------------------- */
} else if (lsame_(trans, "T")) {
/* Form B := U'*B
where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m) */
if (lsame_(uplo, "U")) {
/* Loop backward applying the transformations. */
k = *n;
L70:
if (k < 1) {
goto L90;
}
/* 1 x 1 pivot block. */
if (ipiv[k] > 0) {
if (k > 1) {
/* Interchange if P(K) != I. */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Apply the transformation */
i__1 = k - 1;
zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
&a_ref(1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
}
if (nounit) {
zscal_(nrhs, &a_ref(k, k), &b_ref(k, 1), ldb);
}
--k;
/* 2 x 2 pivot block. */
} else {
if (k > 2) {
/* Interchange if P(K) != I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k - 1) {
zswap_(nrhs, &b_ref(k - 1, 1), ldb, &b_ref(kp, 1),
ldb);
}
/* Apply the transformations */
i__1 = k - 2;
zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
&a_ref(1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
i__1 = k - 2;
zgemv_("Transpose", &i__1, nrhs, &c_b1, &b[b_offset], ldb,
&a_ref(1, k - 1), &c__1, &c_b1, &b_ref(k - 1, 1),
ldb);
}
/* Multiply by the diagonal block if non-unit. */
if (nounit) {
i__1 = a_subscr(k - 1, k - 1);
d11.r = a[i__1].r, d11.i = a[i__1].i;
i__1 = a_subscr(k, k);
d22.r = a[i__1].r, d22.i = a[i__1].i;
i__1 = a_subscr(k - 1, k);
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 = b_subscr(k - 1, j);
t1.r = b[i__2].r, t1.i = b[i__2].i;
i__2 = b_subscr(k, j);
t2.r = b[i__2].r, t2.i = b[i__2].i;
i__2 = b_subscr(k - 1, j);
z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
t1.i + d11.i * t1.r;
z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
t2.i + d12.i * t2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(k, j);
z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
t1.i + d21.i * t1.r;
z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
t2.i + d22.i * t2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L80: */
}
}
k += -2;
}
goto L70;
L90:
/* Form B := L'*B
where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1) */
;
} else {
/* Loop forward applying the L-transformations. */
k = 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) {
zswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
/* Apply the transformation */
i__1 = *n - k;
zgemv_("Transpose", &i__1, nrhs, &c_b1, &b_ref(k + 1, 1),
ldb, &a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k, 1),
ldb);
}
if (nounit) {
zscal_(nrhs, &a_ref(k, k), &b_ref(k, 1), ldb);
}
++k;
/* 2 x 2 pivot block. */
} else {
if (k < *n - 1) {
/* Interchange if P(K) != I. */
kp = (i__1 = ipiv[k], abs(i__1));
if (kp != k + 1) {
zswap_(nrhs, &b_ref(k + 1, 1), ldb, &b_ref(kp, 1),
ldb);
}
/* Apply the transformation */
i__1 = *n - k - 1;
zgemv_("Transpose", &i__1, nrhs, &c_b1, &b_ref(k + 2, 1),
ldb, &a_ref(k + 2, k + 1), &c__1, &c_b1, &b_ref(k
+ 1, 1), ldb);
i__1 = *n - k - 1;
zgemv_("Transpose", &i__1, nrhs, &c_b1, &b_ref(k + 2, 1),
ldb, &a_ref(k + 2, k), &c__1, &c_b1, &b_ref(k, 1),
ldb);
}
/* Multiply by the diagonal block if non-unit. */
if (nounit) {
i__1 = a_subscr(k, k);
d11.r = a[i__1].r, d11.i = a[i__1].i;
i__1 = a_subscr(k + 1, k + 1);
d22.r = a[i__1].r, d22.i = a[i__1].i;
i__1 = a_subscr(k + 1, k);
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 = b_subscr(k, j);
t1.r = b[i__2].r, t1.i = b[i__2].i;
i__2 = b_subscr(k + 1, j);
t2.r = b[i__2].r, t2.i = b[i__2].i;
i__2 = b_subscr(k, j);
z__2.r = d11.r * t1.r - d11.i * t1.i, z__2.i = d11.r *
t1.i + d11.i * t1.r;
z__3.r = d12.r * t2.r - d12.i * t2.i, z__3.i = d12.r *
t2.i + d12.i * t2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(k + 1, j);
z__2.r = d21.r * t1.r - d21.i * t1.i, z__2.i = d21.r *
t1.i + d21.i * t1.r;
z__3.r = d22.r * t2.r - d22.i * t2.i, z__3.i = d22.r *
t2.i + d22.i * t2.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L110: */
}
}
k += 2;
}
goto L100;
L120:
;
}
}
return 0;
/* End of ZLAVSY */
} /* zlavsy_ */
static void pzgstrf2
/************************************************************************/
(
superlu_options_t_Distributed *options,
int_t k, double thresh, Glu_persist_t *Glu_persist, gridinfo_t *grid,
LocalLU_t *Llu, SuperLUStat_t *stat, int* info
)
/*
* Purpose
* =======
* Factor diagonal and subdiagonal blocks and test for exact singularity.
* Only the process column that owns block column *k* participates
* in the work.
*
* Arguments
* =========
*
* k (input) int (global)
* The column number of the block column to be factorized.
*
* thresh (input) double (global)
* The threshold value = s_eps * anorm.
*
* Glu_persist (input) Glu_persist_t*
* Global data structures (xsup, supno) replicated on all processes.
*
* grid (input) gridinfo_t*
* The 2D process mesh.
*
* Llu (input/output) LocalLU_t*
* Local data structures to store distributed L and U matrices.
*
* stat (output) SuperLUStat_t*
* Record the statistics about the factorization.
* See SuperLUStat_t structure defined in util.h.
*
* info (output) int*
* = 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.
*
*/
{
int c, iam, l, pkk;
int incx = 1, incy = 1;
int nsupr; /* number of rows in the block (LDA) */
int luptr;
int_t i, krow, j, jfst, jlst;
int_t nsupc; /* number of columns in the block */
int_t *xsup = Glu_persist->xsup;
doublecomplex *lusup, temp;
doublecomplex *ujrow;
doublecomplex one = {1.0, 0.0}, alpha = {-1.0, 0.0};
*info = 0;
/* Quick return. */
/* Initialization. */
iam = grid->iam;
krow = PROW( k, grid );
pkk = PNUM( PROW(k, grid), PCOL(k, grid), grid );
j = LBj( k, grid ); /* Local block number */
jfst = FstBlockC( k );
jlst = FstBlockC( k+1 );
lusup = Llu->Lnzval_bc_ptr[j];
nsupc = SuperSize( k );
if ( Llu->Lrowind_bc_ptr[j] ) nsupr = Llu->Lrowind_bc_ptr[j][1];
ujrow = Llu->ujrow;
luptr = 0; /* Point to the diagonal entries. */
c = nsupc;
for (j = 0; j < jlst - jfst; ++j) {
/* Broadcast the j-th row (nsupc - j) elements to
the process column. */
if ( iam == pkk ) { /* Diagonal process. */
i = luptr;
if ( options->ReplaceTinyPivot == YES ) {
if ( z_abs1(&lusup[i]) < thresh ) { /* Diagonal */
#if ( PRNTlevel>=2 )
printf("(%d) .. col %d, tiny pivot %e ",
iam, jfst+j, lusup[i]);
#endif
/* Keep the replaced diagonal with the same sign. */
if ( lusup[i].r < 0 ) lusup[i].r = -thresh;
else lusup[i].r = thresh;
lusup[i].i = 0.0;
#if ( PRNTlevel>=2 )
printf("replaced by %e\n", lusup[i]);
#endif
++stat->TinyPivots;
}
}
for (l = 0; l < c; ++l, i += nsupr) ujrow[l] = lusup[i];
}
#if 0
dbcast_col(ujrow, c, pkk, UjROW, grid, &c);
#else
MPI_Bcast(ujrow, c, SuperLU_MPI_DOUBLE_COMPLEX, krow,
(grid->cscp).comm);
/*bcast_tree(ujrow, c, SuperLU_MPI_DOUBLE_COMPLEX, krow,
(24*k+j)%NTAGS, grid, COMM_COLUMN, &c);*/
#endif
#if ( DEBUGlevel>=2 )
if ( k == 3329 && j == 2 ) {
if ( iam == pkk ) {
printf("..(%d) k %d, j %d: Send ujrow[0] %e\n",iam,k,j,ujrow[0]);
} else {
printf("..(%d) k %d, j %d: Recv ujrow[0] %e\n",iam,k,j,ujrow[0]);
}
}
#endif
if ( !lusup ) { /* Empty block column. */
--c;
if ( ujrow[0].r == 0.0 && ujrow[0].i == 0.0 ) *info = j+jfst+1;
continue;
}
/* Test for singularity. */
if ( ujrow[0].r == 0.0 && ujrow[0].i == 0.0 ) {
*info = j+jfst+1;
} else {
/* Scale the j-th column of the matrix. */
z_div(&temp, &one, &ujrow[0]);
if ( iam == pkk ) {
for (i = luptr+1; i < luptr-j+nsupr; ++i)
zz_mult(&lusup[i], &lusup[i], &temp);
stat->ops[FACT] += 6*(nsupr-j-1) + 10;
} else {
for (i = luptr; i < luptr+nsupr; ++i)
zz_mult(&lusup[i], &lusup[i], &temp);
stat->ops[FACT] += 6*nsupr + 10;
}
}
/* Rank-1 update of the trailing submatrix. */
if ( --c ) {
if ( iam == pkk ) {
l = nsupr - j - 1;
#ifdef _CRAY
CGERU(&l, &c, &alpha, &lusup[luptr+1], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr+1], &nsupr);
#else
zgeru_(&l, &c, &alpha, &lusup[luptr+1], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr+1], &nsupr);
#endif
stat->ops[FACT] += 8 * l * c;
} else {
#ifdef _CRAY
CGERU(&nsupr, &c, &alpha, &lusup[luptr], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr], &nsupr);
#else
zgeru_(&nsupr, &c, &alpha, &lusup[luptr], &incx,
&ujrow[1], &incy, &lusup[luptr+nsupr], &nsupr);
#endif
stat->ops[FACT] += 8 * nsupr * c;
}
}
/* Move to the next column. */
if ( iam == pkk ) luptr += nsupr + 1;
else luptr += nsupr;
} /* for j ... */
} /* PZGSTRF2 */
/* Subroutine */ int zgbtrs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, doublecomplex *ab, integer *ldab, integer *ipiv,
doublecomplex *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
=======
ZGBTRS 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 ZGBTRF.
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*16 array, dimension (LDAB,N)
Details of the LU factorization of the band matrix A, as
computed by ZGBTRF. 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*16 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 doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Local variables */
static integer i__, j, l;
extern logical lsame_(char *, char *);
static logical lnoti;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
, zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), ztbsv_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer kd, lm;
extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
integer *, doublecomplex *, 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_("ZGBTRS", &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) {
zswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb);
}
z__1.r = -1., z__1.i = 0.;
zgeru_(&lm, nrhs, &z__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;
ztbsv_("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;
ztbsv_("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);
z__1.r = -1., z__1.i = 0.;
zgemv_("Transpose", &lm, nrhs, &z__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) {
zswap_(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;
ztbsv_("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);
zlacgv_(nrhs, &b_ref(j, 1), ldb);
z__1.r = -1., z__1.i = 0.;
zgemv_("Conjugate transpose", &lm, nrhs, &z__1, &b_ref(j + 1,
1), ldb, &ab_ref(kd + 1, j), &c__1, &c_b1, &b_ref(j,
1), ldb);
zlacgv_(nrhs, &b_ref(j, 1), ldb);
l = ipiv[j];
if (l != j) {
zswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb);
}
/* L60: */
}
}
}
return 0;
/* End of ZGBTRS */
} /* zgbtrs_ */
/* Subroutine */ int zsytrs_(char *uplo, integer *n, integer *nrhs,
doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *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
=======
ZSYTRS 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 ZSYTRF.
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*16 array, dimension (LDA,N)
The block diagonal matrix D and the multipliers used to
obtain the factor U or L as computed by ZSYTRF.
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 ZSYTRF.
B (input/output) COMPLEX*16 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 doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static doublecomplex akm1k;
static integer j, k;
extern logical lsame_(char *, char *);
static doublecomplex denom;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical upper;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
static doublecomplex ak, bk;
static integer kp;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublecomplex 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_("ZSYTRS", &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) {
zswap_(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;
z__1.r = -1., z__1.i = 0.;
zgeru_(&i__1, nrhs, &z__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. */
z_div(&z__1, &c_b1, &a_ref(k, k));
zscal_(nrhs, &z__1, &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) {
zswap_(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;
z__1.r = -1., z__1.i = 0.;
zgeru_(&i__1, nrhs, &z__1, &a_ref(1, k), &c__1, &b_ref(k, 1), ldb,
&b_ref(1, 1), ldb);
i__1 = k - 2;
z__1.r = -1., z__1.i = 0.;
zgeru_(&i__1, nrhs, &z__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;
z_div(&z__1, &a_ref(k - 1, k - 1), &akm1k);
akm1.r = z__1.r, akm1.i = z__1.i;
z_div(&z__1, &a_ref(k, k), &akm1k);
ak.r = z__1.r, ak.i = z__1.i;
z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
akm1.i * ak.r;
z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.;
denom.r = z__1.r, denom.i = z__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
z_div(&z__1, &b_ref(k - 1, j), &akm1k);
bkm1.r = z__1.r, bkm1.i = z__1.i;
z_div(&z__1, &b_ref(k, j), &akm1k);
bk.r = z__1.r, bk.i = z__1.i;
i__2 = b_subscr(k - 1, j);
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(k, j);
z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
bk.i + akm1.i * bk.r;
z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__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;
z__1.r = -1., z__1.i = 0.;
zgemv_("Transpose", &i__1, nrhs, &z__1, &b[b_offset], ldb, &a_ref(
1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(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. */
i__1 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("Transpose", &i__1, nrhs, &z__1, &b[b_offset], ldb, &a_ref(
1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = 0.;
zgemv_("Transpose", &i__1, nrhs, &z__1, &b[b_offset], ldb, &a_ref(
1, k + 1), &c__1, &c_b1, &b_ref(k + 1, 1), ldb)
;
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
zswap_(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) {
zswap_(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;
z__1.r = -1., z__1.i = 0.;
zgeru_(&i__1, nrhs, &z__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. */
z_div(&z__1, &c_b1, &a_ref(k, k));
zscal_(nrhs, &z__1, &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) {
zswap_(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;
z__1.r = -1., z__1.i = 0.;
zgeru_(&i__1, nrhs, &z__1, &a_ref(k + 2, k), &c__1, &b_ref(k,
1), ldb, &b_ref(k + 2, 1), ldb);
i__1 = *n - k - 1;
z__1.r = -1., z__1.i = 0.;
zgeru_(&i__1, nrhs, &z__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;
z_div(&z__1, &a_ref(k, k), &akm1k);
akm1.r = z__1.r, akm1.i = z__1.i;
z_div(&z__1, &a_ref(k + 1, k + 1), &akm1k);
ak.r = z__1.r, ak.i = z__1.i;
z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
akm1.i * ak.r;
z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.;
denom.r = z__1.r, denom.i = z__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
z_div(&z__1, &b_ref(k, j), &akm1k);
bkm1.r = z__1.r, bkm1.i = z__1.i;
z_div(&z__1, &b_ref(k + 1, j), &akm1k);
bk.r = z__1.r, bk.i = z__1.i;
i__2 = b_subscr(k, j);
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = b_subscr(k + 1, j);
z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
bk.i + akm1.i * bk.r;
z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__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;
z__1.r = -1., z__1.i = 0.;
zgemv_("Transpose", &i__1, nrhs, &z__1, &b_ref(k + 1, 1), ldb,
&a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(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) {
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("Transpose", &i__1, nrhs, &z__1, &b_ref(k + 1, 1), ldb,
&a_ref(k + 1, k), &c__1, &c_b1, &b_ref(k, 1), ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = 0.;
zgemv_("Transpose", &i__1, nrhs, &z__1, &b_ref(k + 1, 1), ldb,
&a_ref(k + 1, k - 1), &c__1, &c_b1, &b_ref(k - 1, 1),
ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
zswap_(nrhs, &b_ref(k, 1), ldb, &b_ref(kp, 1), ldb);
}
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of ZSYTRS */
} /* zsytrs_ */
/* Subroutine */
int zhetrs_rook_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg( doublecomplex *, doublecomplex *);
/* Local variables */
integer j, k;
doublereal s;
doublecomplex ak, bk;
integer kp;
doublecomplex akm1, bkm1, akm1k;
extern logical lsame_(char *, char *);
doublecomplex denom;
extern /* Subroutine */
int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */
int zgeru_(integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *, integer *), zlacgv_(integer *, doublecomplex *, integer *);
/* -- LAPACK computational routine (version 3.5.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2013 */
/* .. 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_("ZHETRS_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**H. */
/* 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)
{
zswap_(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;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgeru_(&i__1, nrhs, &z__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. */
i__1 = k + k * a_dim1;
s = 1. / a[i__1].r;
zdscal_(nrhs, &s, &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)
{
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kp = -ipiv[k - 1];
if (kp != k - 1)
{
zswap_(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;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgeru_(&i__1, nrhs, &z__1, &a[k * a_dim1 + 1], &c__1, &b[k + b_dim1], ldb, &b[b_dim1 + 1], ldb);
i__1 = k - 2;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgeru_(&i__1, nrhs, &z__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
z_div(&z__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k);
akm1.r = z__1.r;
akm1.i = z__1.i; // , expr subst
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &a[k + k * a_dim1], &z__2);
ak.r = z__1.r;
ak.i = z__1.i; // , expr subst
z__2.r = akm1.r * ak.r - akm1.i * ak.i;
z__2.i = akm1.r * ak.i + akm1.i * ak.r; // , expr subst
z__1.r = z__2.r - 1.;
z__1.i = z__2.i - 0.; // , expr subst
denom.r = z__1.r;
denom.i = z__1.i; // , expr subst
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k);
bkm1.r = z__1.r;
bkm1.i = z__1.i; // , expr subst
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &b[k + j * b_dim1], &z__2);
bk.r = z__1.r;
bk.i = z__1.i; // , expr subst
i__2 = k - 1 + j * b_dim1;
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i;
z__3.i = ak.r * bkm1.i + ak.i * bkm1.r; // , expr subst
z__2.r = z__3.r - bk.r;
z__2.i = z__3.i - bk.i; // , expr subst
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r;
b[i__2].i = z__1.i; // , expr subst
i__2 = k + j * b_dim1;
z__3.r = akm1.r * bk.r - akm1.i * bk.i;
z__3.i = akm1.r * bk.i + akm1.i * bk.r; // , expr subst
z__2.r = z__3.r - bkm1.r;
z__2.i = z__3.i - bkm1.i; // , expr subst
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r;
b[i__2].i = z__1.i; // , expr subst
/* L20: */
}
k += -2;
}
goto L10;
L30: /* Next solve U**H *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**H(K)), where U(K) is the transformation */
/* stored in column K of A. */
if (k > 1)
{
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] , ldb, &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k)
{
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
++k;
}
else
{
/* 2 x 2 diagonal block */
/* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation */
/* stored in columns K and K+1 of A. */
if (k > 1)
{
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] , ldb, &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] , ldb, &a[(k + 1) * a_dim1 + 1], &c__1, &c_b1, &b[k + 1 + b_dim1], ldb);
zlacgv_(nrhs, &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)
{
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kp = -ipiv[k + 1];
if (kp != k + 1)
{
zswap_(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**H. */
/* 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)
{
zswap_(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;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgeru_(&i__1, nrhs, &z__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. */
i__1 = k + k * a_dim1;
s = 1. / a[i__1].r;
zdscal_(nrhs, &s, &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)
{
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kp = -ipiv[k + 1];
if (kp != k + 1)
{
zswap_(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;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgeru_(&i__1, nrhs, &z__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;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgeru_(&i__1, nrhs, &z__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
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &a[k + k * a_dim1], &z__2);
akm1.r = z__1.r;
akm1.i = z__1.i; // , expr subst
z_div(&z__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k);
ak.r = z__1.r;
ak.i = z__1.i; // , expr subst
z__2.r = akm1.r * ak.r - akm1.i * ak.i;
z__2.i = akm1.r * ak.i + akm1.i * ak.r; // , expr subst
z__1.r = z__2.r - 1.;
z__1.i = z__2.i - 0.; // , expr subst
denom.r = z__1.r;
denom.i = z__1.i; // , expr subst
i__1 = *nrhs;
for (j = 1;
j <= i__1;
++j)
{
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &b[k + j * b_dim1], &z__2);
bkm1.r = z__1.r;
bkm1.i = z__1.i; // , expr subst
z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k);
bk.r = z__1.r;
bk.i = z__1.i; // , expr subst
i__2 = k + j * b_dim1;
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i;
z__3.i = ak.r * bkm1.i + ak.i * bkm1.r; // , expr subst
z__2.r = z__3.r - bk.r;
z__2.i = z__3.i - bk.i; // , expr subst
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r;
b[i__2].i = z__1.i; // , expr subst
i__2 = k + 1 + j * b_dim1;
z__3.r = akm1.r * bk.r - akm1.i * bk.i;
z__3.i = akm1.r * bk.i + akm1.i * bk.r; // , expr subst
z__2.r = z__3.r - bkm1.r;
z__2.i = z__3.i - bkm1.i; // , expr subst
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r;
b[i__2].i = z__1.i; // , expr subst
/* L70: */
}
k += 2;
}
goto L60;
L80: /* Next solve L**H *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**H(K)), where L(K) is the transformation */
/* stored in column K of A. */
if (k < *n)
{
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, & b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k)
{
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
--k;
}
else
{
/* 2 x 2 diagonal block */
/* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation */
/* stored in columns K-1 and K of A. */
if (k < *n)
{
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, & b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1.;
z__1.i = -0.; // , expr subst
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + b_dim1], ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, & c_b1, &b[k - 1 + b_dim1], ldb);
zlacgv_(nrhs, &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)
{
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kp = -ipiv[k - 1];
if (kp != k - 1)
{
zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of ZHETRS_ROOK */
}
/* ----------------------------------------------------------------------- */
/* Subroutine */ int zneupd_(logical *rvec, char *howmny, logical *select,
doublecomplex *d__, doublecomplex *z__, integer *ldz, doublecomplex *
sigma, doublecomplex *workev, char *bmat, integer *n, char *which,
integer *nev, doublereal *tol, doublecomplex *resid, integer *ncv,
doublecomplex *v, integer *ldv, integer *iparam, integer *ipntr,
doublecomplex *workd, doublecomplex *workl, integer *lworkl,
doublereal *rwork, integer *info, ftnlen howmny_len, ftnlen bmat_len,
ftnlen which_len)
{
/* System generated locals */
integer v_dim1, v_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double d_imag(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
/* Local variables */
static integer j, k, ih, jj, iq, np;
static doublecomplex vl[1];
static integer wr, ibd, ldh, ldq;
static doublereal sep;
static integer irz, mode;
static doublereal eps23;
static integer ierr;
static doublecomplex temp;
static integer iwev;
static char type__[6];
static integer ritz, iheig, ihbds;
static doublereal conds;
static logical reord;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static integer nconv;
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static doublereal rtemp;
static doublecomplex rnorm;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), ivout_(integer *, integer
*, integer *, integer *, char *, ftnlen), ztrmm_(char *, char *,
char *, char *, integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen, ftnlen, ftnlen), zmout_(integer *, integer *, integer *,
doublecomplex *, integer *, integer *, char *, ftnlen), zvout_(
integer *, integer *, doublecomplex *, integer *, char *, ftnlen);
extern doublereal dlapy2_(doublereal *, doublereal *);
extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_(
char *, ftnlen);
extern /* Subroutine */ int zunm2r_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen,
ftnlen);
static integer bounds, invsub, iuptri, msglvl, outncv, numcnv, ishift;
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, ftnlen),
zlahqr_(logical *, logical *, integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, integer *), zngets_(integer *, char *
, integer *, integer *, doublecomplex *, doublecomplex *, ftnlen),
zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *, ftnlen), ztrsen_(
char *, char *, logical *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, integer *, integer *,
ftnlen, ftnlen), ztrevc_(char *, char *, logical *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *, doublecomplex *,
doublereal *, integer *, ftnlen, ftnlen), zdscal_(integer *,
doublereal *, doublecomplex *, integer *);
/* %----------------------------------------------------% */
/* | Include files for debugging and timing information | */
/* %----------------------------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: debug.h SID: 2.3 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %---------------------------------% */
/* | See debug.doc for documentation | */
/* %---------------------------------% */
/* %------------------% */
/* | Scalar Arguments | */
/* %------------------% */
/* %--------------------------------% */
/* | See stat.doc for documentation | */
/* %--------------------------------% */
/* \SCCS Information: @(#) */
/* FILE: stat.h SID: 2.2 DATE OF SID: 11/16/95 RELEASE: 2 */
/* %-----------------% */
/* | Array Arguments | */
/* %-----------------% */
/* %------------% */
/* | Parameters | */
/* %------------% */
/* %---------------% */
/* | Local Scalars | */
/* %---------------% */
/* %----------------------% */
/* | External Subroutines | */
/* %----------------------% */
/* %--------------------% */
/* | External Functions | */
/* %--------------------% */
/* %-----------------------% */
/* | Executable Statements | */
/* %-----------------------% */
/* %------------------------% */
/* | Set default parameters | */
/* %------------------------% */
/* Parameter adjustments */
--workd;
--resid;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--d__;
--rwork;
--workev;
--select;
v_dim1 = *ldv;
v_offset = 1 + v_dim1;
v -= v_offset;
--iparam;
--ipntr;
--workl;
/* Function Body */
msglvl = debug_1.mceupd;
mode = iparam[7];
nconv = iparam[5];
*info = 0;
/* %---------------------------------% */
/* | Get machine dependent constant. | */
/* %---------------------------------% */
eps23 = dlamch_("Epsilon-Machine", (ftnlen)15);
eps23 = pow_dd(&eps23, &c_b5);
/* %-------------------------------% */
/* | Quick return | */
/* | Check for incompatible input | */
/* %-------------------------------% */
ierr = 0;
if (nconv <= 0) {
ierr = -14;
} else if (*n <= 0) {
ierr = -1;
} else if (*nev <= 0) {
ierr = -2;
} else if (*ncv <= *nev || *ncv > *n) {
ierr = -3;
} else if (s_cmp(which, "LM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SM", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which, "LR", (ftnlen)2,
(ftnlen)2) != 0 && s_cmp(which, "SR", (ftnlen)2, (ftnlen)2) != 0
&& s_cmp(which, "LI", (ftnlen)2, (ftnlen)2) != 0 && s_cmp(which,
"SI", (ftnlen)2, (ftnlen)2) != 0) {
ierr = -5;
} else if (*(unsigned char *)bmat != 'I' && *(unsigned char *)bmat != 'G')
{
ierr = -6;
} else /* if(complicated condition) */ {
/* Computing 2nd power */
i__1 = *ncv;
if (*lworkl < i__1 * i__1 * 3 + (*ncv << 2)) {
ierr = -7;
} else if (*(unsigned char *)howmny != 'A' && *(unsigned char *)
howmny != 'P' && *(unsigned char *)howmny != 'S' && *rvec) {
ierr = -13;
} else if (*(unsigned char *)howmny == 'S') {
ierr = -12;
}
}
if (mode == 1 || mode == 2) {
s_copy(type__, "REGULR", (ftnlen)6, (ftnlen)6);
} else if (mode == 3) {
s_copy(type__, "SHIFTI", (ftnlen)6, (ftnlen)6);
} else {
ierr = -10;
}
if (mode == 1 && *(unsigned char *)bmat == 'G') {
ierr = -11;
}
/* %------------% */
/* | Error Exit | */
/* %------------% */
if (ierr != 0) {
*info = ierr;
goto L9000;
}
/* %--------------------------------------------------------% */
/* | Pointer into WORKL for address of H, RITZ, WORKEV, Q | */
/* | etc... and the remaining workspace. | */
/* | Also update pointer to be used on output. | */
/* | Memory is laid out as follows: | */
/* | workl(1:ncv*ncv) := generated Hessenberg matrix | */
/* | workl(ncv*ncv+1:ncv*ncv+ncv) := ritz values | */
/* | workl(ncv*ncv+ncv+1:ncv*ncv+2*ncv) := error bounds | */
/* %--------------------------------------------------------% */
/* %-----------------------------------------------------------% */
/* | The following is used and set by ZNEUPD. | */
/* | workl(ncv*ncv+2*ncv+1:ncv*ncv+3*ncv) := The untransformed | */
/* | Ritz values. | */
/* | workl(ncv*ncv+3*ncv+1:ncv*ncv+4*ncv) := The untransformed | */
/* | error bounds of | */
/* | the Ritz values | */
/* | workl(ncv*ncv+4*ncv+1:2*ncv*ncv+4*ncv) := Holds the upper | */
/* | triangular matrix | */
/* | for H. | */
/* | workl(2*ncv*ncv+4*ncv+1: 3*ncv*ncv+4*ncv) := Holds the | */
/* | associated matrix | */
/* | representation of | */
/* | the invariant | */
/* | subspace for H. | */
/* | GRAND total of NCV * ( 3 * NCV + 4 ) locations. | */
/* %-----------------------------------------------------------% */
ih = ipntr[5];
ritz = ipntr[6];
iq = ipntr[7];
bounds = ipntr[8];
ldh = *ncv;
ldq = *ncv;
iheig = bounds + ldh;
ihbds = iheig + ldh;
iuptri = ihbds + ldh;
invsub = iuptri + ldh * *ncv;
ipntr[9] = iheig;
ipntr[11] = ihbds;
ipntr[12] = iuptri;
ipntr[13] = invsub;
wr = 1;
iwev = wr + *ncv;
/* %-----------------------------------------% */
/* | irz points to the Ritz values computed | */
/* | by _neigh before exiting _naup2. | */
/* | ibd points to the Ritz estimates | */
/* | computed by _neigh before exiting | */
/* | _naup2. | */
/* %-----------------------------------------% */
irz = ipntr[14] + *ncv * *ncv;
ibd = irz + *ncv;
/* %------------------------------------% */
/* | RNORM is B-norm of the RESID(1:N). | */
/* %------------------------------------% */
i__1 = ih + 2;
rnorm.r = workl[i__1].r, rnorm.i = workl[i__1].i;
i__1 = ih + 2;
workl[i__1].r = 0., workl[i__1].i = 0.;
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_neupd: "
"Ritz values passed in from _NAUPD.", (ftnlen)42);
zvout_(&debug_1.logfil, ncv, &workl[ibd], &debug_1.ndigit, "_neupd: "
"Ritz estimates passed in from _NAUPD.", (ftnlen)45);
}
if (*rvec) {
reord = FALSE_;
/* %---------------------------------------------------% */
/* | Use the temporary bounds array to store indices | */
/* | These will be used to mark the select array later | */
/* %---------------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
i__2 = bounds + j - 1;
workl[i__2].r = (doublereal) j, workl[i__2].i = 0.;
select[j] = FALSE_;
/* L10: */
}
/* %-------------------------------------% */
/* | Select the wanted Ritz values. | */
/* | Sort the Ritz values so that the | */
/* | wanted ones appear at the tailing | */
/* | NEV positions of workl(irr) and | */
/* | workl(iri). Move the corresponding | */
/* | error estimates in workl(ibd) | */
/* | accordingly. | */
/* %-------------------------------------% */
np = *ncv - *nev;
ishift = 0;
zngets_(&ishift, which, nev, &np, &workl[irz], &workl[bounds], (
ftnlen)2);
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[irz], &debug_1.ndigit, "_neu"
"pd: Ritz values after calling _NGETS.", (ftnlen)41);
zvout_(&debug_1.logfil, ncv, &workl[bounds], &debug_1.ndigit,
"_neupd: Ritz value indices after calling _NGETS.", (
ftnlen)48);
}
/* %-----------------------------------------------------% */
/* | Record indices of the converged wanted Ritz values | */
/* | Mark the select array for possible reordering | */
/* %-----------------------------------------------------% */
numcnv = 0;
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = irz + *ncv - j;
d__3 = workl[i__2].r;
d__4 = d_imag(&workl[irz + *ncv - j]);
d__1 = eps23, d__2 = dlapy2_(&d__3, &d__4);
rtemp = max(d__1,d__2);
i__2 = bounds + *ncv - j;
jj = (integer) workl[i__2].r;
i__2 = ibd + jj - 1;
d__1 = workl[i__2].r;
d__2 = d_imag(&workl[ibd + jj - 1]);
if (numcnv < nconv && dlapy2_(&d__1, &d__2) <= *tol * rtemp) {
select[jj] = TRUE_;
++numcnv;
if (jj > *nev) {
reord = TRUE_;
}
}
/* L11: */
}
/* %-----------------------------------------------------------% */
/* | Check the count (numcnv) of converged Ritz values with | */
/* | the number (nconv) reported by dnaupd. If these two | */
/* | are different then there has probably been an error | */
/* | caused by incorrect passing of the dnaupd data. | */
/* %-----------------------------------------------------------% */
if (msglvl > 2) {
ivout_(&debug_1.logfil, &c__1, &numcnv, &debug_1.ndigit, "_neupd"
": Number of specified eigenvalues", (ftnlen)39);
ivout_(&debug_1.logfil, &c__1, &nconv, &debug_1.ndigit, "_neupd:"
" Number of \"converged\" eigenvalues", (ftnlen)41);
}
if (numcnv != nconv) {
*info = -15;
goto L9000;
}
/* %-------------------------------------------------------% */
/* | Call LAPACK routine zlahqr to compute the Schur form | */
/* | of the upper Hessenberg matrix returned by ZNAUPD. | */
/* | Make a copy of the upper Hessenberg matrix. | */
/* | Initialize the Schur vector matrix Q to the identity. | */
/* %-------------------------------------------------------% */
i__1 = ldh * *ncv;
zcopy_(&i__1, &workl[ih], &c__1, &workl[iuptri], &c__1);
zlaset_("All", ncv, ncv, &c_b2, &c_b1, &workl[invsub], &ldq, (ftnlen)
3);
zlahqr_(&c_true, &c_true, ncv, &c__1, ncv, &workl[iuptri], &ldh, &
workl[iheig], &c__1, ncv, &workl[invsub], &ldq, &ierr);
zcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
if (ierr != 0) {
*info = -8;
goto L9000;
}
if (msglvl > 1) {
zvout_(&debug_1.logfil, ncv, &workl[iheig], &debug_1.ndigit,
"_neupd: Eigenvalues of H", (ftnlen)24);
zvout_(&debug_1.logfil, ncv, &workl[ihbds], &debug_1.ndigit,
"_neupd: Last row of the Schur vector matrix", (ftnlen)43)
;
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldh, &
debug_1.ndigit, "_neupd: The upper triangular matrix "
, (ftnlen)36);
}
}
if (reord) {
/* %-----------------------------------------------% */
/* | Reorder the computed upper triangular matrix. | */
/* %-----------------------------------------------% */
ztrsen_("None", "V", &select[1], ncv, &workl[iuptri], &ldh, &
workl[invsub], &ldq, &workl[iheig], &nconv, &conds, &sep,
&workev[1], ncv, &ierr, (ftnlen)4, (ftnlen)1);
if (ierr == 1) {
*info = 1;
goto L9000;
}
if (msglvl > 2) {
zvout_(&debug_1.logfil, ncv, &workl[iheig], &debug_1.ndigit,
"_neupd: Eigenvalues of H--reordered", (ftnlen)35);
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[iuptri], &ldq, &
debug_1.ndigit, "_neupd: Triangular matrix after"
" re-ordering", (ftnlen)43);
}
}
}
/* %---------------------------------------------% */
/* | Copy the last row of the Schur basis matrix | */
/* | to workl(ihbds). This vector will be used | */
/* | to compute the Ritz estimates of converged | */
/* | Ritz values. | */
/* %---------------------------------------------% */
zcopy_(ncv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds], &c__1);
/* %--------------------------------------------% */
/* | Place the computed eigenvalues of H into D | */
/* | if a spectral transformation was not used. | */
/* %--------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
zcopy_(&nconv, &workl[iheig], &c__1, &d__[1], &c__1);
}
/* %----------------------------------------------------------% */
/* | Compute the QR factorization of the matrix representing | */
/* | the wanted invariant subspace located in the first NCONV | */
/* | columns of workl(invsub,ldq). | */
/* %----------------------------------------------------------% */
zgeqr2_(ncv, &nconv, &workl[invsub], &ldq, &workev[1], &workev[*ncv +
1], &ierr);
/* %--------------------------------------------------------% */
/* | * Postmultiply V by Q using zunm2r. | */
/* | * Copy the first NCONV columns of VQ into Z. | */
/* | * Postmultiply Z by R. | */
/* | The N by NCONV matrix Z is now a matrix representation | */
/* | of the approximate invariant subspace associated with | */
/* | the Ritz values in workl(iheig). The first NCONV | */
/* | columns of V are now approximate Schur vectors | */
/* | associated with the upper triangular matrix of order | */
/* | NCONV in workl(iuptri). | */
/* %--------------------------------------------------------% */
zunm2r_("Right", "Notranspose", n, ncv, &nconv, &workl[invsub], &ldq,
&workev[1], &v[v_offset], ldv, &workd[*n + 1], &ierr, (ftnlen)
5, (ftnlen)11);
zlacpy_("All", n, &nconv, &v[v_offset], ldv, &z__[z_offset], ldz, (
ftnlen)3);
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
/* %---------------------------------------------------% */
/* | Perform both a column and row scaling if the | */
/* | diagonal element of workl(invsub,ldq) is negative | */
/* | I'm lazy and don't take advantage of the upper | */
/* | triangular form of workl(iuptri,ldq). | */
/* | Note that since Q is orthogonal, R is a diagonal | */
/* | matrix consisting of plus or minus ones. | */
/* %---------------------------------------------------% */
i__2 = invsub + (j - 1) * ldq + j - 1;
if (workl[i__2].r < 0.) {
z__1.r = -1., z__1.i = -0.;
zscal_(&nconv, &z__1, &workl[iuptri + j - 1], &ldq);
z__1.r = -1., z__1.i = -0.;
zscal_(&nconv, &z__1, &workl[iuptri + (j - 1) * ldq], &c__1);
}
/* L20: */
}
if (*(unsigned char *)howmny == 'A') {
/* %--------------------------------------------% */
/* | Compute the NCONV wanted eigenvectors of T | */
/* | located in workl(iuptri,ldq). | */
/* %--------------------------------------------% */
i__1 = *ncv;
for (j = 1; j <= i__1; ++j) {
if (j <= nconv) {
select[j] = TRUE_;
} else {
select[j] = FALSE_;
}
/* L30: */
}
ztrevc_("Right", "Select", &select[1], ncv, &workl[iuptri], &ldq,
vl, &c__1, &workl[invsub], &ldq, ncv, &outncv, &workev[1],
&rwork[1], &ierr, (ftnlen)5, (ftnlen)6);
if (ierr != 0) {
*info = -9;
goto L9000;
}
/* %------------------------------------------------% */
/* | Scale the returning eigenvectors so that their | */
/* | Euclidean norms are all one. LAPACK subroutine | */
/* | ztrevc returns each eigenvector normalized so | */
/* | that the element of largest magnitude has | */
/* | magnitude 1. | */
/* %------------------------------------------------% */
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
rtemp = dznrm2_(ncv, &workl[invsub + (j - 1) * ldq], &c__1);
rtemp = 1. / rtemp;
zdscal_(ncv, &rtemp, &workl[invsub + (j - 1) * ldq], &c__1);
/* %------------------------------------------% */
/* | Ritz estimates can be obtained by taking | */
/* | the inner product of the last row of the | */
/* | Schur basis of H with eigenvectors of T. | */
/* | Note that the eigenvector matrix of T is | */
/* | upper triangular, thus the length of the | */
/* | inner product can be set to j. | */
/* %------------------------------------------% */
i__2 = j;
zdotc_(&z__1, &j, &workl[ihbds], &c__1, &workl[invsub + (j -
1) * ldq], &c__1);
workev[i__2].r = z__1.r, workev[i__2].i = z__1.i;
/* L40: */
}
if (msglvl > 2) {
zcopy_(&nconv, &workl[invsub + *ncv - 1], &ldq, &workl[ihbds],
&c__1);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &
debug_1.ndigit, "_neupd: Last row of the eigenvector"
" matrix for T", (ftnlen)48);
if (msglvl > 3) {
zmout_(&debug_1.logfil, ncv, ncv, &workl[invsub], &ldq, &
debug_1.ndigit, "_neupd: The eigenvector matrix "
"for T", (ftnlen)36);
}
}
/* %---------------------------------------% */
/* | Copy Ritz estimates into workl(ihbds) | */
/* %---------------------------------------% */
zcopy_(&nconv, &workev[1], &c__1, &workl[ihbds], &c__1);
/* %----------------------------------------------% */
/* | The eigenvector matrix Q of T is triangular. | */
/* | Form Z*Q. | */
/* %----------------------------------------------% */
ztrmm_("Right", "Upper", "No transpose", "Non-unit", n, &nconv, &
c_b1, &workl[invsub], &ldq, &z__[z_offset], ldz, (ftnlen)
5, (ftnlen)5, (ftnlen)12, (ftnlen)8);
}
} else {
/* %--------------------------------------------------% */
/* | An approximate invariant subspace is not needed. | */
/* | Place the Ritz values computed ZNAUPD into D. | */
/* %--------------------------------------------------% */
zcopy_(&nconv, &workl[ritz], &c__1, &d__[1], &c__1);
zcopy_(&nconv, &workl[ritz], &c__1, &workl[iheig], &c__1);
zcopy_(&nconv, &workl[bounds], &c__1, &workl[ihbds], &c__1);
}
/* %------------------------------------------------% */
/* | Transform the Ritz values and possibly vectors | */
/* | and corresponding error bounds of OP to those | */
/* | of A*x = lambda*B*x. | */
/* %------------------------------------------------% */
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) == 0) {
if (*rvec) {
zscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
} else {
/* %---------------------------------------% */
/* | A spectral transformation was used. | */
/* | * Determine the Ritz estimates of the | */
/* | Ritz values in the original system. | */
/* %---------------------------------------% */
if (*rvec) {
zscal_(ncv, &rnorm, &workl[ihbds], &c__1);
}
i__1 = *ncv;
for (k = 1; k <= i__1; ++k) {
i__2 = iheig + k - 1;
temp.r = workl[i__2].r, temp.i = workl[i__2].i;
i__2 = ihbds + k - 1;
z_div(&z__2, &workl[ihbds + k - 1], &temp);
z_div(&z__1, &z__2, &temp);
workl[i__2].r = z__1.r, workl[i__2].i = z__1.i;
/* L50: */
}
}
/* %-----------------------------------------------------------% */
/* | * Transform the Ritz values back to the original system. | */
/* | For TYPE = 'SHIFTI' the transformation is | */
/* | lambda = 1/theta + sigma | */
/* | NOTES: | */
/* | *The Ritz vectors are not affected by the transformation. | */
/* %-----------------------------------------------------------% */
if (s_cmp(type__, "SHIFTI", (ftnlen)6, (ftnlen)6) == 0) {
i__1 = nconv;
for (k = 1; k <= i__1; ++k) {
i__2 = k;
z_div(&z__2, &c_b1, &workl[iheig + k - 1]);
z__1.r = z__2.r + sigma->r, z__1.i = z__2.i + sigma->i;
d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
/* L60: */
}
}
if (s_cmp(type__, "REGULR", (ftnlen)6, (ftnlen)6) != 0 && msglvl > 1) {
zvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_neupd: U"
"ntransformed Ritz values.", (ftnlen)34);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Ritz estimates of the untransformed Ritz values.", (
ftnlen)56);
} else if (msglvl > 1) {
zvout_(&debug_1.logfil, &nconv, &d__[1], &debug_1.ndigit, "_neupd: C"
"onverged Ritz values.", (ftnlen)30);
zvout_(&debug_1.logfil, &nconv, &workl[ihbds], &debug_1.ndigit, "_ne"
"upd: Associated Ritz estimates.", (ftnlen)34);
}
/* %-------------------------------------------------% */
/* | Eigenvector Purification step. Formally perform | */
/* | one of inverse subspace iteration. Only used | */
/* | for MODE = 3. See reference 3. | */
/* %-------------------------------------------------% */
if (*rvec && *(unsigned char *)howmny == 'A' && s_cmp(type__, "SHIFTI", (
ftnlen)6, (ftnlen)6) == 0) {
/* %------------------------------------------------% */
/* | Purify the computed Ritz vectors by adding a | */
/* | little bit of the residual vector: | */
/* | T | */
/* | resid(:)*( e s ) / theta | */
/* | NCV | */
/* | where H s = s theta. | */
/* %------------------------------------------------% */
i__1 = nconv;
for (j = 1; j <= i__1; ++j) {
i__2 = iheig + j - 1;
if (workl[i__2].r != 0. || workl[i__2].i != 0.) {
i__2 = j;
z_div(&z__1, &workl[invsub + (j - 1) * ldq + *ncv - 1], &
workl[iheig + j - 1]);
workev[i__2].r = z__1.r, workev[i__2].i = z__1.i;
}
/* L100: */
}
/* %---------------------------------------% */
/* | Perform a rank one update to Z and | */
/* | purify all the Ritz vectors together. | */
/* %---------------------------------------% */
zgeru_(n, &nconv, &c_b1, &resid[1], &c__1, &workev[1], &c__1, &z__[
z_offset], ldz);
}
L9000:
return 0;
/* %---------------% */
/* | End of zneupd| */
/* %---------------% */
} /* zneupd_ */
/* Subroutine */ int zlarz_(char *side, integer *m, integer *n, integer *l,
doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
c__, integer *ldc, doublecomplex *work)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
ZLARZ 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 ZTZRZF.
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*16 array, dimension (1+(L-1)*abs(INCV))
The vector v in the representation of H as returned by
ZTZRZF. V is not used if TAU = 0.
INCV (input) INTEGER
The increment between elements of v. INCV <> 0.
TAU (input) COMPLEX*16
The value tau in the representation of H.
C (input/output) COMPLEX*16 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*16 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
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer c_dim1, c_offset;
doublecomplex z__1;
/* Local variables */
extern logical lsame_(char *, char *);
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
, zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), zlacgv_(integer *,
doublecomplex *, integer *);
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* Function Body */
if (lsame_(side, "L")) {
/* Form H * C */
if (tau->r != 0. || tau->i != 0.) {
/* w( 1:n ) = conjg( C( 1, 1:n ) ) */
zcopy_(n, &c__[c_offset], ldc, &work[1], &c__1);
zlacgv_(n, &work[1], &c__1);
/* w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) ) */
zgemv_("Conjugate transpose", l, n, &c_b1, &c___ref(*m - *l + 1,
1), ldc, &v[1], incv, &c_b1, &work[1], &c__1);
zlacgv_(n, &work[1], &c__1);
/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(n, &z__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 )' ) */
z__1.r = -tau->r, z__1.i = -tau->i;
zgeru_(l, n, &z__1, &v[1], incv, &work[1], &c__1, &c___ref(*m - *
l + 1, 1), ldc);
}
} else {
/* Form C * H */
if (tau->r != 0. || tau->i != 0.) {
/* w( 1:m ) = C( 1:m, 1 ) */
zcopy_(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 ) */
zgemv_("No transpose", m, l, &c_b1, &c___ref(1, *n - *l + 1), ldc,
&v[1], incv, &c_b1, &work[1], &c__1);
/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(m, &z__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 )' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, l, &z__1, &work[1], &c__1, &v[1], incv, &c___ref(1, *n
- *l + 1), ldc);
}
}
return 0;
/* End of ZLARZ */
} /* zlarz_ */
/* Subroutine */ int zgbtrs_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, doublecomplex *ab, integer *ldab, integer *ipiv,
doublecomplex *b, integer *ldb, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Local variables */
integer i__, j, l, kd, lm;
extern logical lsame_(char *, char *);
logical lnoti;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
, zswap_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), ztbsv_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zlacgv_(
integer *, doublecomplex *, integer *);
logical notran;
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZGBTRS 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 ZGBTRF. */
/* 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*16 array, dimension (LDAB,N) */
/* Details of the LU factorization of the band matrix A, as */
/* computed by ZGBTRF. 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*16 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 .. */
/* 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_("ZGBTRS", &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) {
zswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
}
z__1.r = -1., z__1.i = -0.;
zgeru_(&lm, nrhs, &z__1, &ab[kd + 1 + j * ab_dim1], &c__1, &b[
j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb);
/* L10: */
}
}
i__1 = *nrhs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Solve U*X = B, overwriting B with X. */
i__2 = *kl + *ku;
ztbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[
ab_offset], ldab, &b[i__ * b_dim1 + 1], &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;
ztbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset],
ldab, &b[i__ * b_dim1 + 1], &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);
z__1.r = -1., z__1.i = -0.;
zgemv_("Transpose", &lm, nrhs, &z__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) {
zswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], 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;
ztbsv_("Upper", "Conjugate transpose", "Non-unit", n, &i__2, &ab[
ab_offset], ldab, &b[i__ * b_dim1 + 1], &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);
zlacgv_(nrhs, &b[j + b_dim1], ldb);
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &lm, nrhs, &z__1, &b[j + 1 +
b_dim1], ldb, &ab[kd + 1 + j * ab_dim1], &c__1, &c_b1,
&b[j + b_dim1], ldb);
zlacgv_(nrhs, &b[j + b_dim1], ldb);
l = ipiv[j];
if (l != j) {
zswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb);
}
/* L60: */
}
}
}
return 0;
/* End of ZGBTRS */
} /* zgbtrs_ */
/* Subroutine */ int zhptrs_(char *uplo, integer *n, integer *nrhs,
doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb,
integer *info)
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
integer j, k;
doublereal s;
doublecomplex ak, bk;
integer kc, kp;
doublecomplex akm1, bkm1, akm1k;
extern logical lsame_(char *, char *);
doublecomplex denom;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
logical upper;
extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zdscal_(integer *, doublereal *, doublecomplex *,
integer *), zlacgv_(integer *, doublecomplex *, integer *);
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPTRS solves a system of linear equations A*X = B with a complex */
/* Hermitian matrix A stored in packed format using the factorization */
/* A = U*D*U**H or A = L*D*L**H computed by ZHPTRF. */
/* 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. */
/* AP (input) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* The block diagonal matrix D and the multipliers used to */
/* obtain the factor U or L as computed by ZHPTRF, stored as a */
/* packed triangular matrix. */
/* IPIV (input) INTEGER array, dimension (N) */
/* Details of the interchanges and the block structure of D */
/* as determined by ZHPTRF. */
/* B (input/output) COMPLEX*16 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 */
--ap;
--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 (*ldb < max(1,*n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPTRS", &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;
kc = *n * (*n + 1) / 2 + 1;
L10:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L30;
}
kc -= k;
if (ipiv[k] > 0) {
/* 1 x 1 diagonal block */
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(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;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + k - 1;
s = 1. / ap[i__1].r;
zdscal_(nrhs, &s, &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) {
zswap_(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;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, &
b[b_dim1 + 1], ldb);
i__1 = k - 2;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc - (k - 1)], &c__1, &b[k - 1 +
b_dim1], ldb, &b[b_dim1 + 1], ldb);
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + k - 2;
akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
z_div(&z__1, &ap[kc - 1], &akm1k);
akm1.r = z__1.r, akm1.i = z__1.i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &ap[kc + k - 1], &z__2);
ak.r = z__1.r, ak.i = z__1.i;
z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
akm1.i * ak.r;
z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
denom.r = z__1.r, denom.i = z__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k);
bkm1.r = z__1.r, bkm1.i = z__1.i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &b[k + j * b_dim1], &z__2);
bk.r = z__1.r, bk.i = z__1.i;
i__2 = k - 1 + j * b_dim1;
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = k + j * b_dim1;
z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
bk.i + akm1.i * bk.r;
z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L20: */
}
kc = kc - k + 1;
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;
kc = 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) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc += k;
++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) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
i__1 = k - 1;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset]
, ldb, &ap[kc + k], &c__1, &c_b1, &b[k + 1 + b_dim1],
ldb);
zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc = kc + (k << 1) + 1;
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;
kc = 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) {
zswap_(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;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + 1], &c__1, &b[k + b_dim1],
ldb, &b[k + 1 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = kc;
s = 1. / ap[i__1].r;
zdscal_(nrhs, &s, &b[k + b_dim1], ldb);
kc = kc + *n - k + 1;
++k;
} else {
/* 2 x 2 diagonal block */
/* Interchange rows K+1 and -IPIV(K). */
kp = -ipiv[k];
if (kp != k + 1) {
zswap_(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;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + 2], &c__1, &b[k + b_dim1],
ldb, &b[k + 2 + b_dim1], ldb);
i__1 = *n - k - 1;
z__1.r = -1., z__1.i = -0.;
zgeru_(&i__1, nrhs, &z__1, &ap[kc + *n - k + 2], &c__1, &b[k
+ 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
}
/* Multiply by the inverse of the diagonal block. */
i__1 = kc + 1;
akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i;
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &ap[kc], &z__2);
akm1.r = z__1.r, akm1.i = z__1.i;
z_div(&z__1, &ap[kc + *n - k + 1], &akm1k);
ak.r = z__1.r, ak.i = z__1.i;
z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i +
akm1.i * ak.r;
z__1.r = z__2.r - 1., z__1.i = z__2.i - 0.;
denom.r = z__1.r, denom.i = z__1.i;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
d_cnjg(&z__2, &akm1k);
z_div(&z__1, &b[k + j * b_dim1], &z__2);
bkm1.r = z__1.r, bkm1.i = z__1.i;
z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k);
bk.r = z__1.r, bk.i = z__1.i;
i__2 = k + j * b_dim1;
z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r *
bkm1.i + ak.i * bkm1.r;
z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
i__2 = k + 1 + j * b_dim1;
z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r *
bk.i + akm1.i * bk.r;
z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i;
z_div(&z__1, &z__2, &denom);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/* L70: */
}
kc = kc + (*n - k << 1) + 1;
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;
kc = *n * (*n + 1) / 2 + 1;
L90:
/* If K < 1, exit from loop. */
if (k < 1) {
goto L100;
}
kc -= *n - k + 1;
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) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
}
/* Interchange rows K and IPIV(K). */
kp = ipiv[k];
if (kp != k) {
zswap_(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) {
zlacgv_(nrhs, &b[k + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k +
b_dim1], ldb);
zlacgv_(nrhs, &b[k + b_dim1], ldb);
zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
i__1 = *n - k;
z__1.r = -1., z__1.i = -0.;
zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 +
b_dim1], ldb, &ap[kc - (*n - k)], &c__1, &c_b1, &b[k
- 1 + b_dim1], ldb);
zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb);
}
/* Interchange rows K and -IPIV(K). */
kp = -ipiv[k];
if (kp != k) {
zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
}
kc -= *n - k + 2;
k += -2;
}
goto L90;
L100:
;
}
return 0;
/* End of ZHPTRS */
} /* zhptrs_ */
void cblas_zgerc(const enum CBLAS_ORDER order, const integer M, const integer N,
const void *alpha, const void *X, const integer incX,
const void *Y, const integer incY, void *A, const integer lda)
{
#define F77_M M
#define F77_N N
#define F77_incX incX
#define F77_incY incy
#define F77_lda lda
integer n, i, tincy, incy=incY;
double *y=(double *)Y, *yy=(double *)Y, *ty, *st;
extern integer CBLAS_CallFromC;
extern integer RowMajorStrg;
RowMajorStrg = 0;
CBLAS_CallFromC = 1;
if (order == CblasColMajor)
{
zgerc_( &F77_M, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, A,
&F77_lda);
} else if (order == CblasRowMajor)
{
RowMajorStrg = 1;
if (N > 0)
{
n = N << 1;
y = malloc(n*sizeof(double));
ty = y;
if( incY > 0 ) {
i = incY << 1;
tincy = 2;
st= y+n;
} else {
i = incY *(-2);
tincy = -2;
st = y-2;
y +=(n-2);
}
do
{
*y = *yy;
y[1] = -yy[1];
y += tincy ;
yy += i;
}
while (y != st);
y = ty;
incy = 1;
}
else y = (double *) Y;
zgeru_( &F77_N, &F77_M, alpha, y, &F77_incY, X, &F77_incX, A,
&F77_lda);
if(Y!=y)
free(y);
} else cblas_xerbla(1, "cblas_zgerc", "Illegal Order setting, %d\n", order);
CBLAS_CallFromC = 0;
RowMajorStrg = 0;
return;
}
/* Subroutine */ int zlarz_(char *side, integer *m, integer *n, integer *l,
doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
c__, integer *ldc, doublecomplex *work)
{
/* System generated locals */
integer c_dim1, c_offset;
doublecomplex z__1;
/* Local variables */
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZLARZ 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 ZTZRZF. */
/* 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*16 array, dimension (1+(L-1)*abs(INCV)) */
/* The vector v in the representation of H as returned by */
/* ZTZRZF. V is not used if TAU = 0. */
/* INCV (input) INTEGER */
/* The increment between elements of v. INCV <> 0. */
/* TAU (input) COMPLEX*16 */
/* The value tau in the representation of H. */
/* C (input/output) COMPLEX*16 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*16 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 */
/* ===================================================================== */
/* 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. || tau->i != 0.) {
/* w( 1:n ) = conjg( C( 1, 1:n ) ) */
zcopy_(n, &c__[c_offset], ldc, &work[1], &c__1);
zlacgv_(n, &work[1], &c__1);
/* w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) ) */
zgemv_("Conjugate transpose", l, n, &c_b1, &c__[*m - *l + 1 +
c_dim1], ldc, &v[1], incv, &c_b1, &work[1], &c__1);
zlacgv_(n, &work[1], &c__1);
/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(n, &z__1, &work[1], &c__1, &c__[c_offset], ldc);
/* tau * v( 1:l ) * conjg( w( 1:n )' ) */
z__1.r = -tau->r, z__1.i = -tau->i;
zgeru_(l, n, &z__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l +
1 + c_dim1], ldc);
}
} else {
/* Form C * H */
if (tau->r != 0. || tau->i != 0.) {
/* w( 1:m ) = C( 1:m, 1 ) */
zcopy_(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 ) */
zgemv_("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 ) */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(m, &z__1, &work[1], &c__1, &c__[c_offset], &c__1);
/* tau * w( 1:m ) * v( 1:l )' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, l, &z__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l +
1) * c_dim1 + 1], ldc);
}
}
return 0;
/* End of ZLARZ */
} /* zlarz_ */
/* Subroutine */ int zlatzm_(char *side, integer *m, integer *n,
doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex *
c1, doublecomplex *c2, integer *ldc, doublecomplex *work, ftnlen
side_len)
{
/* System generated locals */
integer c1_dim1, c1_offset, c2_dim1, c2_offset, i__1;
doublecomplex z__1;
/* Local variables */
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *, ftnlen),
zgeru_(integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *)
, zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), zlacgv_(integer *,
doublecomplex *, integer *);
/* -- LAPACK routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine ZUNMRZ. */
/* ZLATZM applies a Householder matrix generated by ZTZRQF 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*16 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*16 */
/* The value tau in the representation of P. */
/* C1 (input/output) COMPLEX*16 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*16 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*16 array, dimension */
/* (N) if SIDE = 'L' */
/* (M) if SIDE = 'R' */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c2_dim1 = *ldc;
c2_offset = 1 + c2_dim1;
c2 -= c2_offset;
c1_dim1 = *ldc;
c1_offset = 1 + c1_dim1;
c1 -= c1_offset;
--work;
/* Function Body */
if (min(*m,*n) == 0 || tau->r == 0. && tau->i == 0.) {
return 0;
}
if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
/* w := conjg( C1 + v' * C2 ) */
zcopy_(n, &c1[c1_offset], ldc, &work[1], &c__1);
zlacgv_(n, &work[1], &c__1);
i__1 = *m - 1;
zgemv_("Conjugate transpose", &i__1, n, &c_b1, &c2[c2_offset], ldc, &
v[1], incv, &c_b1, &work[1], &c__1, (ftnlen)19);
/* [ C1 ] := [ C1 ] - tau* [ 1 ] * w' */
/* [ C2 ] [ C2 ] [ v ] */
zlacgv_(n, &work[1], &c__1);
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(n, &z__1, &work[1], &c__1, &c1[c1_offset], ldc);
i__1 = *m - 1;
z__1.r = -tau->r, z__1.i = -tau->i;
zgeru_(&i__1, n, &z__1, &v[1], incv, &work[1], &c__1, &c2[c2_offset],
ldc);
} else if (lsame_(side, "R", (ftnlen)1, (ftnlen)1)) {
/* w := C1 + C2 * v */
zcopy_(m, &c1[c1_offset], &c__1, &work[1], &c__1);
i__1 = *n - 1;
zgemv_("No transpose", m, &i__1, &c_b1, &c2[c2_offset], ldc, &v[1],
incv, &c_b1, &work[1], &c__1, (ftnlen)12);
/* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] */
z__1.r = -tau->r, z__1.i = -tau->i;
zaxpy_(m, &z__1, &work[1], &c__1, &c1[c1_offset], &c__1);
i__1 = *n - 1;
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, &i__1, &z__1, &work[1], &c__1, &v[1], incv, &c2[c2_offset],
ldc);
}
return 0;
/* End of ZLATZM */
} /* zlatzm_ */
