/* Subroutine */ int cggsvp_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, complex *a, integer *lda, complex *b, integer *ldb, real *tola, real *tolb, integer *k, integer *l, complex *u, integer *ldu, complex *v, integer *ldv, complex *q, integer *ldq, integer *iwork, real *rwork, complex *tau, complex *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 September 30, 1994 Purpose ======= CGGSVP computes unitary matrices U, V and Q such that N-K-L K L U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; L ( 0 0 A23 ) M-K-L ( 0 0 0 ) N-K-L K L = K ( 0 A12 A13 ) if M-K-L < 0; M-K ( 0 0 A23 ) N-K-L K L V'*B*Q = L ( 0 0 B13 ) P-L ( 0 0 0 ) where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the conjugate transpose of Z. This decomposition is the preprocessing step for computing the Generalized Singular Value Decomposition (GSVD), see subroutine CGGSVD. Arguments ========= JOBU (input) CHARACTER*1 = 'U': Unitary matrix U is computed; = 'N': U is not computed. JOBV (input) CHARACTER*1 = 'V': Unitary matrix V is computed; = 'N': V is not computed. JOBQ (input) CHARACTER*1 = 'Q': Unitary matrix Q is computed; = 'N': Q is not computed. M (input) INTEGER The number of rows of the matrix A. M >= 0. P (input) INTEGER The number of rows of the matrix B. P >= 0. N (input) INTEGER The number of columns of the matrices A and B. N >= 0. A (input/output) COMPLEX array, dimension (LDA,N) On entry, the M-by-N matrix A. On exit, A contains the triangular (or trapezoidal) matrix described in the Purpose section. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,M). B (input/output) COMPLEX array, dimension (LDB,N) On entry, the P-by-N matrix B. On exit, B contains the triangular matrix described in the Purpose section. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,P). TOLA (input) REAL TOLB (input) REAL TOLA and TOLB are the thresholds to determine the effective numerical rank of matrix B and a subblock of A. Generally, they are set to TOLA = MAX(M,N)*norm(A)*MACHEPS, TOLB = MAX(P,N)*norm(B)*MACHEPS. The size of TOLA and TOLB may affect the size of backward errors of the decomposition. K (output) INTEGER L (output) INTEGER On exit, K and L specify the dimension of the subblocks described in Purpose section. K + L = effective numerical rank of (A',B')'. U (output) COMPLEX array, dimension (LDU,M) If JOBU = 'U', U contains the unitary matrix U. If JOBU = 'N', U is not referenced. LDU (input) INTEGER The leading dimension of the array U. LDU >= max(1,M) if JOBU = 'U'; LDU >= 1 otherwise. V (output) COMPLEX array, dimension (LDV,M) If JOBV = 'V', V contains the unitary matrix V. If JOBV = 'N', V is not referenced. LDV (input) INTEGER The leading dimension of the array V. LDV >= max(1,P) if JOBV = 'V'; LDV >= 1 otherwise. Q (output) COMPLEX array, dimension (LDQ,N) If JOBQ = 'Q', Q contains the unitary matrix Q. If JOBQ = 'N', Q is not referenced. LDQ (input) INTEGER The leading dimension of the array Q. LDQ >= max(1,N) if JOBQ = 'Q'; LDQ >= 1 otherwise. IWORK (workspace) INTEGER array, dimension (N) RWORK (workspace) REAL array, dimension (2*N) TAU (workspace) COMPLEX array, dimension (N) WORK (workspace) COMPLEX array, dimension (max(3*N,M,P)) INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value. Further Details =============== The subroutine uses LAPACK subroutine CGEQPF for the QR factorization with column pivoting to detect the effective numerical rank of the a matrix. It may be replaced by a better rank determination strategy. ===================================================================== Test the input parameters Parameter adjustments */ /* Table of constant values */ static complex c_b1 = {0.f,0.f}; static complex c_b2 = {1.f,0.f}; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3; real r__1, r__2; /* Builtin functions */ double r_imag(complex *); /* Local variables */ static integer i__, j; extern logical lsame_(char *, char *); static logical wantq, wantu, wantv; extern /* Subroutine */ int cgeqr2_(integer *, integer *, complex *, integer *, complex *, complex *, integer *), cgerq2_(integer *, integer *, complex *, integer *, complex *, complex *, integer *), cung2r_(integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *), cunm2r_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *), cunmr2_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *), cgeqpf_(integer *, integer *, complex *, integer *, integer *, complex *, complex *, real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *), xerbla_(char *, integer *), clapmt_(logical *, integer *, integer *, complex *, integer *, integer *); static logical forwrd; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define 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)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; u_dim1 = *ldu; u_offset = 1 + u_dim1 * 1; u -= u_offset; v_dim1 = *ldv; v_offset = 1 + v_dim1 * 1; v -= v_offset; q_dim1 = *ldq; q_offset = 1 + q_dim1 * 1; q -= q_offset; --iwork; --rwork; --tau; --work; /* Function Body */ wantu = lsame_(jobu, "U"); wantv = lsame_(jobv, "V"); wantq = lsame_(jobq, "Q"); forwrd = TRUE_; *info = 0; if (! (wantu || lsame_(jobu, "N"))) { *info = -1; } else if (! (wantv || lsame_(jobv, "N"))) { *info = -2; } else if (! (wantq || lsame_(jobq, "N"))) { *info = -3; } else if (*m < 0) { *info = -4; } else if (*p < 0) { *info = -5; } else if (*n < 0) { *info = -6; } else if (*lda < max(1,*m)) { *info = -8; } else if (*ldb < max(1,*p)) { *info = -10; } else if (*ldu < 1 || wantu && *ldu < *m) { *info = -16; } else if (*ldv < 1 || wantv && *ldv < *p) { *info = -18; } else if (*ldq < 1 || wantq && *ldq < *n) { *info = -20; } if (*info != 0) { i__1 = -(*info); xerbla_("CGGSVP", &i__1); return 0; } /* QR with column pivoting of B: B*P = V*( S11 S12 ) ( 0 0 ) */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { iwork[i__] = 0; /* L10: */ } cgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1], info); /* Update A := A*P */ clapmt_(&forwrd, m, n, &a[a_offset], lda, &iwork[1]); /* Determine the effective rank of matrix B. */ *l = 0; i__1 = min(*p,*n); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = b_subscr(i__, i__); if ((r__1 = b[i__2].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__, i__)), dabs(r__2)) > *tolb) { ++(*l); } /* L20: */ } if (wantv) { /* Copy the details of V, and form V. */ claset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv); if (*p > 1) { i__1 = *p - 1; clacpy_("Lower", &i__1, n, &b_ref(2, 1), ldb, &v_ref(2, 1), ldv); } i__1 = min(*p,*n); cung2r_(p, p, &i__1, &v[v_offset], ldv, &tau[1], &work[1], info); } /* Clean up B */ i__1 = *l - 1; for (j = 1; j <= i__1; ++j) { i__2 = *l; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); b[i__3].r = 0.f, b[i__3].i = 0.f; /* L30: */ } /* L40: */ } if (*p > *l) { i__1 = *p - *l; claset_("Full", &i__1, n, &c_b1, &c_b1, &b_ref(*l + 1, 1), ldb); } if (wantq) { /* Set Q = I and Update Q := Q*P */ claset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq); clapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); } if (*p >= *l && *n != *l) { /* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */ cgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); /* Update A := A*Z' */ cunmr2_("Right", "Conjugate transpose", m, n, l, &b[b_offset], ldb, & tau[1], &a[a_offset], lda, &work[1], info); if (wantq) { /* Update Q := Q*Z' */ cunmr2_("Right", "Conjugate transpose", n, n, l, &b[b_offset], ldb, &tau[1], &q[q_offset], ldq, &work[1], info); } /* Clean up B */ i__1 = *n - *l; claset_("Full", l, &i__1, &c_b1, &c_b1, &b[b_offset], ldb); i__1 = *n; for (j = *n - *l + 1; j <= i__1; ++j) { i__2 = *l; for (i__ = j - *n + *l + 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); b[i__3].r = 0.f, b[i__3].i = 0.f; /* L50: */ } /* L60: */ } } /* Let N-L L A = ( A11 A12 ) M, then the following does the complete QR decomposition of A11: A11 = U*( 0 T12 )*P1' ( 0 0 ) */ i__1 = *n - *l; for (i__ = 1; i__ <= i__1; ++i__) { iwork[i__] = 0; /* L70: */ } i__1 = *n - *l; cgeqpf_(m, &i__1, &a[a_offset], lda, &iwork[1], &tau[1], &work[1], &rwork[ 1], info); /* Determine the effective rank of A11 */ *k = 0; /* Computing MIN */ i__2 = *m, i__3 = *n - *l; i__1 = min(i__2,i__3); for (i__ = 1; i__ <= i__1; ++i__) { i__2 = a_subscr(i__, i__); if ((r__1 = a[i__2].r, dabs(r__1)) + (r__2 = r_imag(&a_ref(i__, i__)), dabs(r__2)) > *tola) { ++(*k); } /* L80: */ } /* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) Computing MIN */ i__2 = *m, i__3 = *n - *l; i__1 = min(i__2,i__3); cunm2r_("Left", "Conjugate transpose", m, l, &i__1, &a[a_offset], lda, & tau[1], &a_ref(1, *n - *l + 1), lda, &work[1], info); if (wantu) { /* Copy the details of U, and form U */ claset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu); if (*m > 1) { i__1 = *m - 1; i__2 = *n - *l; clacpy_("Lower", &i__1, &i__2, &a_ref(2, 1), lda, &u_ref(2, 1), ldu); } /* Computing MIN */ i__2 = *m, i__3 = *n - *l; i__1 = min(i__2,i__3); cung2r_(m, m, &i__1, &u[u_offset], ldu, &tau[1], &work[1], info); } if (wantq) { /* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 */ i__1 = *n - *l; clapmt_(&forwrd, n, &i__1, &q[q_offset], ldq, &iwork[1]); } /* Clean up A: set the strictly lower triangular part of A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. */ i__1 = *k - 1; for (j = 1; j <= i__1; ++j) { i__2 = *k; for (i__ = j + 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); a[i__3].r = 0.f, a[i__3].i = 0.f; /* L90: */ } /* L100: */ } if (*m > *k) { i__1 = *m - *k; i__2 = *n - *l; claset_("Full", &i__1, &i__2, &c_b1, &c_b1, &a_ref(*k + 1, 1), lda); } if (*n - *l > *k) { /* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 */ i__1 = *n - *l; cgerq2_(k, &i__1, &a[a_offset], lda, &tau[1], &work[1], info); if (wantq) { /* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' */ i__1 = *n - *l; cunmr2_("Right", "Conjugate transpose", n, &i__1, k, &a[a_offset], lda, &tau[1], &q[q_offset], ldq, &work[1], info); } /* Clean up A */ i__1 = *n - *l - *k; claset_("Full", k, &i__1, &c_b1, &c_b1, &a[a_offset], lda); i__1 = *n - *l; for (j = *n - *l - *k + 1; j <= i__1; ++j) { i__2 = *k; for (i__ = j - *n + *l + *k + 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); a[i__3].r = 0.f, a[i__3].i = 0.f; /* L110: */ } /* L120: */ } } if (*m > *k) { /* QR factorization of A( K+1:M,N-L+1:N ) */ i__1 = *m - *k; cgeqr2_(&i__1, l, &a_ref(*k + 1, *n - *l + 1), lda, &tau[1], &work[1], info); if (wantu) { /* Update U(:,K+1:M) := U(:,K+1:M)*U1 */ i__1 = *m - *k; /* Computing MIN */ i__3 = *m - *k; i__2 = min(i__3,*l); cunm2r_("Right", "No transpose", m, &i__1, &i__2, &a_ref(*k + 1, * n - *l + 1), lda, &tau[1], &u_ref(1, *k + 1), ldu, &work[ 1], info); } /* Clean up */ i__1 = *n; for (j = *n - *l + 1; j <= i__1; ++j) { i__2 = *m; for (i__ = j - *n + *k + *l + 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); a[i__3].r = 0.f, a[i__3].i = 0.f; /* L130: */ } /* L140: */ } } return 0; /* End of CGGSVP */ } /* cggsvp_ */
/* Subroutine */ int cchkqp_(logical *dotype, integer *nm, integer *mval, integer *nn, integer *nval, real *thresh, logical *tsterr, complex *a, complex *copya, real *s, real *copys, complex *tau, complex *work, real *rwork, integer *iwork, integer *nout) { /* Initialized data */ static integer iseedy[4] = { 1988,1989,1990,1991 }; /* Format strings */ static char fmt_9999[] = "(\002 M =\002,i5,\002, N =\002,i5,\002, type" " \002,i2,\002, test \002,i2,\002, ratio =\002,g12.5)"; /* System generated locals */ integer i__1, i__2, i__3, i__4; real r__1; /* Local variables */ integer i__, k, m, n, im, in, lda; real eps; integer mode, info; char path[3]; integer ilow, nrun; integer ihigh, nfail, iseed[4], imode; integer mnmin, istep, nerrs, lwork; real result[3]; /* Fortran I/O blocks */ static cilist io___24 = { 0, 0, 0, fmt_9999, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CCHKQP tests CGEQPF. */ /* Arguments */ /* ========= */ /* DOTYPE (input) LOGICAL array, dimension (NTYPES) */ /* The matrix types to be used for testing. Matrices of type j */ /* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */ /* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */ /* NM (input) INTEGER */ /* The number of values of M contained in the vector MVAL. */ /* MVAL (input) INTEGER array, dimension (NM) */ /* The values of the matrix row dimension M. */ /* NN (input) INTEGER */ /* The number of values of N contained in the vector NVAL. */ /* NVAL (input) INTEGER array, dimension (NN) */ /* The values of the matrix column dimension N. */ /* THRESH (input) REAL */ /* The threshold value for the test ratios. A result is */ /* included in the output file if RESULT >= THRESH. To have */ /* every test ratio printed, use THRESH = 0. */ /* TSTERR (input) LOGICAL */ /* Flag that indicates whether error exits are to be tested. */ /* A (workspace) COMPLEX array, dimension (MMAX*NMAX) */ /* where MMAX is the maximum value of M in MVAL and NMAX is the */ /* maximum value of N in NVAL. */ /* COPYA (workspace) COMPLEX array, dimension (MMAX*NMAX) */ /* S (workspace) REAL array, dimension */ /* (min(MMAX,NMAX)) */ /* COPYS (workspace) REAL array, dimension */ /* (min(MMAX,NMAX)) */ /* TAU (workspace) COMPLEX array, dimension (MMAX) */ /* WORK (workspace) COMPLEX array, dimension */ /* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */ /* RWORK (workspace) REAL array, dimension (4*NMAX) */ /* IWORK (workspace) INTEGER array, dimension (NMAX) */ /* NOUT (input) INTEGER */ /* The unit number for output. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Scalars in Common .. */ /* .. */ /* .. Common blocks .. */ /* .. */ /* .. Data statements .. */ /* Parameter adjustments */ --iwork; --rwork; --work; --tau; --copys; --s; --copya; --a; --nval; --mval; --dotype; /* Function Body */ /* .. */ /* .. Executable Statements .. */ /* Initialize constants and the random number seed. */ s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17); s_copy(path + 1, "QP", (ftnlen)2, (ftnlen)2); nrun = 0; nfail = 0; nerrs = 0; for (i__ = 1; i__ <= 4; ++i__) { iseed[i__ - 1] = iseedy[i__ - 1]; /* L10: */ } eps = slamch_("Epsilon"); /* Test the error exits */ if (*tsterr) { cerrqp_(path, nout); } infoc_1.infot = 0; i__1 = *nm; for (im = 1; im <= i__1; ++im) { /* Do for each value of M in MVAL. */ m = mval[im]; lda = max(1,m); i__2 = *nn; for (in = 1; in <= i__2; ++in) { /* Do for each value of N in NVAL. */ n = nval[in]; mnmin = min(m,n); /* Computing MAX */ i__3 = 1, i__4 = m * max(m,n) + (mnmin << 2) + max(m,n); lwork = max(i__3,i__4); for (imode = 1; imode <= 6; ++imode) { if (! dotype[imode]) { goto L60; } /* Do for each type of matrix */ /* 1: zero matrix */ /* 2: one small singular value */ /* 3: geometric distribution of singular values */ /* 4: first n/2 columns fixed */ /* 5: last n/2 columns fixed */ /* 6: every second column fixed */ mode = imode; if (imode > 3) { mode = 1; } /* Generate test matrix of size m by n using */ /* singular value distribution indicated by `mode'. */ i__3 = n; for (i__ = 1; i__ <= i__3; ++i__) { iwork[i__] = 0; /* L20: */ } if (imode == 1) { claset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda); i__3 = mnmin; for (i__ = 1; i__ <= i__3; ++i__) { copys[i__] = 0.f; /* L30: */ } } else { r__1 = 1.f / eps; clatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], & mode, &r__1, &c_b16, &m, &n, "No packing", ©a[ 1], &lda, &work[1], &info); if (imode >= 4) { if (imode == 4) { ilow = 1; istep = 1; /* Computing MAX */ i__3 = 1, i__4 = n / 2; ihigh = max(i__3,i__4); } else if (imode == 5) { /* Computing MAX */ i__3 = 1, i__4 = n / 2; ilow = max(i__3,i__4); istep = 1; ihigh = n; } else if (imode == 6) { ilow = 1; istep = 2; ihigh = n; } i__3 = ihigh; i__4 = istep; for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3; i__ += i__4) { iwork[i__] = 1; /* L40: */ } } slaord_("Decreasing", &mnmin, ©s[1], &c__1); } /* Save A and its singular values */ clacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda); /* Compute the QR factorization with pivoting of A */ s_copy(srnamc_1.srnamt, "CGEQPF", (ftnlen)32, (ftnlen)6); cgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], & rwork[1], &info); /* Compute norm(svd(a) - svd(r)) */ result[0] = cqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1], &lwork, &rwork[1]); /* Compute norm( A*P - Q*R ) */ result[1] = cqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, & tau[1], &iwork[1], &work[1], &lwork); /* Compute Q'*Q */ result[2] = cqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &work[1] , &lwork); /* Print information about the tests that did not pass */ /* the threshold. */ for (k = 1; k <= 3; ++k) { if (result[k - 1] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___24.ciunit = *nout; s_wsfe(&io___24); do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(integer)) ; do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer)); do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof( real)); e_wsfe(); ++nfail; } /* L50: */ } nrun += 3; L60: ; } /* L70: */ } /* L80: */ } /* Print a summary of the results. */ alasum_(path, nout, &nfail, &nrun, &nerrs); /* End of CCHKQP */ return 0; } /* cchkqp_ */
/* Subroutine */ int cerrqp_(char *path, integer *nunit) { /* System generated locals */ integer i__1; /* Builtin functions Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer s_wsle(cilist *), e_wsle(void); /* Local variables */ static integer info; static complex a[4] /* was [2][2] */, w[10]; static char c2[2]; extern /* Subroutine */ int cgeqp3_(integer *, integer *, complex *, integer *, integer *, complex *, complex *, integer *, real *, integer *); static integer ip[2]; extern /* Subroutine */ int alaesm_(char *, logical *, integer *); static integer lw; extern /* Subroutine */ int cgeqpf_(integer *, integer *, complex *, integer *, integer *, complex *, complex *, real *, integer *); static real rw[4]; extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical *, logical *); static complex tau[2]; /* Fortran I/O blocks */ static cilist io___4 = { 0, 0, 0, 0, 0 }; #define a_subscr(a_1,a_2) (a_2)*2 + a_1 - 3 #define a_ref(a_1,a_2) a[a_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 June 30, 1999 Purpose ======= CERRQP tests the error exits for CGEQPF and CGEQP3. Arguments ========= PATH (input) CHARACTER*3 The LAPACK path name for the routines to be tested. NUNIT (input) INTEGER The unit number for output. ===================================================================== */ infoc_1.nout = *nunit; s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2); lw = 3; i__1 = a_subscr(1, 1); a[i__1].r = 1.f, a[i__1].i = -1.f; i__1 = a_subscr(1, 2); a[i__1].r = 2.f, a[i__1].i = -2.f; i__1 = a_subscr(2, 2); a[i__1].r = 3.f, a[i__1].i = -3.f; i__1 = a_subscr(2, 1); a[i__1].r = 4.f, a[i__1].i = -4.f; infoc_1.ok = TRUE_; io___4.ciunit = infoc_1.nout; s_wsle(&io___4); e_wsle(); /* Test error exits for QR factorization with pivoting */ if (lsamen_(&c__2, c2, "QP")) { /* CGEQPF */ s_copy(srnamc_1.srnamt, "CGEQPF", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; cgeqpf_(&c_n1, &c__0, a, &c__1, ip, tau, w, rw, &info); chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgeqpf_(&c__0, &c_n1, a, &c__1, ip, tau, w, rw, &info); chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgeqpf_(&c__2, &c__0, a, &c__1, ip, tau, w, rw, &info); chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGEQP3 */ s_copy(srnamc_1.srnamt, "CGEQP3", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; cgeqp3_(&c_n1, &c__0, a, &c__1, ip, tau, w, &lw, rw, &info); chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgeqp3_(&c__1, &c_n1, a, &c__1, ip, tau, w, &lw, rw, &info); chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgeqp3_(&c__1, &c__1, a, &c__0, ip, tau, w, &lw, rw, &info); chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; i__1 = lw - 1; cgeqp3_(&c__2, &c__2, a, &c__2, ip, tau, w, &i__1, rw, &info); chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); } /* Print a summary line. */ alaesm_(path, &infoc_1.ok, &infoc_1.nout); return 0; /* End of CERRQP */ } /* cerrqp_ */
/* Subroutine */ int cerrqp_(char *path, integer *nunit) { /* System generated locals */ integer i__1; /* Local variables */ complex a[9] /* was [3][3] */, w[15]; char c2[2]; integer ip[3], lw; real rw[6]; complex tau[3]; integer info; /* Fortran I/O blocks */ static cilist io___4 = { 0, 0, 0, 0, 0 }; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CERRQP tests the error exits for CGEQPF and CGEQP3. */ /* Arguments */ /* ========= */ /* PATH (input) CHARACTER*3 */ /* The LAPACK path name for the routines to be tested. */ /* NUNIT (input) INTEGER */ /* The unit number for output. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. Local Arrays .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Scalars in Common .. */ /* .. */ /* .. Common blocks .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ infoc_1.nout = *nunit; s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2); lw = 4; a[0].r = 1.f, a[0].i = -1.f; a[3].r = 2.f, a[3].i = -2.f; a[4].r = 3.f, a[4].i = -3.f; a[1].r = 4.f, a[1].i = -4.f; infoc_1.ok = TRUE_; io___4.ciunit = infoc_1.nout; s_wsle(&io___4); e_wsle(); /* Test error exits for QR factorization with pivoting */ if (lsamen_(&c__2, c2, "QP")) { /* CGEQPF */ s_copy(srnamc_1.srnamt, "CGEQPF", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgeqpf_(&c_n1, &c__0, a, &c__1, ip, tau, w, rw, &info); chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgeqpf_(&c__0, &c_n1, a, &c__1, ip, tau, w, rw, &info); chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgeqpf_(&c__2, &c__0, a, &c__1, ip, tau, w, rw, &info); chkxer_("CGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* CGEQP3 */ s_copy(srnamc_1.srnamt, "CGEQP3", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; cgeqp3_(&c_n1, &c__0, a, &c__1, ip, tau, w, &lw, rw, &info); chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; cgeqp3_(&c__1, &c_n1, a, &c__1, ip, tau, w, &lw, rw, &info); chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; cgeqp3_(&c__2, &c__3, a, &c__1, ip, tau, w, &lw, rw, &info); chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; i__1 = lw - 10; cgeqp3_(&c__2, &c__2, a, &c__2, ip, tau, w, &i__1, rw, &info); chkxer_("CGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); } /* Print a summary line. */ alaesm_(path, &infoc_1.ok, &infoc_1.nout); return 0; /* End of CERRQP */ } /* cerrqp_ */
/* Subroutine */ int cgelsx_(integer *m, integer *n, integer *nrhs, complex * a, integer *lda, complex *b, integer *ldb, integer *jpvt, real *rcond, integer *rank, complex *work, real *rwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; complex q__1; /* Builtin functions */ double c_abs(complex *); void r_cnjg(complex *, complex *); /* Local variables */ static integer i__, j, k; static complex c1, c2, s1, s2, t1, t2; static integer mn; static real anrm, bnrm, smin, smax; static integer iascl, ibscl, ismin, ismax; extern /* Subroutine */ int ctrsm_(char *, char *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), claic1_(integer *, integer *, complex *, real *, complex *, complex *, real *, complex *, complex *), cunm2r_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, ftnlen, ftnlen), slabad_(real *, real *); extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *, ftnlen); extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *, ftnlen), cgeqpf_(integer *, integer *, complex *, integer *, integer *, complex *, complex *, real *, integer *); extern doublereal slamch_(char *, ftnlen); extern /* Subroutine */ int claset_(char *, integer *, integer *, complex *, complex *, complex *, integer *, ftnlen), xerbla_(char *, integer *, ftnlen); static real bignum; extern /* Subroutine */ int clatzm_(char *, integer *, integer *, complex *, integer *, complex *, complex *, complex *, integer *, complex *, ftnlen); static real sminpr; extern /* Subroutine */ int ctzrqf_(integer *, integer *, complex *, integer *, complex *, integer *); static real smaxpr, smlnum; /* -- LAPACK driver 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 CGELSY. */ /* CGELSX computes the minimum-norm solution to a complex linear least */ /* squares problem: */ /* minimize || A * X - B || */ /* using a complete orthogonal factorization of A. A is an M-by-N */ /* matrix which may be rank-deficient. */ /* Several right hand side vectors b and solution vectors x can be */ /* handled in a single call; they are stored as the columns of the */ /* M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ /* matrix X. */ /* The routine first computes a QR factorization with column pivoting: */ /* A * P = Q * [ R11 R12 ] */ /* [ 0 R22 ] */ /* with R11 defined as the largest leading submatrix whose estimated */ /* condition number is less than 1/RCOND. The order of R11, RANK, */ /* is the effective rank of A. */ /* Then, R22 is considered to be negligible, and R12 is annihilated */ /* by unitary transformations from the right, arriving at the */ /* complete orthogonal factorization: */ /* A * P = Q * [ T11 0 ] * Z */ /* [ 0 0 ] */ /* The minimum-norm solution is then */ /* X = P * Z' [ inv(T11)*Q1'*B ] */ /* [ 0 ] */ /* where Q1 consists of the first RANK columns of Q. */ /* 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. */ /* NRHS (input) INTEGER */ /* The number of right hand sides, i.e., the number of */ /* columns of matrices B and X. NRHS >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the M-by-N matrix A. */ /* On exit, A has been overwritten by details of its */ /* complete orthogonal factorization. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,M). */ /* B (input/output) COMPLEX array, dimension (LDB,NRHS) */ /* On entry, the M-by-NRHS right hand side matrix B. */ /* On exit, the N-by-NRHS solution matrix X. */ /* If m >= n and RANK = n, the residual sum-of-squares for */ /* the solution in the i-th column is given by the sum of */ /* squares of elements N+1:M in that column. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,M,N). */ /* JPVT (input/output) INTEGER array, dimension (N) */ /* On entry, if JPVT(i) .ne. 0, the i-th column of A is an */ /* initial column, otherwise it is a free column. Before */ /* the QR factorization of A, all initial columns are */ /* permuted to the leading positions; only the remaining */ /* free columns are moved as a result of column pivoting */ /* during the factorization. */ /* On exit, if JPVT(i) = k, then the i-th column of A*P */ /* was the k-th column of A. */ /* RCOND (input) REAL */ /* RCOND is used to determine the effective rank of A, which */ /* is defined as the order of the largest leading triangular */ /* submatrix R11 in the QR factorization with pivoting of A, */ /* whose estimated condition number < 1/RCOND. */ /* RANK (output) INTEGER */ /* The effective rank of A, i.e., the order of the submatrix */ /* R11. This is the same as the order of the submatrix T11 */ /* in the complete orthogonal factorization of A. */ /* WORK (workspace) COMPLEX array, dimension */ /* (min(M,N) + max( N, 2*min(M,N)+NRHS )), */ /* RWORK (workspace) REAL 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 .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --jpvt; --work; --rwork; /* Function Body */ mn = min(*m,*n); ismin = mn + 1; ismax = (mn << 1) + 1; /* Test the input arguments. */ *info = 0; if (*m < 0) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*nrhs < 0) { *info = -3; } else if (*lda < max(1,*m)) { *info = -5; } else /* if(complicated condition) */ { /* Computing MAX */ i__1 = max(1,*m); if (*ldb < max(i__1,*n)) { *info = -7; } } if (*info != 0) { i__1 = -(*info); xerbla_("CGELSX", &i__1, (ftnlen)6); return 0; } /* Quick return if possible */ /* Computing MIN */ i__1 = min(*m,*n); if (min(i__1,*nrhs) == 0) { *rank = 0; return 0; } /* Get machine parameters */ smlnum = slamch_("S", (ftnlen)1) / slamch_("P", (ftnlen)1); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); /* Scale A, B if max elements outside range [SMLNUM,BIGNUM] */ anrm = clange_("M", m, n, &a[a_offset], lda, &rwork[1], (ftnlen)1); iascl = 0; if (anrm > 0.f && anrm < smlnum) { /* Scale matrix norm up to SMLNUM */ clascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, info, (ftnlen)1); iascl = 1; } else if (anrm > bignum) { /* Scale matrix norm down to BIGNUM */ clascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, info, (ftnlen)1); iascl = 2; } else if (anrm == 0.f) { /* Matrix all zero. Return zero solution. */ i__1 = max(*m,*n); claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb, (ftnlen)1); *rank = 0; goto L100; } bnrm = clange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1], (ftnlen)1); ibscl = 0; if (bnrm > 0.f && bnrm < smlnum) { /* Scale matrix norm up to SMLNUM */ clascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, info, (ftnlen)1); ibscl = 1; } else if (bnrm > bignum) { /* Scale matrix norm down to BIGNUM */ clascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, info, (ftnlen)1); ibscl = 2; } /* Compute QR factorization with column pivoting of A: */ /* A * P = Q * R */ cgeqpf_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], & rwork[1], info); /* complex workspace MN+N. Real workspace 2*N. Details of Householder */ /* rotations stored in WORK(1:MN). */ /* Determine RANK using incremental condition estimation */ i__1 = ismin; work[i__1].r = 1.f, work[i__1].i = 0.f; i__1 = ismax; work[i__1].r = 1.f, work[i__1].i = 0.f; smax = c_abs(&a[a_dim1 + 1]); smin = smax; if (c_abs(&a[a_dim1 + 1]) == 0.f) { *rank = 0; i__1 = max(*m,*n); claset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb, (ftnlen)1); goto L100; } else { *rank = 1; } L10: if (*rank < mn) { i__ = *rank + 1; claic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ i__ + i__ * a_dim1], &sminpr, &s1, &c1); claic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[ i__ + i__ * a_dim1], &smaxpr, &s2, &c2); if (smaxpr * *rcond <= sminpr) { i__1 = *rank; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = ismin + i__ - 1; i__3 = ismin + i__ - 1; q__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, q__1.i = s1.r * work[i__3].i + s1.i * work[i__3].r; work[i__2].r = q__1.r, work[i__2].i = q__1.i; i__2 = ismax + i__ - 1; i__3 = ismax + i__ - 1; q__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, q__1.i = s2.r * work[i__3].i + s2.i * work[i__3].r; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L20: */ } i__1 = ismin + *rank; work[i__1].r = c1.r, work[i__1].i = c1.i; i__1 = ismax + *rank; work[i__1].r = c2.r, work[i__1].i = c2.i; smin = sminpr; smax = smaxpr; ++(*rank); goto L10; } } /* Logically partition R = [ R11 R12 ] */ /* [ 0 R22 ] */ /* where R11 = R(1:RANK,1:RANK) */ /* [R11,R12] = [ T11, 0 ] * Y */ if (*rank < *n) { ctzrqf_(rank, n, &a[a_offset], lda, &work[mn + 1], info); } /* Details of Householder rotations stored in WORK(MN+1:2*MN) */ /* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */ cunm2r_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, & work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], info, (ftnlen)4, (ftnlen)19); /* workspace NRHS */ /* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ ctrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[ a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, (ftnlen) 12, (ftnlen)8); i__1 = *n; for (i__ = *rank + 1; i__ <= i__1; ++i__) { i__2 = *nrhs; for (j = 1; j <= i__2; ++j) { i__3 = i__ + j * b_dim1; b[i__3].r = 0.f, b[i__3].i = 0.f; /* L30: */ } /* L40: */ } /* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */ if (*rank < *n) { i__1 = *rank; for (i__ = 1; i__ <= i__1; ++i__) { i__2 = *n - *rank + 1; r_cnjg(&q__1, &work[mn + i__]); clatzm_("Left", &i__2, nrhs, &a[i__ + (*rank + 1) * a_dim1], lda, &q__1, &b[i__ + b_dim1], &b[*rank + 1 + b_dim1], ldb, & work[(mn << 1) + 1], (ftnlen)4); /* L50: */ } } /* workspace NRHS */ /* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = (mn << 1) + i__; work[i__3].r = 1.f, work[i__3].i = 0.f; /* L60: */ } i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = (mn << 1) + i__; if (work[i__3].r == 1.f && work[i__3].i == 0.f) { if (jpvt[i__] != i__) { k = i__; i__3 = k + j * b_dim1; t1.r = b[i__3].r, t1.i = b[i__3].i; i__3 = jpvt[k] + j * b_dim1; t2.r = b[i__3].r, t2.i = b[i__3].i; L70: i__3 = jpvt[k] + j * b_dim1; b[i__3].r = t1.r, b[i__3].i = t1.i; i__3 = (mn << 1) + k; work[i__3].r = 0.f, work[i__3].i = 0.f; t1.r = t2.r, t1.i = t2.i; k = jpvt[k]; i__3 = jpvt[k] + j * b_dim1; t2.r = b[i__3].r, t2.i = b[i__3].i; if (jpvt[k] != i__) { goto L70; } i__3 = i__ + j * b_dim1; b[i__3].r = t1.r, b[i__3].i = t1.i; i__3 = (mn << 1) + k; work[i__3].r = 0.f, work[i__3].i = 0.f; } } /* L80: */ } /* L90: */ } /* Undo scaling */ if (iascl == 1) { clascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); clascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], lda, info, (ftnlen)1); } else if (iascl == 2) { clascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); clascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], lda, info, (ftnlen)1); } if (ibscl == 1) { clascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); } else if (ibscl == 2) { clascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); } L100: return 0; /* End of CGELSX */ } /* cgelsx_ */