/* 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_ */