/* Subroutine */ int zspt01_(char *uplo, integer *n, doublecomplex *a,
doublecomplex *afac, integer *ipiv, doublecomplex *c__, integer *ldc,
doublereal *rwork, doublereal *resid)
{
/* System generated locals */
integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5;
doublecomplex z__1;
/* Local variables */
static integer info, i__, j;
extern logical lsame_(char *, char *);
static doublereal anorm;
static integer jc;
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
extern doublereal zlansp_(char *, char *, integer *, doublecomplex *,
doublereal *);
extern /* Subroutine */ int zlavsp_(char *, char *, char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
integer *);
extern doublereal zlansy_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
static doublereal eps;
#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)]
/* -- LAPACK test 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
=======
ZSPT01 reconstructs a symmetric indefinite packed matrix A from its
diagonal pivoting factorization A = U*D*U' or A = L*D*L' and computes
the residual
norm( C - A ) / ( N * norm(A) * EPS ),
where C is the reconstructed matrix and EPS is the machine epsilon.
Arguments
==========
UPLO (input) CHARACTER*1
Specifies whether the upper or lower triangular part of the
Hermitian matrix A is stored:
= 'U': Upper triangular
= 'L': Lower triangular
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The original symmetric matrix A, stored as a packed
triangular matrix.
AFAC (input) COMPLEX*16 array, dimension (N*(N+1)/2)
The factored form of the matrix A, stored as a packed
triangular matrix. AFAC contains the block diagonal matrix D
and the multipliers used to obtain the factor L or U from the
L*D*L' or U*D*U' factorization as computed by ZSPTRF.
IPIV (input) INTEGER array, dimension (N)
The pivot indices from ZSPTRF.
C (workspace) COMPLEX*16 array, dimension (LDC,N)
LDC (integer) INTEGER
The leading dimension of the array C. LDC >= max(1,N).
RWORK (workspace) DOUBLE PRECISION array, dimension (N)
RESID (output) DOUBLE PRECISION
If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
=====================================================================
Quick exit if N = 0.
Parameter adjustments */
--a;
--afac;
--ipiv;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--rwork;
/* Function Body */
if (*n <= 0) {
*resid = 0.;
return 0;
}
/* Determine EPS and the norm of A. */
eps = dlamch_("Epsilon");
anorm = zlansp_("1", uplo, n, &a[1], &rwork[1]);
/* Initialize C to the identity matrix. */
zlaset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc);
/* Call ZLAVSP to form the product D * U' (or D * L' ). */
zlavsp_(uplo, "Transpose", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[
c_offset], ldc, &info);
/* Call ZLAVSP again to multiply by U ( or L ). */
zlavsp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[
c_offset], ldc, &info);
/* Compute the difference C - A . */
if (lsame_(uplo, "U")) {
jc = 0;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
i__5 = jc + i__;
z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L10: */
}
jc += j;
/* L20: */
}
} else {
jc = 1;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
i__5 = jc + i__ - j;
z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[
i__5].i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L30: */
}
jc = jc + *n - j + 1;
/* L40: */
}
}
/* Compute norm( C - A ) / ( N * norm(A) * EPS ) */
*resid = zlansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]);
if (anorm <= 0.) {
if (*resid != 0.) {
*resid = 1. / eps;
}
} else {
*resid = *resid / (doublereal) (*n) / anorm / eps;
}
return 0;
/* End of ZSPT01 */
} /* zspt01_ */
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer
*m, integer *n, complex *a, integer *lda, complex *b, integer *ldb,
complex *c__, integer *ldc, real *scale, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CTRSYL solves the complex Sylvester matrix equation:
op(A)*X + X*op(B) = scale*C or
op(A)*X - X*op(B) = scale*C,
where op(A) = A or A**H, and A and B are both upper triangular. A is
M-by-M and B is N-by-N; the right hand side C and the solution X are
M-by-N; and scale is an output scale factor, set <= 1 to avoid
overflow in X.
Arguments
=========
TRANA (input) CHARACTER*1
Specifies the option op(A):
= 'N': op(A) = A (No transpose)
= 'C': op(A) = A**H (Conjugate transpose)
TRANB (input) CHARACTER*1
Specifies the option op(B):
= 'N': op(B) = B (No transpose)
= 'C': op(B) = B**H (Conjugate transpose)
ISGN (input) INTEGER
Specifies the sign in the equation:
= +1: solve op(A)*X + X*op(B) = scale*C
= -1: solve op(A)*X - X*op(B) = scale*C
M (input) INTEGER
The order of the matrix A, and the number of rows in the
matrices X and C. M >= 0.
N (input) INTEGER
The order of the matrix B, and the number of columns in the
matrices X and C. N >= 0.
A (input) COMPLEX array, dimension (LDA,M)
The upper triangular matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,M).
B (input) COMPLEX array, dimension (LDB,N)
The upper triangular matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
C (input/output) COMPLEX array, dimension (LDC,N)
On entry, the M-by-N right hand side matrix C.
On exit, C is overwritten by the solution matrix X.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M)
SCALE (output) REAL
The scale factor, scale, set <= 1 to avoid overflow in X.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
= 1: A and B have common or very close eigenvalues; perturbed
values were used to solve the equation (but the matrices
A and B are unchanged).
=====================================================================
Decode and Test input parameters
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4;
real r__1, r__2;
complex q__1, q__2, q__3, q__4;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
/* Local variables */
static real smin;
static complex suml, sumr;
static integer j, k, l;
extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer
*, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer
*, complex *, integer *);
static complex a11;
static real db;
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
static complex x11;
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
static real scaloc;
extern doublereal slamch_(char *);
extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer
*), xerbla_(char *, integer *);
static real bignum;
static logical notrna, notrnb;
static real smlnum, da11;
static complex vec;
static real dum[1], eps, sgn;
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
/* Function Body */
notrna = lsame_(trana, "N");
notrnb = lsame_(tranb, "N");
*info = 0;
if (! notrna && ! lsame_(trana, "T") && ! lsame_(
trana, "C")) {
*info = -1;
} else if (! notrnb && ! lsame_(tranb, "T") && !
lsame_(tranb, "C")) {
*info = -2;
} else if (*isgn != 1 && *isgn != -1) {
*info = -3;
} else if (*m < 0) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*m)) {
*info = -7;
} else if (*ldb < max(1,*n)) {
*info = -9;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CTRSYL", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0) {
return 0;
}
/* Set constants to control overflow */
eps = slamch_("P");
smlnum = slamch_("S");
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
smlnum = smlnum * (real) (*m * *n) / eps;
bignum = 1.f / smlnum;
/* Computing MAX */
r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n,
&b[b_offset], ldb, dum);
smin = dmax(r__1,r__2);
*scale = 1.f;
sgn = (real) (*isgn);
if (notrna && notrnb) {
/* Solve A*X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
M L-1
R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)].
I=K+1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__2 = k + 1;
/* Computing MIN */
i__3 = k + 1;
i__4 = *m - k;
cdotu_(&q__1, &i__4, &a_ref(k, min(i__2,*m)), lda, &c___ref(
min(i__3,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__2 = l - 1;
cdotu_(&q__1, &i__2, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i;
q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L10: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L20: */
}
/* L30: */
}
} else if (! notrna && notrnb) {
/* Solve A' *X + ISGN*X*B = scale*C.
The (K,L)th block of X is determined starting from
upper-left corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
Where
K-1 L-1
R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]
I=1 J=1 */
i__1 = *n;
for (l = 1; l <= i__1; ++l) {
i__2 = *m;
for (k = 1; k <= i__2; ++k) {
i__3 = k - 1;
cdotc_(&q__1, &i__3, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
i__3 = l - 1;
cdotu_(&q__1, &i__3, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1)
;
sumr.r = q__1.r, sumr.i = q__1.i;
i__3 = c___subscr(k, l);
q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
r_cnjg(&q__2, &a_ref(k, k));
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L40: */
}
*scale *= scaloc;
}
i__3 = c___subscr(k, l);
c__[i__3].r = x11.r, c__[i__3].i = x11.i;
/* L50: */
}
/* L60: */
}
} else if (! notrna && ! notrnb) {
/* Solve A'*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
upper-right corner column by column by
A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
K-1
R(K,L) = SUM [A'(I,K)*X(I,L)] +
I=1
N
ISGN*SUM [X(K,J)*B'(L,J)].
J=L+1 */
for (l = *n; l >= 1; --l) {
i__1 = *m;
for (k = 1; k <= i__1; ++k) {
i__2 = k - 1;
cdotc_(&q__1, &i__2, &a_ref(1, k), &c__1, &c___ref(1, l), &
c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__2 = l + 1;
/* Computing MIN */
i__3 = l + 1;
i__4 = *n - l;
cdotc_(&q__1, &i__4, &c___ref(k, min(i__2,*n)), ldc, &b_ref(l,
min(i__3,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__2 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__2 = a_subscr(k, k);
i__3 = b_subscr(l, l);
q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i;
q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i;
r_cnjg(&q__1, &q__2);
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L70: */
}
*scale *= scaloc;
}
i__2 = c___subscr(k, l);
c__[i__2].r = x11.r, c__[i__2].i = x11.i;
/* L80: */
}
/* L90: */
}
} else if (notrna && ! notrnb) {
/* Solve A*X + ISGN*X*B' = C.
The (K,L)th block of X is determined starting from
bottom-left corner column by column by
A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L)
Where
M N
R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)]
I=K+1 J=L+1 */
for (l = *n; l >= 1; --l) {
for (k = *m; k >= 1; --k) {
/* Computing MIN */
i__1 = k + 1;
/* Computing MIN */
i__2 = k + 1;
i__3 = *m - k;
cdotu_(&q__1, &i__3, &a_ref(k, min(i__1,*m)), lda, &c___ref(
min(i__2,*m), l), &c__1);
suml.r = q__1.r, suml.i = q__1.i;
/* Computing MIN */
i__1 = l + 1;
/* Computing MIN */
i__2 = l + 1;
i__3 = *n - l;
cdotc_(&q__1, &i__3, &c___ref(k, min(i__1,*n)), ldc, &b_ref(l,
min(i__2,*n)), ldb);
sumr.r = q__1.r, sumr.i = q__1.i;
i__1 = c___subscr(k, l);
r_cnjg(&q__4, &sumr);
q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i;
q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i;
q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i;
vec.r = q__1.r, vec.i = q__1.i;
scaloc = 1.f;
i__1 = a_subscr(k, k);
r_cnjg(&q__3, &b_ref(l, l));
q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i;
q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i;
a11.r = q__1.r, a11.i = q__1.i;
da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11),
dabs(r__2));
if (da11 <= smin) {
a11.r = smin, a11.i = 0.f;
da11 = smin;
*info = 1;
}
db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs(
r__2));
if (da11 < 1.f && db > 1.f) {
if (db > bignum * da11) {
scaloc = 1.f / db;
}
}
q__3.r = scaloc, q__3.i = 0.f;
q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r *
q__3.i + vec.i * q__3.r;
cladiv_(&q__1, &q__2, &a11);
x11.r = q__1.r, x11.i = q__1.i;
if (scaloc != 1.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
csscal_(m, &scaloc, &c___ref(1, j), &c__1);
/* L100: */
}
*scale *= scaloc;
}
i__1 = c___subscr(k, l);
c__[i__1].r = x11.r, c__[i__1].i = x11.i;
/* L110: */
}
/* L120: */
}
}
return 0;
/* End of CTRSYL */
} /* ctrsyl_ */
/* Subroutine */ int chemm_(char *side, char *uplo, integer *m, integer *n,
complex *alpha, complex *a, integer *lda, complex *b, integer *ldb,
complex *beta, complex *c__, integer *ldc)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4, i__5, i__6;
real r__1;
complex q__1, q__2, q__3, q__4, q__5;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer info;
static complex temp1, temp2;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static integer nrowa;
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
/* Purpose
=======
CHEMM performs one of the matrix-matrix operations
C := alpha*A*B + beta*C,
or
C := alpha*B*A + beta*C,
where alpha and beta are scalars, A is an hermitian matrix and B and
C are m by n matrices.
Parameters
==========
SIDE - CHARACTER*1.
On entry, SIDE specifies whether the hermitian matrix A
appears on the left or right in the operation as follows:
SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
Unchanged on exit.
UPLO - CHARACTER*1.
On entry, UPLO specifies whether the upper or lower
triangular part of the hermitian matrix A is to be
referenced as follows:
UPLO = 'U' or 'u' Only the upper triangular part of the
hermitian matrix is to be referenced.
UPLO = 'L' or 'l' Only the lower triangular part of the
hermitian matrix is to be referenced.
Unchanged on exit.
M - INTEGER.
On entry, M specifies the number of rows of the matrix C.
M must be at least zero.
Unchanged on exit.
N - INTEGER.
On entry, N specifies the number of columns of the matrix C.
N must be at least zero.
Unchanged on exit.
ALPHA - COMPLEX .
On entry, ALPHA specifies the scalar alpha.
Unchanged on exit.
A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is
m when SIDE = 'L' or 'l' and is n otherwise.
Before entry with SIDE = 'L' or 'l', the m by m part of
the array A must contain the hermitian matrix, such that
when UPLO = 'U' or 'u', the leading m by m upper triangular
part of the array A must contain the upper triangular part
of the hermitian matrix and the strictly lower triangular
part of A is not referenced, and when UPLO = 'L' or 'l',
the leading m by m lower triangular part of the array A
must contain the lower triangular part of the hermitian
matrix and the strictly upper triangular part of A is not
referenced.
Before entry with SIDE = 'R' or 'r', the n by n part of
the array A must contain the hermitian matrix, such that
when UPLO = 'U' or 'u', the leading n by n upper triangular
part of the array A must contain the upper triangular part
of the hermitian matrix and the strictly lower triangular
part of A is not referenced, and when UPLO = 'L' or 'l',
the leading n by n lower triangular part of the array A
must contain the lower triangular part of the hermitian
matrix and the strictly upper triangular part of A is not
referenced.
Note that the imaginary parts of the diagonal elements need
not be set, they are assumed to be zero.
Unchanged on exit.
LDA - INTEGER.
On entry, LDA specifies the first dimension of A as declared
in the calling (sub) program. When SIDE = 'L' or 'l' then
LDA must be at least max( 1, m ), otherwise LDA must be at
least max( 1, n ).
Unchanged on exit.
B - COMPLEX array of DIMENSION ( LDB, n ).
Before entry, the leading m by n part of the array B must
contain the matrix B.
Unchanged on exit.
LDB - INTEGER.
On entry, LDB specifies the first dimension of B as declared
in the calling (sub) program. LDB must be at least
max( 1, m ).
Unchanged on exit.
BETA - COMPLEX .
On entry, BETA specifies the scalar beta. When BETA is
supplied as zero then C need not be set on input.
Unchanged on exit.
C - COMPLEX array of DIMENSION ( LDC, n ).
Before entry, the leading m by n part of the array C must
contain the matrix C, except when beta is zero, in which
case C need not be set on entry.
On exit, the array C is overwritten by the m by n updated
matrix.
LDC - INTEGER.
On entry, LDC specifies the first dimension of C as declared
in the calling (sub) program. LDC must be at least
max( 1, m ).
Unchanged on exit.
Level 3 Blas routine.
-- Written on 8-February-1989.
Jack Dongarra, Argonne National Laboratory.
Iain Duff, AERE Harwell.
Jeremy Du Croz, Numerical Algorithms Group Ltd.
Sven Hammarling, Numerical Algorithms Group Ltd.
Set NROWA as the number of rows of A.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
/* Function Body */
if (lsame_(side, "L")) {
nrowa = *m;
} else {
nrowa = *n;
}
upper = lsame_(uplo, "U");
/* Test the input parameters. */
info = 0;
if (! lsame_(side, "L") && ! lsame_(side, "R")) {
info = 1;
} else if (! upper && ! lsame_(uplo, "L")) {
info = 2;
} else if (*m < 0) {
info = 3;
} else if (*n < 0) {
info = 4;
} else if (*lda < max(1,nrowa)) {
info = 7;
} else if (*ldb < max(1,*m)) {
info = 9;
} else if (*ldc < max(1,*m)) {
info = 12;
}
if (info != 0) {
xerbla_("CHEMM ", &info);
return 0;
}
/* Quick return if possible. */
if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r
== 1.f && beta->i == 0.f)) {
return 0;
}
/* And when alpha.eq.zero. */
if (alpha->r == 0.f && alpha->i == 0.f) {
if (beta->r == 0.f && beta->i == 0.f) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
c__[i__3].r = 0.f, c__[i__3].i = 0.f;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
q__1.i = beta->r * c__[i__4].i + beta->i * c__[
i__4].r;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L30: */
}
/* L40: */
}
}
return 0;
}
/* Start the operations. */
if (lsame_(side, "L")) {
/* Form C := alpha*A*B + beta*C. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, j);
q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i,
q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3]
.r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__3 = i__ - 1;
for (k = 1; k <= i__3; ++k) {
i__4 = c___subscr(k, j);
i__5 = c___subscr(k, j);
i__6 = a_subscr(k, i__);
q__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i,
q__2.i = temp1.r * a[i__6].i + temp1.i * a[
i__6].r;
q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
q__2.i;
c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
i__4 = b_subscr(k, j);
r_cnjg(&q__3, &a_ref(k, i__));
q__2.r = b[i__4].r * q__3.r - b[i__4].i * q__3.i,
q__2.i = b[i__4].r * q__3.i + b[i__4].i *
q__3.r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L50: */
}
if (beta->r == 0.f && beta->i == 0.f) {
i__3 = c___subscr(i__, j);
i__4 = a_subscr(i__, i__);
r__1 = a[i__4].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
q__3.i = alpha->r * temp2.i + alpha->i *
temp2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
} else {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, q__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
i__5 = a_subscr(i__, i__);
r__1 = a[i__5].r;
q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i;
q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
q__5.i = alpha->r * temp2.i + alpha->i *
temp2.r;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
}
/* L60: */
}
/* L70: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
for (i__ = *m; i__ >= 1; --i__) {
i__2 = b_subscr(i__, j);
q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i,
q__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2]
.r;
temp1.r = q__1.r, temp1.i = q__1.i;
temp2.r = 0.f, temp2.i = 0.f;
i__2 = *m;
for (k = i__ + 1; k <= i__2; ++k) {
i__3 = c___subscr(k, j);
i__4 = c___subscr(k, j);
i__5 = a_subscr(k, i__);
q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i,
q__2.i = temp1.r * a[i__5].i + temp1.i * a[
i__5].r;
q__1.r = c__[i__4].r + q__2.r, q__1.i = c__[i__4].i +
q__2.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
i__3 = b_subscr(k, j);
r_cnjg(&q__3, &a_ref(k, i__));
q__2.r = b[i__3].r * q__3.r - b[i__3].i * q__3.i,
q__2.i = b[i__3].r * q__3.i + b[i__3].i *
q__3.r;
q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i;
temp2.r = q__1.r, temp2.i = q__1.i;
/* L80: */
}
if (beta->r == 0.f && beta->i == 0.f) {
i__2 = c___subscr(i__, j);
i__3 = a_subscr(i__, i__);
r__1 = a[i__3].r;
q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i;
q__3.r = alpha->r * temp2.r - alpha->i * temp2.i,
q__3.i = alpha->r * temp2.i + alpha->i *
temp2.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
} else {
i__2 = c___subscr(i__, j);
i__3 = c___subscr(i__, j);
q__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3]
.i, q__3.i = beta->r * c__[i__3].i + beta->i *
c__[i__3].r;
i__4 = a_subscr(i__, i__);
r__1 = a[i__4].r;
q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i;
q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i;
q__5.r = alpha->r * temp2.r - alpha->i * temp2.i,
q__5.i = alpha->r * temp2.i + alpha->i *
temp2.r;
q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
c__[i__2].r = q__1.r, c__[i__2].i = q__1.i;
}
/* L90: */
}
/* L100: */
}
}
} else {
/* Form C := alpha*B*A + beta*C. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = a_subscr(j, j);
r__1 = a[i__2].r;
q__1.r = r__1 * alpha->r, q__1.i = r__1 * alpha->i;
temp1.r = q__1.r, temp1.i = q__1.i;
if (beta->r == 0.f && beta->i == 0.f) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = b_subscr(i__, j);
q__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i,
q__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4]
.r;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L110: */
}
} else {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
q__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i,
q__2.i = beta->r * c__[i__4].i + beta->i * c__[
i__4].r;
i__5 = b_subscr(i__, j);
q__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i,
q__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5]
.r;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L120: */
}
}
i__2 = j - 1;
for (k = 1; k <= i__2; ++k) {
if (upper) {
i__3 = a_subscr(k, j);
q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
.r;
temp1.r = q__1.r, temp1.i = q__1.i;
} else {
r_cnjg(&q__2, &a_ref(j, k));
q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
alpha->r * q__2.i + alpha->i * q__2.r;
temp1.r = q__1.r, temp1.i = q__1.i;
}
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = c___subscr(i__, j);
i__5 = c___subscr(i__, j);
i__6 = b_subscr(i__, k);
q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
.r;
q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
q__2.i;
c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
/* L130: */
}
/* L140: */
}
i__2 = *n;
for (k = j + 1; k <= i__2; ++k) {
if (upper) {
r_cnjg(&q__2, &a_ref(j, k));
q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i =
alpha->r * q__2.i + alpha->i * q__2.r;
temp1.r = q__1.r, temp1.i = q__1.i;
} else {
i__3 = a_subscr(k, j);
q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3]
.r;
temp1.r = q__1.r, temp1.i = q__1.i;
}
i__3 = *m;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = c___subscr(i__, j);
i__5 = c___subscr(i__, j);
i__6 = b_subscr(i__, k);
q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i,
q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6]
.r;
q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i +
q__2.i;
c__[i__4].r = q__1.r, c__[i__4].i = q__1.i;
/* L150: */
}
/* L160: */
}
/* L170: */
}
}
return 0;
/* End of CHEMM . */
} /* chemm_ */
/* Subroutine */ int zsyrk_(char *uplo, char *trans, integer *n, integer *k,
doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex *
beta, doublecomplex *c__, integer *ldc)
{
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
doublecomplex z__1, z__2, z__3;
/* Local variables */
static integer info;
static doublecomplex temp;
static integer i__, j, l;
extern logical lsame_(char *, char *);
static integer nrowa;
static logical upper;
extern /* Subroutine */ int xerbla_(char *, integer *);
#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 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)]
/* Purpose
=======
ZSYRK performs one of the symmetric rank k operations
C := alpha*A*A' + beta*C,
or
C := alpha*A'*A + beta*C,
where alpha and beta are scalars, C is an n by n symmetric matrix
and A is an n by k matrix in the first case and a k by n matrix
in the second case.
Parameters
==========
UPLO - CHARACTER*1.
On entry, UPLO specifies whether the upper or lower
triangular part of the array C is to be referenced as
follows:
UPLO = 'U' or 'u' Only the upper triangular part of C
is to be referenced.
UPLO = 'L' or 'l' Only the lower triangular part of C
is to be referenced.
Unchanged on exit.
TRANS - CHARACTER*1.
On entry, TRANS specifies the operation to be performed as
follows:
TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.
TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
Unchanged on exit.
N - INTEGER.
On entry, N specifies the order of the matrix C. N must be
at least zero.
Unchanged on exit.
K - INTEGER.
On entry with TRANS = 'N' or 'n', K specifies the number
of columns of the matrix A, and on entry with
TRANS = 'T' or 't', K specifies the number of rows of the
matrix A. K must be at least zero.
Unchanged on exit.
ALPHA - COMPLEX*16 .
On entry, ALPHA specifies the scalar alpha.
Unchanged on exit.
A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is
k when TRANS = 'N' or 'n', and is n otherwise.
Before entry with TRANS = 'N' or 'n', the leading n by k
part of the array A must contain the matrix A, otherwise
the leading k by n part of the array A must contain the
matrix A.
Unchanged on exit.
LDA - INTEGER.
On entry, LDA specifies the first dimension of A as declared
in the calling (sub) program. When TRANS = 'N' or 'n'
then LDA must be at least max( 1, n ), otherwise LDA must
be at least max( 1, k ).
Unchanged on exit.
BETA - COMPLEX*16 .
On entry, BETA specifies the scalar beta.
Unchanged on exit.
C - COMPLEX*16 array of DIMENSION ( LDC, n ).
Before entry with UPLO = 'U' or 'u', the leading n by n
upper triangular part of the array C must contain the upper
triangular part of the symmetric matrix and the strictly
lower triangular part of C is not referenced. On exit, the
upper triangular part of the array C is overwritten by the
upper triangular part of the updated matrix.
Before entry with UPLO = 'L' or 'l', the leading n by n
lower triangular part of the array C must contain the lower
triangular part of the symmetric matrix and the strictly
upper triangular part of C is not referenced. On exit, the
lower triangular part of the array C is overwritten by the
lower triangular part of the updated matrix.
LDC - INTEGER.
On entry, LDC specifies the first dimension of C as declared
in the calling (sub) program. LDC must be at least
max( 1, n ).
Unchanged on exit.
Level 3 Blas routine.
-- Written on 8-February-1989.
Jack Dongarra, Argonne National Laboratory.
Iain Duff, AERE Harwell.
Jeremy Du Croz, Numerical Algorithms Group Ltd.
Sven Hammarling, Numerical Algorithms Group Ltd.
Test the input parameters.
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
/* Function Body */
if (lsame_(trans, "N")) {
nrowa = *n;
} else {
nrowa = *k;
}
upper = lsame_(uplo, "U");
info = 0;
if (! upper && ! lsame_(uplo, "L")) {
info = 1;
} else if (! lsame_(trans, "N") && ! lsame_(trans,
"T")) {
info = 2;
} else if (*n < 0) {
info = 3;
} else if (*k < 0) {
info = 4;
} else if (*lda < max(1,nrowa)) {
info = 7;
} else if (*ldc < max(1,*n)) {
info = 10;
}
if (info != 0) {
xerbla_("ZSYRK ", &info);
return 0;
}
/* Quick return if possible. */
if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && (beta->r
== 1. && beta->i == 0.)) {
return 0;
}
/* And when alpha.eq.zero. */
if (alpha->r == 0. && alpha->i == 0.) {
if (upper) {
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
c__[i__3].r = 0., c__[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L30: */
}
/* L40: */
}
}
} else {
if (beta->r == 0. && beta->i == 0.) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
c__[i__3].r = 0., c__[i__3].i = 0.;
/* L50: */
}
/* L60: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L70: */
}
/* L80: */
}
}
}
return 0;
}
/* Start the operations. */
if (lsame_(trans, "N")) {
/* Form C := alpha*A*A' + beta*C. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (beta->r == 0. && beta->i == 0.) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
c__[i__3].r = 0., c__[i__3].i = 0.;
/* L90: */
}
} else if (beta->r != 1. || beta->i != 0.) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L100: */
}
}
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
i__3 = a_subscr(j, l);
if (a[i__3].r != 0. || a[i__3].i != 0.) {
i__3 = a_subscr(j, l);
z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
z__1.i = alpha->r * a[i__3].i + alpha->i * a[
i__3].r;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = j;
for (i__ = 1; i__ <= i__3; ++i__) {
i__4 = c___subscr(i__, j);
i__5 = c___subscr(i__, j);
i__6 = a_subscr(i__, l);
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
z__2.i = temp.r * a[i__6].i + temp.i * a[
i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
.i + z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
/* L110: */
}
}
/* L120: */
}
/* L130: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (beta->r == 0. && beta->i == 0.) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
c__[i__3].r = 0., c__[i__3].i = 0.;
/* L140: */
}
} else if (beta->r != 1. || beta->i != 0.) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__1.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L150: */
}
}
i__2 = *k;
for (l = 1; l <= i__2; ++l) {
i__3 = a_subscr(j, l);
if (a[i__3].r != 0. || a[i__3].i != 0.) {
i__3 = a_subscr(j, l);
z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i,
z__1.i = alpha->r * a[i__3].i + alpha->i * a[
i__3].r;
temp.r = z__1.r, temp.i = z__1.i;
i__3 = *n;
for (i__ = j; i__ <= i__3; ++i__) {
i__4 = c___subscr(i__, j);
i__5 = c___subscr(i__, j);
i__6 = a_subscr(i__, l);
z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i,
z__2.i = temp.r * a[i__6].i + temp.i * a[
i__6].r;
z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5]
.i + z__2.i;
c__[i__4].r = z__1.r, c__[i__4].i = z__1.i;
/* L160: */
}
}
/* L170: */
}
/* L180: */
}
}
} else {
/* Form C := alpha*A'*A + beta*C. */
if (upper) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
temp.r = 0., temp.i = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
i__4 = a_subscr(l, i__);
i__5 = a_subscr(l, j);
z__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5]
.i, z__2.i = a[i__4].r * a[i__5].i + a[i__4]
.i * a[i__5].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L190: */
}
if (beta->r == 0. && beta->i == 0.) {
i__3 = c___subscr(i__, j);
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
z__1.i = alpha->r * temp.i + alpha->i *
temp.r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = c___subscr(i__, j);
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
z__2.i = alpha->r * temp.i + alpha->i *
temp.r;
i__4 = c___subscr(i__, j);
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
/* L200: */
}
/* L210: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j; i__ <= i__2; ++i__) {
temp.r = 0., temp.i = 0.;
i__3 = *k;
for (l = 1; l <= i__3; ++l) {
i__4 = a_subscr(l, i__);
i__5 = a_subscr(l, j);
z__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5]
.i, z__2.i = a[i__4].r * a[i__5].i + a[i__4]
.i * a[i__5].r;
z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i;
temp.r = z__1.r, temp.i = z__1.i;
/* L220: */
}
if (beta->r == 0. && beta->i == 0.) {
i__3 = c___subscr(i__, j);
z__1.r = alpha->r * temp.r - alpha->i * temp.i,
z__1.i = alpha->r * temp.i + alpha->i *
temp.r;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
} else {
i__3 = c___subscr(i__, j);
z__2.r = alpha->r * temp.r - alpha->i * temp.i,
z__2.i = alpha->r * temp.i + alpha->i *
temp.r;
i__4 = c___subscr(i__, j);
z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4]
.i, z__3.i = beta->r * c__[i__4].i + beta->i *
c__[i__4].r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
}
/* L230: */
}
/* L240: */
}
}
}
return 0;
/* End of ZSYRK . */
} /* zsyrk_ */
/* Subroutine */ int zlacrm_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublereal *b, integer *ldb, doublecomplex *c__,
integer *ldc, doublereal *rwork)
{
/* -- 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
=======
ZLACRM performs a very simple matrix-matrix multiplication:
C := A * B,
where A is M by N and complex; B is N by N and real;
C is M by N and complex.
Arguments
=========
M (input) INTEGER
The number of rows of the matrix A and of the matrix C.
M >= 0.
N (input) INTEGER
The number of columns and rows of the matrix B and
the number of columns of the matrix C.
N >= 0.
A (input) COMPLEX*16 array, dimension (LDA, N)
A contains the M by N matrix A.
LDA (input) INTEGER
The leading dimension of the array A. LDA >=max(1,M).
B (input) DOUBLE PRECISION array, dimension (LDB, N)
B contains the N by N matrix B.
LDB (input) INTEGER
The leading dimension of the array B. LDB >=max(1,N).
C (input) COMPLEX*16 array, dimension (LDC, N)
C contains the M by N matrix C.
LDC (input) INTEGER
The leading dimension of the array C. LDC >=max(1,N).
RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N)
=====================================================================
Quick return if possible.
Parameter adjustments */
/* Table of constant values */
static doublereal c_b6 = 1.;
static doublereal c_b7 = 0.;
/* System generated locals */
integer b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2,
i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1;
/* Builtin functions */
double d_imag(doublecomplex *);
/* Local variables */
static integer i__, j, l;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
#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 c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--rwork;
/* Function Body */
if (*m == 0 || *n == 0) {
return 0;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = a_subscr(i__, j);
rwork[(j - 1) * *m + i__] = a[i__3].r;
/* L10: */
}
/* L20: */
}
l = *m * *n + 1;
dgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, &
rwork[l], m);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = l + (j - 1) * *m + i__ - 1;
c__[i__3].r = rwork[i__4], c__[i__3].i = 0.;
/* L30: */
}
/* L40: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
rwork[(j - 1) * *m + i__] = d_imag(&a_ref(i__, j));
/* L50: */
}
/* L60: */
}
dgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, &
rwork[l], m);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
d__1 = c__[i__4].r;
i__5 = l + (j - 1) * *m + i__ - 1;
z__1.r = d__1, z__1.i = rwork[i__5];
c__[i__3].r = z__1.r, c__[i__3].i = z__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of ZLACRM */
} /* zlacrm_ */
/* Subroutine */ int clarfb_(char *side, char *trans, char *direct, char *
storev, integer *m, integer *n, integer *k, complex *v, integer *ldv,
complex *t, integer *ldt, complex *c__, integer *ldc, complex *work,
integer *ldwork)
{
/* -- 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
=======
CLARFB applies a complex block reflector H or its transpose H' to a
complex M-by-N matrix C, from either the left or the right.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply H or H' from the Left
= 'R': apply H or H' from the Right
TRANS (input) CHARACTER*1
= 'N': apply H (No transpose)
= 'C': apply H' (Conjugate transpose)
DIRECT (input) CHARACTER*1
Indicates how H is formed from a product of elementary
reflectors
= 'F': H = H(1) H(2) . . . H(k) (Forward)
= 'B': H = H(k) . . . H(2) H(1) (Backward)
STOREV (input) CHARACTER*1
Indicates how the vectors which define the elementary
reflectors are stored:
= 'C': Columnwise
= 'R': Rowwise
M (input) INTEGER
The number of rows of the matrix C.
N (input) INTEGER
The number of columns of the matrix C.
K (input) INTEGER
The order of the matrix T (= the number of elementary
reflectors whose product defines the block reflector).
V (input) COMPLEX array, dimension
(LDV,K) if STOREV = 'C'
(LDV,M) if STOREV = 'R' and SIDE = 'L'
(LDV,N) if STOREV = 'R' and SIDE = 'R'
The matrix V. See further details.
LDV (input) INTEGER
The leading dimension of the array V.
If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
if STOREV = 'R', LDV >= K.
T (input) COMPLEX array, dimension (LDT,K)
The triangular K-by-K matrix T in the representation of the
block reflector.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= K.
C (input/output) COMPLEX array, dimension (LDC,N)
On entry, the M-by-N matrix C.
On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace) COMPLEX array, dimension (LDWORK,K)
LDWORK (input) INTEGER
The leading dimension of the array WORK.
If SIDE = 'L', LDWORK >= max(1,N);
if SIDE = 'R', LDWORK >= max(1,M).
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static complex c_b1 = {1.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1,
work_offset, i__1, i__2, i__3, i__4, i__5;
complex q__1, q__2;
/* Builtin functions */
void r_cnjg(complex *, complex *);
/* Local variables */
static integer i__, j;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), ctrmm_(char *, char *, char *, char *,
integer *, integer *, complex *, complex *, integer *, complex *,
integer *), clacgv_(integer *,
complex *, integer *);
static char transt[1];
#define work_subscr(a_1,a_2) (a_2)*work_dim1 + a_1
#define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)]
#define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1
#define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)]
#define v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1
#define v_ref(a_1,a_2) v[v_subscr(a_1,a_2)]
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1 * 1;
work -= work_offset;
/* Function Body */
if (*m <= 0 || *n <= 0) {
return 0;
}
if (lsame_(trans, "N")) {
*(unsigned char *)transt = 'C';
} else {
*(unsigned char *)transt = 'N';
}
if (lsame_(storev, "C")) {
if (lsame_(direct, "F")) {
/* Let V = ( V1 ) (first K rows)
( V2 )
where V1 is unit lower triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 )
( C2 )
W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1);
clacgv_(n, &work_ref(1, j), &c__1);
/* L10: */
}
/* W := W * V1 */
ctrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork);
if (*m > *k) {
/* W := W + C2'*V2 */
i__1 = *m - *k;
cgemm_("Conjugate transpose", "No transpose", n, k, &i__1,
&c_b1, &c___ref(*k + 1, 1), ldc, &v_ref(*k + 1,
1), ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ctrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W' */
if (*m > *k) {
/* C2 := C2 - V2 * W' */
i__1 = *m - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "Conjugate transpose", &i__1, n, k,
&q__1, &v_ref(*k + 1, 1), ldv, &work[work_offset]
, ldwork, &c_b1, &c___ref(*k + 1, 1), ldc);
}
/* W := W * V1' */
ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(j, i__);
i__4 = c___subscr(j, i__);
r_cnjg(&q__2, &work_ref(i__, j));
q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
q__2.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L20: */
}
/* L30: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 )
W := C * V = (C1*V1 + C2*V2) (stored in WORK)
W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1);
/* L40: */
}
/* W := W * V1 */
ctrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork);
if (*n > *k) {
/* W := W + C2 * V2 */
i__1 = *n - *k;
cgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1,
&c___ref(1, *k + 1), ldc, &v_ref(*k + 1, 1), ldv,
&c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ctrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V' */
if (*n > *k) {
/* C2 := C2 - W * V2' */
i__1 = *n - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "Conjugate transpose", m, &i__1, k,
&q__1, &work[work_offset], ldwork, &v_ref(*k + 1,
1), ldv, &c_b1, &c___ref(1, *k + 1), ldc);
}
/* W := W * V1' */
ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
i__5 = work_subscr(i__, j);
q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L50: */
}
/* L60: */
}
}
} else {
/* Let V = ( V1 )
( V2 ) (last K rows)
where V2 is unit upper triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 )
( C2 )
W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j),
&c__1);
clacgv_(n, &work_ref(1, j), &c__1);
/* L70: */
}
/* W := W * V2 */
ctrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1,
&v_ref(*m - *k + 1, 1), ldv, &work[work_offset],
ldwork);
if (*m > *k) {
/* W := W + C1'*V1 */
i__1 = *m - *k;
cgemm_("Conjugate transpose", "No transpose", n, k, &i__1,
&c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ctrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V * W' */
if (*m > *k) {
/* C1 := C1 - V1 * W' */
i__1 = *m - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "Conjugate transpose", &i__1, n, k,
&q__1, &v[v_offset], ldv, &work[work_offset],
ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2' */
ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k,
&c_b1, &v_ref(*m - *k + 1, 1), ldv, &work[work_offset]
, ldwork)
;
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(*m - *k + j, i__);
i__4 = c___subscr(*m - *k + j, i__);
r_cnjg(&q__2, &work_ref(i__, j));
q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
q__2.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L80: */
}
/* L90: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 )
W := C * V = (C1*V1 + C2*V2) (stored in WORK)
W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j)
, &c__1);
/* L100: */
}
/* W := W * V2 */
ctrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1,
&v_ref(*n - *k + 1, 1), ldv, &work[work_offset],
ldwork);
if (*n > *k) {
/* W := W + C1 * V1 */
i__1 = *n - *k;
cgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1,
&c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, &
work[work_offset], ldwork)
;
}
/* W := W * T or W * T' */
ctrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V' */
if (*n > *k) {
/* C1 := C1 - W * V1' */
i__1 = *n - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "Conjugate transpose", m, &i__1, k,
&q__1, &work[work_offset], ldwork, &v[v_offset],
ldv, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2' */
ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k,
&c_b1, &v_ref(*n - *k + 1, 1), ldv, &work[work_offset]
, ldwork)
;
/* C2 := C2 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, *n - *k + j);
i__4 = c___subscr(i__, *n - *k + j);
i__5 = work_subscr(i__, j);
q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L110: */
}
/* L120: */
}
}
}
} else if (lsame_(storev, "R")) {
if (lsame_(direct, "F")) {
/* Let V = ( V1 V2 ) (V1: first K columns)
where V1 is unit upper triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 )
( C2 )
W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
W := C1' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1);
clacgv_(n, &work_ref(1, j), &c__1);
/* L130: */
}
/* W := W * V1' */
ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (*m > *k) {
/* W := W + C2'*V2' */
i__1 = *m - *k;
cgemm_("Conjugate transpose", "Conjugate transpose", n, k,
&i__1, &c_b1, &c___ref(*k + 1, 1), ldc, &v_ref(1,
*k + 1), ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ctrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V' * W' */
if (*m > *k) {
/* C2 := C2 - V2' * W' */
i__1 = *m - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, n, k, &q__1, &v_ref(1, *k + 1), ldv, &work[
work_offset], ldwork, &c_b1, &c___ref(*k + 1, 1),
ldc);
}
/* W := W * V1 */
ctrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(j, i__);
i__4 = c___subscr(j, i__);
r_cnjg(&q__2, &work_ref(i__, j));
q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
q__2.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L140: */
}
/* L150: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 )
W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
W := C1 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1);
/* L160: */
}
/* W := W * V1' */
ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k,
&c_b1, &v[v_offset], ldv, &work[work_offset], ldwork);
if (*n > *k) {
/* W := W + C2 * V2' */
i__1 = *n - *k;
cgemm_("No transpose", "Conjugate transpose", m, k, &i__1,
&c_b1, &c___ref(1, *k + 1), ldc, &v_ref(1, *k +
1), ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ctrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (*n > *k) {
/* C2 := C2 - W * V2 */
i__1 = *n - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "No transpose", m, &i__1, k, &q__1,
&work[work_offset], ldwork, &v_ref(1, *k + 1),
ldv, &c_b1, &c___ref(1, *k + 1), ldc);
}
/* W := W * V1 */
ctrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1,
&v[v_offset], ldv, &work[work_offset], ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, j);
i__4 = c___subscr(i__, j);
i__5 = work_subscr(i__, j);
q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L170: */
}
/* L180: */
}
}
} else {
/* Let V = ( V1 V2 ) (V2: last K columns)
where V2 is unit lower triangular. */
if (lsame_(side, "L")) {
/* Form H * C or H' * C where C = ( C1 )
( C2 )
W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
W := C2' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j),
&c__1);
clacgv_(n, &work_ref(1, j), &c__1);
/* L190: */
}
/* W := W * V2' */
ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k,
&c_b1, &v_ref(1, *m - *k + 1), ldv, &work[work_offset]
, ldwork)
;
if (*m > *k) {
/* W := W + C1'*V1' */
i__1 = *m - *k;
cgemm_("Conjugate transpose", "Conjugate transpose", n, k,
&i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset],
ldv, &c_b1, &work[work_offset], ldwork);
}
/* W := W * T' or W * T */
ctrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - V' * W' */
if (*m > *k) {
/* C1 := C1 - V1' * W' */
i__1 = *m - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("Conjugate transpose", "Conjugate transpose", &
i__1, n, k, &q__1, &v[v_offset], ldv, &work[
work_offset], ldwork, &c_b1, &c__[c_offset], ldc);
}
/* W := W * V2 */
ctrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1,
&v_ref(1, *m - *k + 1), ldv, &work[work_offset],
ldwork);
/* C2 := C2 - W' */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(*m - *k + j, i__);
i__4 = c___subscr(*m - *k + j, i__);
r_cnjg(&q__2, &work_ref(i__, j));
q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i -
q__2.i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L200: */
}
/* L210: */
}
} else if (lsame_(side, "R")) {
/* Form C * H or C * H' where C = ( C1 C2 )
W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
W := C2 */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j)
, &c__1);
/* L220: */
}
/* W := W * V2' */
ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k,
&c_b1, &v_ref(1, *n - *k + 1), ldv, &work[work_offset]
, ldwork)
;
if (*n > *k) {
/* W := W + C1 * V1' */
i__1 = *n - *k;
cgemm_("No transpose", "Conjugate transpose", m, k, &i__1,
&c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &
c_b1, &work[work_offset], ldwork);
}
/* W := W * T or W * T' */
ctrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[
t_offset], ldt, &work[work_offset], ldwork);
/* C := C - W * V */
if (*n > *k) {
/* C1 := C1 - W * V1 */
i__1 = *n - *k;
q__1.r = -1.f, q__1.i = 0.f;
cgemm_("No transpose", "No transpose", m, &i__1, k, &q__1,
&work[work_offset], ldwork, &v[v_offset], ldv, &
c_b1, &c__[c_offset], ldc)
;
}
/* W := W * V2 */
ctrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1,
&v_ref(1, *n - *k + 1), ldv, &work[work_offset],
ldwork);
/* C1 := C1 - W */
i__1 = *k;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = c___subscr(i__, *n - *k + j);
i__4 = c___subscr(i__, *n - *k + j);
i__5 = work_subscr(i__, j);
q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[
i__4].i - work[i__5].i;
c__[i__3].r = q__1.r, c__[i__3].i = q__1.i;
/* L230: */
}
/* L240: */
}
}
}
}
return 0;
/* End of CLARFB */
} /* clarfb_ */
