int
f2c_zgerc(integer* M, integer* N,
doublecomplex* alpha,
doublecomplex* X, integer* incX,
doublecomplex* Y, integer* incY,
doublecomplex* A, integer* lda)
{
zgerc_(M, N, alpha,
X, incX, Y, incY, A, lda);
return 0;
}
void parallelStorageFreqDTCReal::fieldIn(cplx* fftFact)
{
if(!fieldInFreq_)
return;
// Copy the field information into a vector
for(int jj = 0; jj < fieldInFreq_->sz_[2]; ++jj)
{
for(int ii = 0; ii < fieldInFreq_->sz_[1]; ++ii)
{
dcopy_(fieldInFreq_->sz_[0], &grid_->point(fieldInFreq_->loc_[0]+ii*fieldInFreq_->addVec1_[0]+jj*fieldInFreq_->addVec2_[0], fieldInFreq_->loc_[1]+ii*fieldInFreq_->addVec1_[1]+jj*fieldInFreq_->addVec2_[1], fieldInFreq_->loc_[2]+ii*fieldInFreq_->addVec1_[2]+jj*fieldInFreq_->addVec2_[2]), fieldInFreq_->stride_, reinterpret_cast<double*>( &fIn_[ (ii*fieldInFreq_->sz_[2] + jj)*fieldInFreq_->sz_[0] ] ) , 2 );
}
}
// Take an outer product of the prefactor vector and the field vectors to get the discrete Fourier Transform at all points
zgerc_(nfreq_, fieldInFreq_->sz_[0]*fieldInFreq_->sz_[1]*fieldInFreq_->sz_[2], 1.0, fftFact, 1, fIn_.data(), 1, outGrid_->data(), nfreq_);
}
/* 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_ */
void
zgerc(int m, int n, doublecomplex *alpha, doublecomplex *x, int incx, doublecomplex *y, int incy, doublecomplex *a, int lda)
{
zgerc_( &m, &n, alpha, x, &incx, y, &incy, a, &lda);
}
/* Subroutine */ int zlarf_(char *side, integer *m, integer *n, doublecomplex
*v, integer *incv, doublecomplex *tau, doublecomplex *c__, integer *
ldc, doublecomplex *work)
{
/* System generated locals */
integer c_dim1, c_offset, i__1;
doublecomplex z__1;
/* Local variables */
integer i__;
logical applyleft;
extern logical lsame_(char *, char *);
integer lastc;
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 *);
integer lastv;
extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *),
ilazlr_(integer *, integer *, doublecomplex *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARF 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. */
/* 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. */
/* V (input) COMPLEX*16 array, dimension */
/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
/* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
/* The vector v in the representation of H. 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 >= lmax(1,M). */
/* WORK (workspace) COMPLEX*16 array, dimension */
/* (N) if SIDE = 'L' */
/* or (M) if SIDE = 'R' */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
applyleft = lsame_(side, "L");
lastv = 0;
lastc = 0;
if (tau->r != 0. || tau->i != 0.) {
/* Set up variables for scanning V. LASTV begins pointing to the end */
/* of V. */
if (applyleft) {
lastv = *m;
} else {
lastv = *n;
}
if (*incv > 0) {
i__ = (lastv - 1) * *incv + 1;
} else {
i__ = 1;
}
/* Look for the last non-zero row in V. */
for(;;) { /* while(complicated condition) */
i__1 = i__;
if (!(lastv > 0 && (v[i__1].r == 0. && v[i__1].i == 0.)))
break;
--lastv;
i__ -= *incv;
}
if (applyleft) {
/* Scan for the last non-zero column in C(1:lastv,:). */
lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc);
} else {
/* Scan for the last non-zero row in C(:,1:lastv). */
lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc);
}
}
/* Note that lastc.eq.0 renders the BLAS operations null; no special */
/* case is needed at this level. */
if (applyleft) {
/* Form H * C */
if (lastv > 0) {
/* w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */
zgemv_("Conjugate transpose", &lastv, &lastc, &c_b1, &c__[
c_offset], ldc, &v[1], incv, &c_b2, &work[1], &c__1);
/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(&lastv, &lastc, &z__1, &v[1], incv, &work[1], &c__1, &c__[
c_offset], ldc);
}
} else {
/* Form C * H */
if (lastv > 0) {
/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
zgemv_("No transpose", &lastc, &lastv, &c_b1, &c__[c_offset], ldc,
&v[1], incv, &c_b2, &work[1], &c__1);
/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(&lastc, &lastv, &z__1, &work[1], &c__1, &v[1], incv, &c__[
c_offset], ldc);
}
}
return 0;
/* End of ZLARF */
} /* zlarf_ */
/* Subroutine */ int zlaghe_(integer *n, integer *k, doublereal *d,
doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double z_abs(doublecomplex *);
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer i, j;
static doublecomplex alpha;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *),
zhemv_(char *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *), zaxpy_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
static doublecomplex wa, wb;
static doublereal wn;
extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_(
integer *, integer *, integer *, doublecomplex *);
static doublecomplex tau;
/* -- LAPACK auxiliary test 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
=======
ZLAGHE generates a complex hermitian matrix A, by pre- and post-
multiplying a real diagonal matrix D with a random unitary matrix:
A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
unitary transformations.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
K (input) INTEGER
The number of nonzero subdiagonals within the band of A.
0 <= K <= N-1.
D (input) DOUBLE PRECISION array, dimension (N)
The diagonal elements of the diagonal matrix D.
A (output) COMPLEX*16 array, dimension (LDA,N)
The generated n by n hermitian matrix A (the full matrix is
stored).
LDA (input) INTEGER
The leading dimension of the array A. LDA >= N.
ISEED (input/output) INTEGER array, dimension (4)
On entry, the seed of the random number generator; the array
elements must be between 0 and 4095, and ISEED(4) must be
odd.
On exit, the seed is updated.
WORK (workspace) COMPLEX*16 array, dimension (2*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
=====================================================================
Test the input arguments
Parameter adjustments */
--d;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZLAGHE", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = i + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
i__2 = i + i * a_dim1;
i__3 = i;
a[i__2].r = d[i__3], a[i__2].i = 0.;
/* L30: */
}
/* Generate lower triangle of hermitian matrix */
for (i = *n - 1; i >= 1; --i) {
/* generate random reflection */
i__1 = *n - i + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *n - i;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply random reflection to A(i:n,i:n) from the left
and the right
compute y := tau * A * u */
i__1 = *n - i + 1;
zhemv_("Lower", &i__1, &tau, &a[i + i * a_dim1], lda, &work[1], &c__1,
&c_b1, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__1 = *n - i + 1;
zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__1 = *n - i + 1;
zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
i__1 = *n - i + 1;
z__1.r = -1., z__1.i = 0.;
zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &
a[i + i * a_dim1], lda);
/* L40: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i = 1; i <= i__1; ++i) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i + 1;
wn = dznrm2_(&i__2, &a[*k + i + i * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*k + i + i * a_dim1]);
i__2 = *k + i + i * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *k + i + i * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *k - i;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*k + i + 1 + i * a_dim1], &c__1);
i__2 = *k + i + i * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i + (i + 1)
* a_dim1], lda, &a[*k + i + i * a_dim1], &c__1, &c_b1, &work[
1], &c__1);
i__2 = *n - *k - i + 1;
i__3 = *k - 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*k + i + i * a_dim1], &c__1, &work[1],
&c__1, &a[*k + i + (i + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the rig
ht
compute y := tau * A * u */
i__2 = *n - *k - i + 1;
zhemv_("Lower", &i__2, &tau, &a[*k + i + (*k + i) * a_dim1], lda, &a[*
k + i + i * a_dim1], &c__1, &c_b1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = 0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__2 = *n - *k - i + 1;
zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i + i * a_dim1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - *k - i + 1;
zaxpy_(&i__2, &alpha, &a[*k + i + i * a_dim1], &c__1, &work[1], &c__1)
;
/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i + 1;
z__1.r = -1., z__1.i = 0.;
zher2_("Lower", &i__2, &z__1, &a[*k + i + i * a_dim1], &c__1, &work[1]
, &c__1, &a[*k + i + (*k + i) * a_dim1], lda);
i__2 = *k + i + i * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = *n;
for (j = *k + i + 1; j <= i__2; ++j) {
i__3 = j + i * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
/* L60: */
}
/* Store full hermitian matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i = j + 1; i <= i__2; ++i) {
i__3 = j + i * a_dim1;
d_cnjg(&z__1, &a[i + j * a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of ZLAGHE */
} /* zlaghe_ */
/* Subroutine */ int zlaghe_(integer *n, integer *k, doublereal *d__,
doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Local variables */
integer i__, j;
doublecomplex wa, wb;
doublereal wn;
doublecomplex tau;
doublecomplex alpha;
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAGHE generates a complex hermitian matrix A, by pre- and post- */
/* multiplying a real diagonal matrix D with a random unitary matrix: */
/* A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
/* unitary transformations. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* K (input) INTEGER */
/* The number of nonzero subdiagonals within the band of A. */
/* 0 <= K <= N-1. */
/* D (input) DOUBLE PRECISION array, dimension (N) */
/* The diagonal elements of the diagonal matrix D. */
/* A (output) COMPLEX*16 array, dimension (LDA,N) */
/* The generated n by n hermitian matrix A (the full matrix is */
/* stored). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= N. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* WORK (workspace) COMPLEX*16 array, dimension (2*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
--d__;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*k < 0 || *k > *n - 1) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZLAGHE", &i__1);
return 0;
}
/* initialize lower triangle of A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.;
/* L30: */
}
/* Generate lower triangle of hermitian matrix */
for (i__ = *n - 1; i__ >= 1; --i__) {
/* generate random reflection */
i__1 = *n - i__ + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *n - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply random reflection to A(i:n,i:n) from the left */
/* and the right */
/* compute y := tau * A * u */
i__1 = *n - i__ + 1;
zhemv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
c__1, &c_b1, &work[*n + 1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = -0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__1 = *n - i__ + 1;
zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__1 = *n - i__ + 1;
zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
/* apply the transformation as a rank-2 update to A(i:n,i:n) */
i__1 = *n - i__ + 1;
z__1.r = -1., z__1.i = -0.;
zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &
a[i__ + i__ * a_dim1], lda);
/* L40: */
}
/* Reduce number of subdiagonals to K */
i__1 = *n - 1 - *k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* generate reflection to annihilate A(k+i+1:n,i) */
i__2 = *n - *k - i__ + 1;
wn = dznrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*k + i__ + i__ * a_dim1]);
i__2 = *k + i__ + i__ * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *k + i__ + i__ * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *k - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
i__2 = *k + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */
i__2 = *n - *k - i__ + 1;
i__3 = *k - 1;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__
+ 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
c_b1, &work[1], &c__1);
i__2 = *n - *k - i__ + 1;
i__3 = *k - 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
/* apply reflection to A(k+i:n,k+i:n) from the left and the right */
/* compute y := tau * A * u */
i__2 = *n - *k - i__ + 1;
zhemv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda,
&a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
/* compute v := y - 1/2 * tau * ( y, u ) * u */
z__3.r = -.5, z__3.i = -0.;
z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i +
z__3.i * tau.r;
i__2 = *n - *k - i__ + 1;
zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i__ + i__ * a_dim1], &
c__1);
z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i
+ z__2.i * z__4.r;
alpha.r = z__1.r, alpha.i = z__1.i;
i__2 = *n - *k - i__ + 1;
zaxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
c__1);
/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */
i__2 = *n - *k - i__ + 1;
z__1.r = -1., z__1.i = -0.;
zher2_("Lower", &i__2, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &
work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
i__2 = *k + i__ + i__ * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
i__2 = *n;
for (j = *k + i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
/* L60: */
}
/* Store full hermitian matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = j + 1; i__ <= i__2; ++i__) {
i__3 = j + i__ * a_dim1;
d_cnjg(&z__1, &a[i__ + j * a_dim1]);
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L70: */
}
/* L80: */
}
return 0;
/* End of ZLAGHE */
} /* zlaghe_ */
/* 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_ */
/* Subroutine */ int zlagge_(integer *m, integer *n, integer *kl, integer *ku,
doublereal *d__, doublecomplex *a, integer *lda, integer *iseed,
doublecomplex *work, 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 */
integer i__, j;
doublecomplex wa, wb;
doublereal wn;
doublecomplex tau;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
integer *, doublecomplex *, integer *), zlarnv_(integer *,
integer *, integer *, doublecomplex *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLAGGE generates a complex general m by n matrix A, by pre- and post- */
/* multiplying a real diagonal matrix D with random unitary matrices: */
/* A = U*D*V. The lower and upper bandwidths may then be reduced to */
/* kl and ku by additional unitary transformations. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* The number of nonzero subdiagonals within the band of A. */
/* 0 <= KL <= M-1. */
/* KU (input) INTEGER */
/* The number of nonzero superdiagonals within the band of A. */
/* 0 <= KU <= N-1. */
/* D (input) DOUBLE PRECISION array, dimension (min(M,N)) */
/* The diagonal elements of the diagonal matrix D. */
/* A (output) COMPLEX*16 array, dimension (LDA,N) */
/* The generated m by n matrix A. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= M. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* WORK (workspace) COMPLEX*16 array, dimension (M+N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input arguments */
/* Parameter adjustments */
--d__;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--iseed;
--work;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*kl < 0 || *kl > *m - 1) {
*info = -3;
} else if (*ku < 0 || *ku > *n - 1) {
*info = -4;
} else if (*lda < max(1,*m)) {
*info = -7;
}
if (*info < 0) {
i__1 = -(*info);
xerbla_("ZLAGGE", &i__1);
return 0;
}
/* initialize A to diagonal matrix */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L10: */
}
/* L20: */
}
i__1 = min(*m,*n);
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__ + i__ * a_dim1;
i__3 = i__;
a[i__2].r = d__[i__3], a[i__2].i = 0.;
/* L30: */
}
/* pre- and post-multiply A by random unitary matrices */
for (i__ = min(*m,*n); i__ >= 1; --i__) {
if (i__ < *m) {
/* generate random reflection */
i__1 = *m - i__ + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *m - i__ + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *m - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* multiply A(i:m,i:n) by random reflection from the left */
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
zgemv_("Conjugate transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ *
a_dim1], lda, &work[1], &c__1, &c_b1, &work[*m + 1], &
c__1);
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__1, &i__2, &z__1, &work[1], &c__1, &work[*m + 1], &c__1,
&a[i__ + i__ * a_dim1], lda);
}
if (i__ < *n) {
/* generate random reflection */
i__1 = *n - i__ + 1;
zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
i__1 = *n - i__ + 1;
wn = dznrm2_(&i__1, &work[1], &c__1);
d__1 = wn / z_abs(&work[1]);
z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__1 = *n - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__1, &z__1, &work[2], &c__1);
work[1].r = 1., work[1].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* multiply A(i:m,i:n) by random reflection from the right */
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
zgemv_("No transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * a_dim1]
, lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
i__1 = *m - i__ + 1;
i__2 = *n - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__1, &i__2, &z__1, &work[*n + 1], &c__1, &work[1], &c__1,
&a[i__ + i__ * a_dim1], lda);
}
/* L40: */
}
/* Reduce number of subdiagonals to KL and number of superdiagonals */
/* to KU */
/* Computing MAX */
i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
i__1 = max(i__2,i__3);
for (i__ = 1; i__ <= i__1; ++i__) {
if (*kl <= *ku) {
/* annihilate subdiagonal elements first (necessary if KL = 0) */
/* Computing MIN */
i__2 = *m - 1 - *kl;
if (i__ <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i) */
i__2 = *m - *kl - i__ + 1;
wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *m - *kl - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
c__1);
i__2 = *kl + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(kl+i:m,i+1:n) from the left */
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl +
i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ *
a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], &
c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
a_dim1], lda);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
/* Computing MIN */
i__2 = *n - 1 - *ku;
if (i__ <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n) */
i__2 = *n - *ku - i__ + 1;
wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *ku - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
lda);
i__2 = i__ + (*ku + i__) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(i+1:m,ku+i:n) from the right */
i__2 = *n - *ku - i__ + 1;
zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku
+ i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
lda, &c_b1, &work[1], &c__1);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku +
i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
a_dim1], lda);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
} else {
/* annihilate superdiagonal elements first (necessary if */
/* KU = 0) */
/* Computing MIN */
i__2 = *n - 1 - *ku;
if (i__ <= min(i__2,*m)) {
/* generate reflection to annihilate A(i,ku+i+1:n) */
i__2 = *n - *ku - i__ + 1;
wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *n - *ku - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1],
lda);
i__2 = i__ + (*ku + i__) * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(i+1:m,ku+i:n) from the right */
i__2 = *n - *ku - i__ + 1;
zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku
+ i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
lda, &c_b1, &work[1], &c__1);
i__2 = *m - i__;
i__3 = *n - *ku - i__ + 1;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku +
i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) *
a_dim1], lda);
i__2 = i__ + (*ku + i__) * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
/* Computing MIN */
i__2 = *m - 1 - *kl;
if (i__ <= min(i__2,*n)) {
/* generate reflection to annihilate A(kl+i+1:m,i) */
i__2 = *m - *kl - i__ + 1;
wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
wa.r = z__1.r, wa.i = z__1.i;
if (wn == 0.) {
tau.r = 0., tau.i = 0.;
} else {
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
wb.r = z__1.r, wb.i = z__1.i;
i__2 = *m - *kl - i__;
z_div(&z__1, &c_b2, &wb);
zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
c__1);
i__2 = *kl + i__ + i__ * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
z_div(&z__1, &wb, &wa);
d__1 = z__1.r;
tau.r = d__1, tau.i = 0.;
}
/* apply reflection to A(kl+i:m,i+1:n) from the left */
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl +
i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ *
a_dim1], &c__1, &c_b1, &work[1], &c__1);
i__2 = *m - *kl - i__ + 1;
i__3 = *n - i__;
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], &
c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) *
a_dim1], lda);
i__2 = *kl + i__ + i__ * a_dim1;
z__1.r = -wa.r, z__1.i = -wa.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
}
i__2 = *m;
for (j = *kl + i__ + 1; j <= i__2; ++j) {
i__3 = j + i__ * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L50: */
}
i__2 = *n;
for (j = *ku + i__ + 1; j <= i__2; ++j) {
i__3 = i__ + j * a_dim1;
a[i__3].r = 0., a[i__3].i = 0.;
/* L60: */
}
/* L70: */
}
return 0;
/* End of ZLAGGE */
} /* zlagge_ */
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 zlarf_(char *side, integer *m, integer *n, doublecomplex
*v, integer *incv, doublecomplex *tau, doublecomplex *c__, integer *
ldc, doublecomplex *work)
{
/* -- 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
=======
ZLARF 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.
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.
V (input) COMPLEX*16 array, dimension
(1 + (M-1)*abs(INCV)) if SIDE = 'L'
or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
The vector v in the representation of H. 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'
=====================================================================
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {1.,0.};
static doublecomplex c_b2 = {0.,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 *);
--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 := C' * v */
zgemv_("Conjugate transpose", m, n, &c_b1, &c__[c_offset], ldc, &
v[1], incv, &c_b2, &work[1], &c__1);
/* C := C - v * w' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, n, &z__1, &v[1], incv, &work[1], &c__1, &c__[c_offset],
ldc);
}
} else {
/* Form C * H */
if (tau->r != 0. || tau->i != 0.) {
/* w := C * v */
zgemv_("No transpose", m, n, &c_b1, &c__[c_offset], ldc, &v[1],
incv, &c_b2, &work[1], &c__1);
/* C := C - w * v' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, n, &z__1, &work[1], &c__1, &v[1], incv, &c__[c_offset],
ldc);
}
}
return 0;
/* End of ZLARF */
} /* zlarf_ */
/* Subroutine */ int ztzrqf_(integer *m, integer *n, doublecomplex *a,
integer *lda, doublecomplex *tau, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
integer i__, k, m1;
doublecomplex alpha;
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 *),
zcopy_(integer *, doublecomplex *, integer *, doublecomplex *,
integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *), xerbla_(char *, integer *), zlacgv_(integer *, doublecomplex *, integer *), zlarfp_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *);
/* -- LAPACK routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* This routine is deprecated and has been replaced by routine ZTZRZF. */
/* ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A */
/* to upper triangular form by means of unitary transformations. */
/* The upper trapezoidal matrix A is factored as */
/* A = ( R 0 ) * Z, */
/* where Z is an N-by-N unitary matrix and R is an M-by-M upper */
/* triangular matrix. */
/* 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 >= M. */
/* A (input/output) COMPLEX*16 array, dimension (LDA,N) */
/* On entry, the leading M-by-N upper trapezoidal part of the */
/* array A must contain the matrix to be factorized. */
/* On exit, the leading M-by-M upper triangular part of A */
/* contains the upper triangular matrix R, and elements M+1 to */
/* N of the first M rows of A, with the array TAU, represent the */
/* unitary matrix Z as a product of M elementary reflectors. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,M). */
/* TAU (output) COMPLEX*16 array, dimension (M) */
/* The scalar factors of the elementary reflectors. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* Further Details */
/* =============== */
/* The factorization is obtained by Householder's method. The kth */
/* transformation matrix, Z( k ), whose conjugate transpose is used to */
/* introduce zeros into the (m - k + 1)th row of A, is given in the form */
/* Z( k ) = ( I 0 ), */
/* ( 0 T( k ) ) */
/* where */
/* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), */
/* ( 0 ) */
/* ( z( k ) ) */
/* tau is a scalar and z( k ) is an ( n - m ) element vector. */
/* tau and z( k ) are chosen to annihilate the elements of the kth row */
/* of X. */
/* The scalar tau is returned in the kth element of TAU and the vector */
/* u( k ) in the kth row of A, such that the elements of z( k ) are */
/* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in */
/* the upper triangular part of A. */
/* Z is given by */
/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
/* Function Body */
*info = 0;
if (*m < 0) {
*info = -1;
} else if (*n < *m) {
*info = -2;
} else if (*lda < max(1,*m)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZTZRQF", &i__1);
return 0;
}
/* Perform the factorization. */
if (*m == 0) {
return 0;
}
if (*m == *n) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
tau[i__2].r = 0., tau[i__2].i = 0.;
/* L10: */
}
} else {
/* Computing MIN */
i__1 = *m + 1;
m1 = min(i__1,*n);
for (k = *m; k >= 1; --k) {
/* Use a Householder reflection to zero the kth row of A. */
/* First set up the reflection. */
i__1 = k + k * a_dim1;
d_cnjg(&z__1, &a[k + k * a_dim1]);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = *n - *m;
zlacgv_(&i__1, &a[k + m1 * a_dim1], lda);
i__1 = k + k * a_dim1;
alpha.r = a[i__1].r, alpha.i = a[i__1].i;
i__1 = *n - *m + 1;
zlarfp_(&i__1, &alpha, &a[k + m1 * a_dim1], lda, &tau[k]);
i__1 = k + k * a_dim1;
a[i__1].r = alpha.r, a[i__1].i = alpha.i;
i__1 = k;
d_cnjg(&z__1, &tau[k]);
tau[i__1].r = z__1.r, tau[i__1].i = z__1.i;
i__1 = k;
if ((tau[i__1].r != 0. || tau[i__1].i != 0.) && k > 1) {
/* We now perform the operation A := A*P( k )'. */
/* Use the first ( k - 1 ) elements of TAU to store a( k ), */
/* where a( k ) consists of the first ( k - 1 ) elements of */
/* the kth column of A. Also let B denote the first */
/* ( k - 1 ) rows of the last ( n - m ) columns of A. */
i__1 = k - 1;
zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &tau[1], &c__1);
/* Form w = a( k ) + B*z( k ) in TAU. */
i__1 = k - 1;
i__2 = *n - *m;
zgemv_("No transpose", &i__1, &i__2, &c_b1, &a[m1 * a_dim1 +
1], lda, &a[k + m1 * a_dim1], lda, &c_b1, &tau[1], &
c__1);
/* Now form a( k ) := a( k ) - conjg(tau)*w */
/* and B := B - conjg(tau)*w*z( k )'. */
i__1 = k - 1;
d_cnjg(&z__2, &tau[k]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zaxpy_(&i__1, &z__1, &tau[1], &c__1, &a[k * a_dim1 + 1], &
c__1);
i__1 = k - 1;
i__2 = *n - *m;
d_cnjg(&z__2, &tau[k]);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(&i__1, &i__2, &z__1, &tau[1], &c__1, &a[k + m1 *
a_dim1], lda, &a[m1 * a_dim1 + 1], lda);
}
/* L20: */
}
}
return 0;
/* End of ZTZRQF */
} /* ztzrqf_ */
/* 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 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 zlatme_(integer *n, char *dist, integer *iseed,
doublecomplex *d, integer *mode, doublereal *cond, doublecomplex *
dmax__, char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
integer *modes, doublereal *conds, integer *kl, integer *ku,
doublereal *anorm, doublecomplex *a, integer *lda, doublecomplex *
work, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static logical bads;
static integer isim;
static doublereal temp;
static integer i, j;
static doublecomplex alpha;
extern logical lsame_(char *, char *);
static integer iinfo;
static doublereal tempa[1];
static integer icols;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer idist;
extern /* Subroutine */ int zscal_(integer *, doublecomplex *,
doublecomplex *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer irows;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), dlatm1_(integer *, doublereal *,
integer *, integer *, integer *, doublereal *, integer *, integer
*), zlatm1_(integer *, doublereal *, integer *, integer *,
integer *, doublecomplex *, integer *, integer *);
static integer ic, jc, ir;
static doublereal ralpha;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zdscal_(integer *, doublereal *,
doublecomplex *, integer *), zlarge_(integer *, doublecomplex *,
integer *, integer *, doublecomplex *, integer *), zlarfg_(
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
static integer irsign;
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static integer iupper;
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
static doublecomplex xnorms;
static integer jcr;
static doublecomplex tau;
/* -- LAPACK test 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
=======
ZLATME generates random non-symmetric square matrices with
specified eigenvalues for testing LAPACK programs.
ZLATME operates by applying the following sequence of
operations:
1. Set the diagonal to D, where D may be input or
computed according to MODE, COND, DMAX, and RSIGN
as described below.
2. If UPPER='T', the upper triangle of A is set to random values
out of distribution DIST.
3. If SIM='T', A is multiplied on the left by a random matrix
X, whose singular values are specified by DS, MODES, and
CONDS, and on the right by X inverse.
4. If KL < N-1, the lower bandwidth is reduced to KL using
Householder transformations. If KU < N-1, the upper
bandwidth is reduced to KU.
5. If ANORM is not negative, the matrix is scaled to have
maximum-element-norm ANORM.
(Note: since the matrix cannot be reduced beyond Hessenberg form,
no packing options are available.)
Arguments
=========
N - INTEGER
The number of columns (or rows) of A. Not modified.
DIST - CHARACTER*1
On entry, DIST specifies the type of distribution to be used
to generate the random eigen-/singular values, and on the
upper triangle (see UPPER).
'U' => UNIFORM( 0, 1 ) ( 'U' for uniform )
'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
'N' => NORMAL( 0, 1 ) ( 'N' for normal )
'D' => uniform on the complex disc |z| < 1.
Not modified.
ISEED - INTEGER array, dimension ( 4 )
On entry ISEED specifies the seed of the random number
generator. They should lie between 0 and 4095 inclusive,
and ISEED(4) should be odd. The random number generator
uses a linear congruential sequence limited to small
integers, and so should produce machine independent
random numbers. The values of ISEED are changed on
exit, and can be used in the next call to ZLATME
to continue the same random number sequence.
Changed on exit.
D - COMPLEX*16 array, dimension ( N )
This array is used to specify the eigenvalues of A. If
MODE=0, then D is assumed to contain the eigenvalues
otherwise they will be computed according to MODE, COND,
DMAX, and RSIGN and placed in D.
Modified if MODE is nonzero.
MODE - INTEGER
On entry this describes how the eigenvalues are to
be specified:
MODE = 0 means use D as input
MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
MODE = 5 sets D to random numbers in the range
( 1/COND , 1 ) such that their logarithms
are uniformly distributed.
MODE = 6 set D to random numbers from same distribution
as the rest of the matrix.
MODE < 0 has the same meaning as ABS(MODE), except that
the order of the elements of D is reversed.
Thus if MODE is between 1 and 4, D has entries ranging
from 1 to 1/COND, if between -1 and -4, D has entries
ranging from 1/COND to 1,
Not modified.
COND - DOUBLE PRECISION
On entry, this is used as described under MODE above.
If used, it must be >= 1. Not modified.
DMAX - COMPLEX*16
If MODE is neither -6, 0 nor 6, the contents of D, as
computed according to MODE and COND, will be scaled by
DMAX / max(abs(D(i))). Note that DMAX need not be
positive or real: if DMAX is negative or complex (or zero),
D will be scaled by a negative or complex number (or zero).
If RSIGN='F' then the largest (absolute) eigenvalue will be
equal to DMAX.
Not modified.
EI - CHARACTER*1 (ignored)
Not modified.
RSIGN - CHARACTER*1
If MODE is not 0, 6, or -6, and RSIGN='T', then the
elements of D, as computed according to MODE and COND, will
be multiplied by a random complex number from the unit
circle |z| = 1. If RSIGN='F', they will not be. RSIGN may
only have the values 'T' or 'F'.
Not modified.
UPPER - CHARACTER*1
If UPPER='T', then the elements of A above the diagonal
will be set to random numbers out of DIST. If UPPER='F',
they will not. UPPER may only have the values 'T' or 'F'.
Not modified.
SIM - CHARACTER*1
If SIM='T', then A will be operated on by a "similarity
transform", i.e., multiplied on the left by a matrix X and
on the right by X inverse. X = U S V, where U and V are
random unitary matrices and S is a (diagonal) matrix of
singular values specified by DS, MODES, and CONDS. If
SIM='F', then A will not be transformed.
Not modified.
DS - DOUBLE PRECISION array, dimension ( N )
This array is used to specify the singular values of X,
in the same way that D specifies the eigenvalues of A.
If MODE=0, the DS contains the singular values, which
may not be zero.
Modified if MODE is nonzero.
MODES - INTEGER
CONDS - DOUBLE PRECISION
Similar to MODE and COND, but for specifying the diagonal
of S. MODES=-6 and +6 are not allowed (since they would
result in randomly ill-conditioned eigenvalues.)
KL - INTEGER
This specifies the lower bandwidth of the matrix. KL=1
specifies upper Hessenberg form. If KL is at least N-1,
then A will have full lower bandwidth.
Not modified.
KU - INTEGER
This specifies the upper bandwidth of the matrix. KU=1
specifies lower Hessenberg form. If KU is at least N-1,
then A will have full upper bandwidth; if KU and KL
are both at least N-1, then A will be dense. Only one of
KU and KL may be less than N-1.
Not modified.
ANORM - DOUBLE PRECISION
If ANORM is not negative, then A will be scaled by a non-
negative real number to make the maximum-element-norm of A
to be ANORM.
Not modified.
A - COMPLEX*16 array, dimension ( LDA, N )
On exit A is the desired test matrix.
Modified.
LDA - INTEGER
LDA specifies the first dimension of A as declared in the
calling program. LDA must be at least M.
Not modified.
WORK - COMPLEX*16 array, dimension ( 3*N )
Workspace.
Modified.
INFO - INTEGER
Error code. On exit, INFO will be set to one of the
following values:
0 => normal return
-1 => N negative
-2 => DIST illegal string
-5 => MODE not in range -6 to 6
-6 => COND less than 1.0, and MODE neither -6, 0 nor 6
-9 => RSIGN is not 'T' or 'F'
-10 => UPPER is not 'T' or 'F'
-11 => SIM is not 'T' or 'F'
-12 => MODES=0 and DS has a zero singular value.
-13 => MODES is not in the range -5 to 5.
-14 => MODES is nonzero and CONDS is less than 1.
-15 => KL is less than 1.
-16 => KU is less than 1, or KL and KU are both less than
N-1.
-19 => LDA is less than M.
1 => Error return from ZLATM1 (computing D)
2 => Cannot scale to DMAX (max. eigenvalue is 0)
3 => Error return from DLATM1 (computing DS)
4 => Error return from ZLARGE
5 => Zero singular value from DLATM1.
=====================================================================
1) Decode and Test the input parameters.
Initialize flags & seed.
Parameter adjustments */
--iseed;
--d;
--ds;
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Decode DIST */
if (lsame_(dist, "U")) {
idist = 1;
} else if (lsame_(dist, "S")) {
idist = 2;
} else if (lsame_(dist, "N")) {
idist = 3;
} else if (lsame_(dist, "D")) {
idist = 4;
} else {
idist = -1;
}
/* Decode RSIGN */
if (lsame_(rsign, "T")) {
irsign = 1;
} else if (lsame_(rsign, "F")) {
irsign = 0;
} else {
irsign = -1;
}
/* Decode UPPER */
if (lsame_(upper, "T")) {
iupper = 1;
} else if (lsame_(upper, "F")) {
iupper = 0;
} else {
iupper = -1;
}
/* Decode SIM */
if (lsame_(sim, "T")) {
isim = 1;
} else if (lsame_(sim, "F")) {
isim = 0;
} else {
isim = -1;
}
/* Check DS, if MODES=0 and ISIM=1 */
bads = FALSE_;
if (*modes == 0 && isim == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (ds[j] == 0.) {
bads = TRUE_;
}
/* L10: */
}
}
/* Set INFO if an error */
if (*n < 0) {
*info = -1;
} else if (idist == -1) {
*info = -2;
} else if (abs(*mode) > 6) {
*info = -5;
} else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
*info = -6;
} else if (irsign == -1) {
*info = -9;
} else if (iupper == -1) {
*info = -10;
} else if (isim == -1) {
*info = -11;
} else if (bads) {
*info = -12;
} else if (isim == 1 && abs(*modes) > 5) {
*info = -13;
} else if (isim == 1 && *modes != 0 && *conds < 1.) {
*info = -14;
} else if (*kl < 1) {
*info = -15;
} else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
*info = -16;
} else if (*lda < max(1,*n)) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATME", &i__1);
return 0;
}
/* Initialize random number generator */
for (i = 1; i <= 4; ++i) {
iseed[i] = (i__1 = iseed[i], abs(i__1)) % 4096;
/* L20: */
}
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* 2) Set up diagonal of A
Compute D according to COND and MODE */
zlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d[1], n, &iinfo);
if (iinfo != 0) {
*info = 1;
return 0;
}
if (*mode != 0 && abs(*mode) != 6) {
/* Scale by DMAX */
temp = z_abs(&d[1]);
i__1 = *n;
for (i = 2; i <= i__1; ++i) {
/* Computing MAX */
d__1 = temp, d__2 = z_abs(&d[i]);
temp = max(d__1,d__2);
/* L30: */
}
if (temp > 0.) {
z__1.r = dmax__->r / temp, z__1.i = dmax__->i / temp;
alpha.r = z__1.r, alpha.i = z__1.i;
} else {
*info = 2;
return 0;
}
zscal_(n, &alpha, &d[1], &c__1);
}
zlaset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
i__1 = *lda + 1;
zcopy_(n, &d[1], &c__1, &a[a_offset], &i__1);
/* 3) If UPPER='T', set upper triangle of A to random numbers. */
if (iupper != 0) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
i__2 = jc - 1;
zlarnv_(&idist, &iseed[1], &i__2, &a[jc * a_dim1 + 1]);
/* L40: */
}
}
/* 4) If SIM='T', apply similarity transformation.
-1
Transform is X A X , where X = U S V, thus
it is U S V A V' (1/S) U' */
if (isim != 0) {
/* Compute S (singular values of the eigenvector matrix)
according to CONDS and MODES */
dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
/* Multiply by V and V' */
zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
/* Multiply by S and (1/S) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zdscal_(n, &ds[j], &a[j + a_dim1], lda);
if (ds[j] != 0.) {
d__1 = 1. / ds[j];
zdscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
} else {
*info = 5;
return 0;
}
/* L50: */
}
/* Multiply by U and U' */
zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
}
/* 5) Reduce the bandwidth. */
if (*kl < *n - 1) {
/* Reduce bandwidth -- kill column */
i__1 = *n - 1;
for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
ic = jcr - *kl;
irows = *n + 1 - jcr;
icols = *n + *kl - jcr;
zcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
xnorms.r = work[1].r, xnorms.i = work[1].i;
zlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
d_cnjg(&z__1, &tau);
tau.r = z__1.r, tau.i = z__1.i;
work[1].r = 1., work[1].i = 0.;
zlarnd_(&z__1, &c__5, &iseed[1]);
alpha.r = z__1.r, alpha.i = z__1.i;
zgemv_("C", &irows, &icols, &c_b2, &a[jcr + (ic + 1) * a_dim1],
lda, &work[1], &c__1, &c_b1, &work[irows + 1], &c__1);
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&irows, &icols, &z__1, &work[1], &c__1, &work[irows + 1], &
c__1, &a[jcr + (ic + 1) * a_dim1], lda);
zgemv_("N", n, &irows, &c_b2, &a[jcr * a_dim1 + 1], lda, &work[1],
&c__1, &c_b1, &work[irows + 1], &c__1);
d_cnjg(&z__2, &tau);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(n, &irows, &z__1, &work[irows + 1], &c__1, &work[1], &c__1,
&a[jcr * a_dim1 + 1], lda);
i__2 = jcr + ic * a_dim1;
a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
i__2 = irows - 1;
zlaset_("Full", &i__2, &c__1, &c_b1, &c_b1, &a[jcr + 1 + ic *
a_dim1], lda);
i__2 = icols + 1;
zscal_(&i__2, &alpha, &a[jcr + ic * a_dim1], lda);
d_cnjg(&z__1, &alpha);
zscal_(n, &z__1, &a[jcr * a_dim1 + 1], &c__1);
/* L60: */
}
} else if (*ku < *n - 1) {
/* Reduce upper bandwidth -- kill a row at a time. */
i__1 = *n - 1;
for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
ir = jcr - *ku;
irows = *n + *ku - jcr;
icols = *n + 1 - jcr;
zcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
xnorms.r = work[1].r, xnorms.i = work[1].i;
zlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
d_cnjg(&z__1, &tau);
tau.r = z__1.r, tau.i = z__1.i;
work[1].r = 1., work[1].i = 0.;
i__2 = icols - 1;
zlacgv_(&i__2, &work[2], &c__1);
zlarnd_(&z__1, &c__5, &iseed[1]);
alpha.r = z__1.r, alpha.i = z__1.i;
zgemv_("N", &irows, &icols, &c_b2, &a[ir + 1 + jcr * a_dim1], lda,
&work[1], &c__1, &c_b1, &work[icols + 1], &c__1);
z__1.r = -tau.r, z__1.i = -tau.i;
zgerc_(&irows, &icols, &z__1, &work[icols + 1], &c__1, &work[1], &
c__1, &a[ir + 1 + jcr * a_dim1], lda);
zgemv_("C", &icols, n, &c_b2, &a[jcr + a_dim1], lda, &work[1], &
c__1, &c_b1, &work[icols + 1], &c__1);
d_cnjg(&z__2, &tau);
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(&icols, n, &z__1, &work[1], &c__1, &work[icols + 1], &c__1,
&a[jcr + a_dim1], lda);
i__2 = ir + jcr * a_dim1;
a[i__2].r = xnorms.r, a[i__2].i = xnorms.i;
i__2 = icols - 1;
zlaset_("Full", &c__1, &i__2, &c_b1, &c_b1, &a[ir + (jcr + 1) *
a_dim1], lda);
i__2 = irows + 1;
zscal_(&i__2, &alpha, &a[ir + jcr * a_dim1], &c__1);
d_cnjg(&z__1, &alpha);
zscal_(n, &z__1, &a[jcr + a_dim1], lda);
/* L70: */
}
}
/* Scale the matrix to have norm ANORM */
if (*anorm >= 0.) {
temp = zlange_("M", n, n, &a[a_offset], lda, tempa);
if (temp > 0.) {
ralpha = *anorm / temp;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
zdscal_(n, &ralpha, &a[j * a_dim1 + 1], &c__1);
/* L80: */
}
}
}
return 0;
/* End of ZLATME */
} /* zlatme_ */
/* Subroutine */ int zlaror_slu(char *side, char *init, integer *m, integer *n,
doublecomplex *a, integer *lda, integer *iseed, doublecomplex *x,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2;
/* Builtin functions */
double z_abs(doublecomplex *);
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer kbeg, jcol;
static doublereal xabs;
static integer irow, j;
static doublecomplex csign;
extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zscal_(integer *, doublecomplex *,
doublecomplex *, integer *);
static integer ixfrm;
extern /* Subroutine */ int zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static integer itype, nxfrm;
static doublereal xnorm;
extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
extern int input_error(char *, int *);
static doublereal factor;
extern /* Subroutine */ int zlacgv_slu(integer *, doublecomplex *, integer *)
;
extern /* Double Complex */ VOID zlarnd_slu(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlaset_slu(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
static doublecomplex xnorms;
/* -- LAPACK auxiliary test 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
=======
ZLAROR pre- or post-multiplies an M by N matrix A by a random
unitary matrix U, overwriting A. A may optionally be
initialized to the identity matrix before multiplying by U.
U is generated using the method of G.W. Stewart
( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ).
(BLAS-2 version)
Arguments
=========
SIDE - CHARACTER*1
SIDE specifies whether A is multiplied on the left or right
by U.
SIDE = 'L' Multiply A on the left (premultiply) by U
SIDE = 'R' Multiply A on the right (postmultiply) by U*
SIDE = 'C' Multiply A on the left by U and the right by U*
SIDE = 'T' Multiply A on the left by U and the right by U'
Not modified.
INIT - CHARACTER*1
INIT specifies whether or not A should be initialized to
the identity matrix.
INIT = 'I' Initialize A to (a section of) the
identity matrix before applying U.
INIT = 'N' No initialization. Apply U to the
input matrix A.
INIT = 'I' may be used to generate square (i.e., unitary)
or rectangular orthogonal matrices (orthogonality being
in the sense of ZDOTC):
For square matrices, M=N, and SIDE many be either 'L' or
'R'; the rows will be orthogonal to each other, as will the
columns.
For rectangular matrices where M < N, SIDE = 'R' will
produce a dense matrix whose rows will be orthogonal and
whose columns will not, while SIDE = 'L' will produce a
matrix whose rows will be orthogonal, and whose first M
columns will be orthogonal, the remaining columns being
zero.
For matrices where M > N, just use the previous
explaination, interchanging 'L' and 'R' and "rows" and
"columns".
Not modified.
M - INTEGER
Number of rows of A. Not modified.
N - INTEGER
Number of columns of A. Not modified.
A - COMPLEX*16 array, dimension ( LDA, N )
Input and output array. Overwritten by U A ( if SIDE = 'L' )
or by A U ( if SIDE = 'R' )
or by U A U* ( if SIDE = 'C')
or by U A U' ( if SIDE = 'T') on exit.
LDA - INTEGER
Leading dimension of A. Must be at least MAX ( 1, M ).
Not modified.
ISEED - INTEGER array, dimension ( 4 )
On entry ISEED specifies the seed of the random number
generator. The array elements should be between 0 and 4095;
if not they will be reduced mod 4096. Also, ISEED(4) must
be odd. The random number generator uses a linear
congruential sequence limited to small integers, and so
should produce machine independent random numbers. The
values of ISEED are changed on exit, and can be used in the
next call to ZLAROR to continue the same random number
sequence.
Modified.
X - COMPLEX*16 array, dimension ( 3*MAX( M, N ) )
Workspace. Of length:
2*M + N if SIDE = 'L',
2*N + M if SIDE = 'R',
3*N if SIDE = 'C' or 'T'.
Modified.
INFO - INTEGER
An error flag. It is set to:
0 if no error.
1 if ZLARND returned a bad random number (installation
problem)
-1 if SIDE is not L, R, C, or T.
-3 if M is negative.
-4 if N is negative or if SIDE is C or T and N is not equal
to M.
-6 if LDA is less than M.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = a_dim1 + 1;
a -= a_offset;
--iseed;
--x;
/* Function Body */
if (*n == 0 || *m == 0) {
return 0;
}
itype = 0;
if (strncmp(side, "L", 1)==0) {
itype = 1;
} else if (strncmp(side, "R", 1)==0) {
itype = 2;
} else if (strncmp(side, "C", 1)==0) {
itype = 3;
} else if (strncmp(side, "T", 1)==0) {
itype = 4;
}
/* Check for argument errors. */
*info = 0;
if (itype == 0) {
*info = -1;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0 || itype == 3 && *n != *m) {
*info = -4;
} else if (*lda < *m) {
*info = -6;
}
if (*info != 0) {
i__1 = -(*info);
input_error("ZLAROR", &i__1);
return 0;
}
if (itype == 1) {
nxfrm = *m;
} else {
nxfrm = *n;
}
/* Initialize A to the identity matrix if desired */
if (strncmp(init, "I", 1)==0) {
zlaset_slu("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda);
}
/* If no rotation possible, still multiply by
a random complex number from the circle |x| = 1
2) Compute Rotation by computing Householder
Transformations H(2), H(3), ..., H(n). Note that the
order in which they are computed is irrelevant. */
i__1 = nxfrm;
for (j = 1; j <= i__1; ++j) {
i__2 = j;
x[i__2].r = 0., x[i__2].i = 0.;
/* L10: */
}
i__1 = nxfrm;
for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
kbeg = nxfrm - ixfrm + 1;
/* Generate independent normal( 0, 1 ) random numbers */
i__2 = nxfrm;
for (j = kbeg; j <= i__2; ++j) {
i__3 = j;
zlarnd_slu(&z__1, &c__3, &iseed[1]);
x[i__3].r = z__1.r, x[i__3].i = z__1.i;
/* L20: */
}
/* Generate a Householder transformation from the random vector
X */
xnorm = dznrm2_(&ixfrm, &x[kbeg], &c__1);
xabs = z_abs(&x[kbeg]);
if (xabs != 0.) {
i__2 = kbeg;
z__1.r = x[i__2].r / xabs, z__1.i = x[i__2].i / xabs;
csign.r = z__1.r, csign.i = z__1.i;
} else {
csign.r = 1., csign.i = 0.;
}
z__1.r = xnorm * csign.r, z__1.i = xnorm * csign.i;
xnorms.r = z__1.r, xnorms.i = z__1.i;
i__2 = nxfrm + kbeg;
z__1.r = -csign.r, z__1.i = -csign.i;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
factor = xnorm * (xnorm + xabs);
if (abs(factor) < 1e-20) {
*info = 1;
i__2 = -(*info);
input_error("ZLAROR", &i__2);
return 0;
} else {
factor = 1. / factor;
}
i__2 = kbeg;
i__3 = kbeg;
z__1.r = x[i__3].r + xnorms.r, z__1.i = x[i__3].i + xnorms.i;
x[i__2].r = z__1.r, x[i__2].i = z__1.i;
/* Apply Householder transformation to A */
if (itype == 1 || itype == 3 || itype == 4) {
/* Apply H(k) on the left of A */
zgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], &
c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
z__2.r = factor, z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(&ixfrm, n, &z__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
c__1, &a[kbeg + a_dim1], lda);
}
if (itype >= 2 && itype <= 4) {
/* Apply H(k)* (or H(k)') on the right of A */
if (itype == 4) {
zlacgv_slu(&ixfrm, &x[kbeg], &c__1);
}
zgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg]
, &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
z__2.r = factor, z__2.i = 0.;
z__1.r = -z__2.r, z__1.i = -z__2.i;
zgerc_(m, &ixfrm, &z__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
c__1, &a[kbeg * a_dim1 + 1], lda);
}
/* L30: */
}
zlarnd_slu(&z__1, &c__3, &iseed[1]);
x[1].r = z__1.r, x[1].i = z__1.i;
xabs = z_abs(&x[1]);
if (xabs != 0.) {
z__1.r = x[1].r / xabs, z__1.i = x[1].i / xabs;
csign.r = z__1.r, csign.i = z__1.i;
} else {
csign.r = 1., csign.i = 0.;
}
i__1 = nxfrm << 1;
x[i__1].r = csign.r, x[i__1].i = csign.i;
/* Scale the matrix A by D. */
if (itype == 1 || itype == 3 || itype == 4) {
i__1 = *m;
for (irow = 1; irow <= i__1; ++irow) {
d_cnjg(&z__1, &x[nxfrm + irow]);
zscal_(n, &z__1, &a[irow + a_dim1], lda);
/* L40: */
}
}
if (itype == 2 || itype == 3) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
zscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
/* L50: */
}
}
if (itype == 4) {
i__1 = *n;
for (jcol = 1; jcol <= i__1; ++jcol) {
d_cnjg(&z__1, &x[nxfrm + jcol]);
zscal_(m, &z__1, &a[jcol * a_dim1 + 1], &c__1);
/* L60: */
}
}
return 0;
/* End of ZLAROR */
} /* zlaror_slu */
/* Subroutine */ int zlarf_(char *side, integer *m, integer *n, doublecomplex
*v, integer *incv, doublecomplex *tau, doublecomplex *c__, integer *
ldc, doublecomplex *work, ftnlen side_len)
{
/* System generated locals */
integer c_dim1, c_offset;
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);
/* -- 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 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARF 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. */
/* 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. */
/* V (input) COMPLEX*16 array, dimension */
/* (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
/* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
/* The vector v in the representation of H. 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' */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--v;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--work;
/* Function Body */
if (lsame_(side, "L", (ftnlen)1, (ftnlen)1)) {
/* Form H * C */
if (tau->r != 0. || tau->i != 0.) {
/* w := C' * v */
zgemv_("Conjugate transpose", m, n, &c_b1, &c__[c_offset], ldc, &
v[1], incv, &c_b2, &work[1], &c__1, (ftnlen)19);
/* C := C - v * w' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, n, &z__1, &v[1], incv, &work[1], &c__1, &c__[c_offset],
ldc);
}
} else {
/* Form C * H */
if (tau->r != 0. || tau->i != 0.) {
/* w := C * v */
zgemv_("No transpose", m, n, &c_b1, &c__[c_offset], ldc, &v[1],
incv, &c_b2, &work[1], &c__1, (ftnlen)12);
/* C := C - w * v' */
z__1.r = -tau->r, z__1.i = -tau->i;
zgerc_(m, n, &z__1, &work[1], &c__1, &v[1], incv, &c__[c_offset],
ldc);
}
}
return 0;
/* End of ZLARF */
} /* zlarf_ */
