/* Subroutine */ int zunmr3_(char *side, char *trans, integer *m, integer *n,
integer *k, integer *l, doublecomplex *a, integer *lda, doublecomplex
*tau, doublecomplex *c__, integer *ldc, doublecomplex *work, 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
=======
ZUNMR3 overwrites the general complex m by n matrix C with
Q * C if SIDE = 'L' and TRANS = 'N', or
Q'* C if SIDE = 'L' and TRANS = 'C', or
C * Q if SIDE = 'R' and TRANS = 'N', or
C * Q' if SIDE = 'R' and TRANS = 'C',
where Q is a complex unitary matrix defined as the product of k
elementary reflectors
Q = H(1) H(2) . . . H(k)
as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n
if SIDE = 'R'.
Arguments
=========
SIDE (input) CHARACTER*1
= 'L': apply Q or Q' from the Left
= 'R': apply Q or Q' from the Right
TRANS (input) CHARACTER*1
= 'N': apply Q (No transpose)
= 'C': apply Q' (Conjugate transpose)
M (input) INTEGER
The number of rows of the matrix C. M >= 0.
N (input) INTEGER
The number of columns of the matrix C. N >= 0.
K (input) INTEGER
The number of elementary reflectors whose product defines
the matrix Q.
If SIDE = 'L', M >= K >= 0;
if SIDE = 'R', N >= K >= 0.
L (input) INTEGER
The number of columns of the matrix A containing
the meaningful part of the Householder reflectors.
If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
A (input) COMPLEX*16 array, dimension
(LDA,M) if SIDE = 'L',
(LDA,N) if SIDE = 'R'
The i-th row must contain the vector which defines the
elementary reflector H(i), for i = 1,2,...,k, as returned by
ZTZRZF in the last k rows of its array argument A.
A is modified by the routine but restored on exit.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,K).
TAU (input) COMPLEX*16 array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i), as returned by ZTZRZF.
C (input/output) COMPLEX*16 array, dimension (LDC,N)
On entry, the m-by-n matrix C.
On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
LDC (input) INTEGER
The leading dimension of the array C. LDC >= max(1,M).
WORK (workspace) COMPLEX*16 array, dimension
(N) if SIDE = 'L',
(M) if SIDE = 'R'
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
Further Details
===============
Based on contributions by
A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
=====================================================================
Test the input arguments
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static logical left;
static doublecomplex taui;
static integer i__;
extern logical lsame_(char *, char *);
static integer i1, i2, i3;
extern /* Subroutine */ int zlarz_(char *, integer *, integer *, integer *
, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *);
static integer ja, ic, jc, mi, ni, nq;
extern /* Subroutine */ int xerbla_(char *, integer *);
static logical notran;
#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;
--tau;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--work;
/* Function Body */
*info = 0;
left = lsame_(side, "L");
notran = lsame_(trans, "N");
/* NQ is the order of Q */
if (left) {
nq = *m;
} else {
nq = *n;
}
if (! left && ! lsame_(side, "R")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "C")) {
*info = -2;
} else if (*m < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > nq) {
*info = -5;
} else if (*l < 0 || left && *l > *m || ! left && *l > *n) {
*info = -6;
} else if (*lda < max(1,*k)) {
*info = -8;
} else if (*ldc < max(1,*m)) {
*info = -11;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZUNMR3", &i__1);
return 0;
}
/* Quick return if possible */
if (*m == 0 || *n == 0 || *k == 0) {
return 0;
}
if (left && ! notran || ! left && notran) {
i1 = 1;
i2 = *k;
i3 = 1;
} else {
i1 = *k;
i2 = 1;
i3 = -1;
}
if (left) {
ni = *n;
ja = *m - *l + 1;
jc = 1;
} else {
mi = *m;
ja = *n - *l + 1;
ic = 1;
}
i__1 = i2;
i__2 = i3;
for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
if (left) {
/* H(i) or H(i)' is applied to C(i:m,1:n) */
mi = *m - i__ + 1;
ic = i__;
} else {
/* H(i) or H(i)' is applied to C(1:m,i:n) */
ni = *n - i__ + 1;
jc = i__;
}
/* Apply H(i) or H(i)' */
if (notran) {
i__3 = i__;
taui.r = tau[i__3].r, taui.i = tau[i__3].i;
} else {
d_cnjg(&z__1, &tau[i__]);
taui.r = z__1.r, taui.i = z__1.i;
}
zlarz_(side, &mi, &ni, l, &a_ref(i__, ja), lda, &taui, &c___ref(ic,
jc), ldc, &work[1]);
/* L10: */
}
return 0;
/* End of ZUNMR3 */
} /* zunmr3_ */
/* Subroutine */ int zlatrz_(integer *m, integer *n, integer *l,
doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *
work)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublecomplex z__1;
/* Builtin functions */
void d_cnjg(doublecomplex *, doublecomplex *);
/* Local variables */
static integer i__;
static doublecomplex alpha;
extern /* Subroutine */ int zlarz_(char *, integer *, integer *, integer *
, doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, ftnlen), zlarfg_(integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *),
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 */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix */
/* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means */
/* of unitary transformations, where Z is an (M+L)-by-(M+L) unitary */
/* matrix and, R and A1 are M-by-M upper triangular matrices. */
/* 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. */
/* L (input) INTEGER */
/* The number of columns of the matrix A containing the */
/* meaningful part of the Householder vectors. N-M >= L >= 0. */
/* 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 N-L+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. */
/* WORK (workspace) COMPLEX*16 array, dimension (M) */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */
/* The factorization is obtained by Householder's method. The kth */
/* transformation matrix, Z( k ), which 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 l element vector. tau and z( k ) */
/* are chosen to annihilate the elements of the kth row of A2. */
/* The scalar tau is returned in the kth element of TAU and the vector */
/* u( k ) in the kth row of A2, such that the elements of z( k ) are */
/* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */
/* the upper triangular part of A1. */
/* Z is given by */
/* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--tau;
--work;
/* Function Body */
if (*m == 0) {
return 0;
} else 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: */
}
return 0;
}
for (i__ = *m; i__ >= 1; --i__) {
/* Generate elementary reflector H(i) to annihilate */
/* [ A(i,i) A(i,n-l+1:n) ] */
zlacgv_(l, &a[i__ + (*n - *l + 1) * a_dim1], lda);
d_cnjg(&z__1, &a[i__ + i__ * a_dim1]);
alpha.r = z__1.r, alpha.i = z__1.i;
i__1 = *l + 1;
zlarfg_(&i__1, &alpha, &a[i__ + (*n - *l + 1) * a_dim1], lda, &tau[
i__]);
i__1 = i__;
d_cnjg(&z__1, &tau[i__]);
tau[i__1].r = z__1.r, tau[i__1].i = z__1.i;
/* Apply H(i) to A(1:i-1,i:n) from the right */
i__1 = i__ - 1;
i__2 = *n - i__ + 1;
d_cnjg(&z__1, &tau[i__]);
zlarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1],
lda, &z__1, &a[i__ * a_dim1 + 1], lda, &work[1], (ftnlen)5);
i__1 = i__ + i__ * a_dim1;
d_cnjg(&z__1, &alpha);
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/* L20: */
}
return 0;
/* End of ZLATRZ */
} /* zlatrz_ */
