/* Subroutine */ int clarft_(char *direct, char *storev, integer *n, integer *
k, complex *v, integer *ldv, complex *tau, complex *t, integer *ldt)
{
/* -- 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
=======
CLARFT forms the triangular factor T of a complex block reflector H
of order n, which is defined as a product of k elementary reflectors.
If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
If STOREV = 'C', the vector which defines the elementary reflector
H(i) is stored in the i-th column of the array V, and
H = I - V * T * V'
If STOREV = 'R', the vector which defines the elementary reflector
H(i) is stored in the i-th row of the array V, and
H = I - V' * T * V
Arguments
=========
DIRECT (input) CHARACTER*1
Specifies the order in which the elementary reflectors are
multiplied to form the block reflector:
= 'F': H = H(1) H(2) . . . H(k) (Forward)
= 'B': H = H(k) . . . H(2) H(1) (Backward)
STOREV (input) CHARACTER*1
Specifies how the vectors which define the elementary
reflectors are stored (see also Further Details):
= 'C': columnwise
= 'R': rowwise
N (input) INTEGER
The order of the block reflector H. N >= 0.
K (input) INTEGER
The order of the triangular factor T (= the number of
elementary reflectors). K >= 1.
V (input/output) COMPLEX array, dimension
(LDV,K) if STOREV = 'C'
(LDV,N) if STOREV = 'R'
The matrix V. See further details.
LDV (input) INTEGER
The leading dimension of the array V.
If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
TAU (input) COMPLEX array, dimension (K)
TAU(i) must contain the scalar factor of the elementary
reflector H(i).
T (output) COMPLEX array, dimension (LDT,K)
The k by k triangular factor T of the block reflector.
If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
lower triangular. The rest of the array is not used.
LDT (input) INTEGER
The leading dimension of the array T. LDT >= K.
Further Details
===============
The shape of the matrix V and the storage of the vectors which define
the H(i) is best illustrated by the following example with n = 5 and
k = 3. The elements equal to 1 are not stored; the corresponding
array elements are modified but restored on exit. The rest of the
array is not used.
DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
( v1 1 ) ( 1 v2 v2 v2 )
( v1 v2 1 ) ( 1 v3 v3 )
( v1 v2 v3 )
( v1 v2 v3 )
DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
V = ( v1 v2 v3 ) V = ( v1 v1 1 )
( v1 v2 v3 ) ( v2 v2 v2 1 )
( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
( 1 v3 )
( 1 )
=====================================================================
Quick return if possible
Parameter adjustments */
/* Table of constant values */
static complex c_b2 = {0.f,0.f};
static integer c__1 = 1;
/* System generated locals */
integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
complex q__1;
/* Local variables */
static integer i__, j;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int ctrmv_(char *, char *, char *, integer *,
complex *, integer *, complex *, integer *), clacgv_(integer *, complex *, integer *);
static complex vii;
#define t_subscr(a_1,a_2) (a_2)*t_dim1 + a_1
#define t_ref(a_1,a_2) t[t_subscr(a_1,a_2)]
#define v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1
#define v_ref(a_1,a_2) v[v_subscr(a_1,a_2)]
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
--tau;
t_dim1 = *ldt;
t_offset = 1 + t_dim1 * 1;
t -= t_offset;
/* Function Body */
if (*n == 0) {
return 0;
}
if (lsame_(direct, "F")) {
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
if (tau[i__2].r == 0.f && tau[i__2].i == 0.f) {
/* H(i) = I */
i__2 = i__;
for (j = 1; j <= i__2; ++j) {
i__3 = t_subscr(j, i__);
t[i__3].r = 0.f, t[i__3].i = 0.f;
/* L10: */
}
} else {
/* general case */
i__2 = v_subscr(i__, i__);
vii.r = v[i__2].r, vii.i = v[i__2].i;
i__2 = v_subscr(i__, i__);
v[i__2].r = 1.f, v[i__2].i = 0.f;
if (lsame_(storev, "C")) {
/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) */
i__2 = *n - i__ + 1;
i__3 = i__ - 1;
i__4 = i__;
q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i;
cgemv_("Conjugate transpose", &i__2, &i__3, &q__1, &v_ref(
i__, 1), ldv, &v_ref(i__, i__), &c__1, &c_b2, &
t_ref(1, i__), &c__1);
} else {
/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' */
if (i__ < *n) {
i__2 = *n - i__;
clacgv_(&i__2, &v_ref(i__, i__ + 1), ldv);
}
i__2 = i__ - 1;
i__3 = *n - i__ + 1;
i__4 = i__;
q__1.r = -tau[i__4].r, q__1.i = -tau[i__4].i;
cgemv_("No transpose", &i__2, &i__3, &q__1, &v_ref(1, i__)
, ldv, &v_ref(i__, i__), ldv, &c_b2, &t_ref(1,
i__), &c__1);
if (i__ < *n) {
i__2 = *n - i__;
clacgv_(&i__2, &v_ref(i__, i__ + 1), ldv);
}
}
i__2 = v_subscr(i__, i__);
v[i__2].r = vii.r, v[i__2].i = vii.i;
/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
i__2 = i__ - 1;
ctrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
t_offset], ldt, &t_ref(1, i__), &c__1);
i__2 = t_subscr(i__, i__);
i__3 = i__;
t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i;
}
/* L20: */
}
} else {
for (i__ = *k; i__ >= 1; --i__) {
i__1 = i__;
if (tau[i__1].r == 0.f && tau[i__1].i == 0.f) {
/* H(i) = I */
i__1 = *k;
for (j = i__; j <= i__1; ++j) {
i__2 = t_subscr(j, i__);
t[i__2].r = 0.f, t[i__2].i = 0.f;
/* L30: */
}
} else {
/* general case */
if (i__ < *k) {
if (lsame_(storev, "C")) {
i__1 = v_subscr(*n - *k + i__, i__);
vii.r = v[i__1].r, vii.i = v[i__1].i;
i__1 = v_subscr(*n - *k + i__, i__);
v[i__1].r = 1.f, v[i__1].i = 0.f;
/* T(i+1:k,i) :=
- tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) */
i__1 = *n - *k + i__;
i__2 = *k - i__;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cgemv_("Conjugate transpose", &i__1, &i__2, &q__1, &
v_ref(1, i__ + 1), ldv, &v_ref(1, i__), &c__1,
&c_b2, &t_ref(i__ + 1, i__), &c__1);
i__1 = v_subscr(*n - *k + i__, i__);
v[i__1].r = vii.r, v[i__1].i = vii.i;
} else {
i__1 = v_subscr(i__, *n - *k + i__);
vii.r = v[i__1].r, vii.i = v[i__1].i;
i__1 = v_subscr(i__, *n - *k + i__);
v[i__1].r = 1.f, v[i__1].i = 0.f;
/* T(i+1:k,i) :=
- tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' */
i__1 = *n - *k + i__ - 1;
clacgv_(&i__1, &v_ref(i__, 1), ldv);
i__1 = *k - i__;
i__2 = *n - *k + i__;
i__3 = i__;
q__1.r = -tau[i__3].r, q__1.i = -tau[i__3].i;
cgemv_("No transpose", &i__1, &i__2, &q__1, &v_ref(
i__ + 1, 1), ldv, &v_ref(i__, 1), ldv, &c_b2,
&t_ref(i__ + 1, i__), &c__1);
i__1 = *n - *k + i__ - 1;
clacgv_(&i__1, &v_ref(i__, 1), ldv);
i__1 = v_subscr(i__, *n - *k + i__);
v[i__1].r = vii.r, v[i__1].i = vii.i;
}
/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
i__1 = *k - i__;
ctrmv_("Lower", "No transpose", "Non-unit", &i__1, &t_ref(
i__ + 1, i__ + 1), ldt, &t_ref(i__ + 1, i__), &
c__1);
}
i__1 = t_subscr(i__, i__);
i__2 = i__;
t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i;
}
/* L40: */
}
}
return 0;
/* End of CLARFT */
} /* clarft_ */
/* Subroutine */ int cunt03_(char *rc, integer *mu, integer *mv, integer *n,
integer *k, complex *u, integer *ldu, complex *v, integer *ldv,
complex *work, integer *lwork, real *rwork, real *result, integer *
info)
{
/* System generated locals */
integer u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4;
real r__1, r__2;
complex q__1, q__2;
/* Builtin functions */
double c_abs(complex *);
void c_div(complex *, complex *, complex *);
/* Local variables */
static integer i__, j;
static complex s;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cunt01_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, real *, real *);
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
static complex su, sv;
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer irc, lmx;
static real ulp, res1, res2;
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
#define v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1
#define v_ref(a_1,a_2) v[v_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
CUNT03 compares two unitary matrices U and V to see if their
corresponding rows or columns span the same spaces. The rows are
checked if RC = 'R', and the columns are checked if RC = 'C'.
RESULT is the maximum of
| V*V' - I | / ( MV ulp ), if RC = 'R', or
| V'*V - I | / ( MV ulp ), if RC = 'C',
and the maximum over rows (or columns) 1 to K of
| U(i) - S*V(i) |/ ( N ulp )
where abs(S) = 1 (chosen to minimize the expression), U(i) is the
i-th row (column) of U, and V(i) is the i-th row (column) of V.
Arguments
==========
RC (input) CHARACTER*1
If RC = 'R' the rows of U and V are to be compared.
If RC = 'C' the columns of U and V are to be compared.
MU (input) INTEGER
The number of rows of U if RC = 'R', and the number of
columns if RC = 'C'. If MU = 0 CUNT03 does nothing.
MU must be at least zero.
MV (input) INTEGER
The number of rows of V if RC = 'R', and the number of
columns if RC = 'C'. If MV = 0 CUNT03 does nothing.
MV must be at least zero.
N (input) INTEGER
If RC = 'R', the number of columns in the matrices U and V,
and if RC = 'C', the number of rows in U and V. If N = 0
CUNT03 does nothing. N must be at least zero.
K (input) INTEGER
The number of rows or columns of U and V to compare.
0 <= K <= max(MU,MV).
U (input) COMPLEX array, dimension (LDU,N)
The first matrix to compare. If RC = 'R', U is MU by N, and
if RC = 'C', U is N by MU.
LDU (input) INTEGER
The leading dimension of U. If RC = 'R', LDU >= max(1,MU),
and if RC = 'C', LDU >= max(1,N).
V (input) COMPLEX array, dimension (LDV,N)
The second matrix to compare. If RC = 'R', V is MV by N, and
if RC = 'C', V is N by MV.
LDV (input) INTEGER
The leading dimension of V. If RC = 'R', LDV >= max(1,MV),
and if RC = 'C', LDV >= max(1,N).
WORK (workspace) COMPLEX array, dimension (LWORK)
LWORK (input) INTEGER
The length of the array WORK. For best performance, LWORK
should be at least N*N if RC = 'C' or M*M if RC = 'R', but
the tests will be done even if LWORK is 0.
RWORK (workspace) REAL array, dimension (max(MV,N))
RESULT (output) REAL
The value computed by the test described above. RESULT is
limited to 1/ulp to avoid overflow.
INFO (output) INTEGER
0 indicates a successful exit
-k indicates the k-th parameter had an illegal value
=====================================================================
Check inputs
Parameter adjustments */
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
--work;
--rwork;
/* Function Body */
*info = 0;
if (lsame_(rc, "R")) {
irc = 0;
} else if (lsame_(rc, "C")) {
irc = 1;
} else {
irc = -1;
}
if (irc == -1) {
*info = -1;
} else if (*mu < 0) {
*info = -2;
} else if (*mv < 0) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*k < 0 || *k > max(*mu,*mv)) {
*info = -5;
} else if (irc == 0 && *ldu < max(1,*mu) || irc == 1 && *ldu < max(1,*n))
{
*info = -7;
} else if (irc == 0 && *ldv < max(1,*mv) || irc == 1 && *ldv < max(1,*n))
{
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CUNT03", &i__1);
return 0;
}
/* Initialize result */
*result = 0.f;
if (*mu == 0 || *mv == 0 || *n == 0) {
return 0;
}
/* Machine constants */
ulp = slamch_("Precision");
if (irc == 0) {
/* Compare rows */
res1 = 0.f;
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
lmx = icamax_(n, &u_ref(i__, 1), ldu);
i__2 = v_subscr(i__, lmx);
if (v[i__2].r == 0.f && v[i__2].i == 0.f) {
sv.r = 1.f, sv.i = 0.f;
} else {
r__1 = c_abs(&v_ref(i__, lmx));
q__2.r = r__1, q__2.i = 0.f;
c_div(&q__1, &q__2, &v_ref(i__, lmx));
sv.r = q__1.r, sv.i = q__1.i;
}
i__2 = u_subscr(i__, lmx);
if (u[i__2].r == 0.f && u[i__2].i == 0.f) {
su.r = 1.f, su.i = 0.f;
} else {
r__1 = c_abs(&u_ref(i__, lmx));
q__2.r = r__1, q__2.i = 0.f;
c_div(&q__1, &q__2, &u_ref(i__, lmx));
su.r = q__1.r, su.i = q__1.i;
}
c_div(&q__1, &sv, &su);
s.r = q__1.r, s.i = q__1.i;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = u_subscr(i__, j);
i__4 = v_subscr(i__, j);
q__2.r = s.r * v[i__4].r - s.i * v[i__4].i, q__2.i = s.r * v[
i__4].i + s.i * v[i__4].r;
q__1.r = u[i__3].r - q__2.r, q__1.i = u[i__3].i - q__2.i;
r__1 = res1, r__2 = c_abs(&q__1);
res1 = dmax(r__1,r__2);
/* L10: */
}
/* L20: */
}
res1 /= (real) (*n) * ulp;
/* Compute orthogonality of rows of V. */
cunt01_("Rows", mv, n, &v[v_offset], ldv, &work[1], lwork, &rwork[1],
&res2);
} else {
/* Compare columns */
res1 = 0.f;
i__1 = *k;
for (i__ = 1; i__ <= i__1; ++i__) {
lmx = icamax_(n, &u_ref(1, i__), &c__1);
i__2 = v_subscr(lmx, i__);
if (v[i__2].r == 0.f && v[i__2].i == 0.f) {
sv.r = 1.f, sv.i = 0.f;
} else {
r__1 = c_abs(&v_ref(lmx, i__));
q__2.r = r__1, q__2.i = 0.f;
c_div(&q__1, &q__2, &v_ref(lmx, i__));
sv.r = q__1.r, sv.i = q__1.i;
}
i__2 = u_subscr(lmx, i__);
if (u[i__2].r == 0.f && u[i__2].i == 0.f) {
su.r = 1.f, su.i = 0.f;
} else {
r__1 = c_abs(&u_ref(lmx, i__));
q__2.r = r__1, q__2.i = 0.f;
c_div(&q__1, &q__2, &u_ref(lmx, i__));
su.r = q__1.r, su.i = q__1.i;
}
c_div(&q__1, &sv, &su);
s.r = q__1.r, s.i = q__1.i;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = u_subscr(j, i__);
i__4 = v_subscr(j, i__);
q__2.r = s.r * v[i__4].r - s.i * v[i__4].i, q__2.i = s.r * v[
i__4].i + s.i * v[i__4].r;
q__1.r = u[i__3].r - q__2.r, q__1.i = u[i__3].i - q__2.i;
r__1 = res1, r__2 = c_abs(&q__1);
res1 = dmax(r__1,r__2);
/* L30: */
}
/* L40: */
}
res1 /= (real) (*n) * ulp;
/* Compute orthogonality of columns of V. */
cunt01_("Columns", n, mv, &v[v_offset], ldv, &work[1], lwork, &rwork[
1], &res2);
}
/* Computing MIN */
r__1 = dmax(res1,res2), r__2 = 1.f / ulp;
*result = dmin(r__1,r__2);
return 0;
/* End of CUNT03 */
} /* cunt03_ */
