/* Subroutine */ int zerrqp_(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 */ doublecomplex a[9] /* was [3][3] */, w[15]; char c2[2]; integer ip[3], lw; doublereal rw[6]; doublecomplex tau[3]; integer info; extern /* Subroutine */ int zgeqp3_(integer *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, doublecomplex *, integer * , doublereal *, integer *), alaesm_(char *, logical *, integer *); extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical *, logical *), zgeqpf_(integer *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, doublecomplex *, doublereal *, integer *); /* 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 */ /* ======= */ /* ZERRQP tests the error exits for ZGEQPF 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., a[0].i = -1.; a[3].r = 2., a[3].i = -2.; a[4].r = 3., a[4].i = -3.; a[1].r = 4., a[1].i = -4.; 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")) { /* ZGEQPF */ s_copy(srnamc_1.srnamt, "ZGEQPF", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; zgeqpf_(&c_n1, &c__0, a, &c__1, ip, tau, w, rw, &info); chkxer_("ZGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zgeqpf_(&c__0, &c_n1, a, &c__1, ip, tau, w, rw, &info); chkxer_("ZGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zgeqpf_(&c__2, &c__0, a, &c__1, ip, tau, w, rw, &info); chkxer_("ZGEQPF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* ZGEQP3 */ s_copy(srnamc_1.srnamt, "ZGEQP3", (ftnlen)32, (ftnlen)6); infoc_1.infot = 1; zgeqp3_(&c_n1, &c__0, a, &c__1, ip, tau, w, &lw, rw, &info); chkxer_("ZGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; zgeqp3_(&c__1, &c_n1, a, &c__1, ip, tau, w, &lw, rw, &info); chkxer_("ZGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; zgeqp3_(&c__2, &c__3, a, &c__1, ip, tau, w, &lw, rw, &info); chkxer_("ZGEQP3", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 8; i__1 = lw - 10; zgeqp3_(&c__2, &c__2, a, &c__2, ip, tau, w, &i__1, rw, &info); chkxer_("ZGEQP3", &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 ZERRQP */ } /* zerrqp_ */
/* Subroutine */ int zchkqp_(logical *dotype, integer *nm, integer *mval, integer *nn, integer *nval, doublereal *thresh, logical *tsterr, doublecomplex *a, doublecomplex *copya, doublereal *s, doublereal * copys, doublecomplex *tau, doublecomplex *work, doublereal *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; doublereal d__1; /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); /* Local variables */ integer i__, k, m, n, im, in, lda; doublereal eps; integer mode, info; char path[3]; integer ilow, nrun; extern /* Subroutine */ int alahd_(integer *, char *); integer ihigh, nfail, iseed[4], imode, mnmin, istep, nerrs, lwork; extern doublereal zqpt01_(integer *, integer *, integer *, doublecomplex * , doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zqrt11_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zqrt12_(integer *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *, integer *, doublereal *) , dlamch_(char *); extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *, integer *), alasum_(char *, integer *, integer *, integer *, integer *), zgeqpf_(integer *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, doublecomplex *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, char *, doublecomplex *, integer *, doublecomplex *, integer *); doublereal result[3]; extern /* Subroutine */ int zerrqp_(char *, integer *); /* 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 */ /* ======= */ /* ZCHKQP tests ZGEQPF. */ /* 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) DOUBLE PRECISION */ /* 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*16 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*16 array, dimension (MMAX*NMAX) */ /* S (workspace) DOUBLE PRECISION array, dimension */ /* (min(MMAX,NMAX)) */ /* COPYS (workspace) DOUBLE PRECISION array, dimension */ /* (min(MMAX,NMAX)) */ /* TAU (workspace) COMPLEX*16 array, dimension (MMAX) */ /* WORK (workspace) COMPLEX*16 array, dimension */ /* (max(M*max(M,N) + 4*min(M,N) + max(M,N))) */ /* RWORK (workspace) DOUBLE PRECISION 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, "Zomplex 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 = dlamch_("Epsilon"); /* Test the error exits */ if (*tsterr) { zerrqp_(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) { zlaset_("Full", &m, &n, &c_b11, &c_b11, ©a[1], &lda); i__3 = mnmin; for (i__ = 1; i__ <= i__3; ++i__) { copys[i__] = 0.; /* L30: */ } } else { d__1 = 1. / eps; zlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], & mode, &d__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: */ } } dlaord_("Decreasing", &mnmin, ©s[1], &c__1); } /* Save A and its singular values */ zlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda); /* Compute the QR factorization with pivoting of A */ s_copy(srnamc_1.srnamt, "ZGEQPF", (ftnlen)32, (ftnlen)6); zgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], & rwork[1], &info); /* Compute norm(svd(a) - svd(r)) */ result[0] = zqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1], &lwork, &rwork[1]); /* Compute norm( A*P - Q*R ) */ result[1] = zqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, & tau[1], &iwork[1], &work[1], &lwork); /* Compute Q'*Q */ result[2] = zqrt11_(&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( doublereal)); e_wsfe(); ++nfail; } /* L50: */ } nrun += 3; L60: ; } /* L70: */ } /* L80: */ } /* Print a summary of the results. */ alasum_(path, nout, &nfail, &nrun, &nerrs); /* End of ZCHKQP */ return 0; } /* zchkqp_ */
/* Subroutine */ int zggsvp_(char *jobu, char *jobv, char *jobq, integer *m, integer *p, integer *n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *tola, doublereal *tolb, integer *k, integer *l, doublecomplex *u, integer *ldu, doublecomplex *v, integer *ldv, doublecomplex *q, integer *ldq, integer *iwork, doublereal * rwork, doublecomplex *tau, 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 September 30, 1994 Purpose ======= ZGGSVP 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 ZGGSVD. 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*16 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*16 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) DOUBLE PRECISION TOLB (input) DOUBLE PRECISION 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)*MAZHEPS, TOLB = MAX(P,N)*norm(B)*MAZHEPS. 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*16 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*16 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*16 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) DOUBLE PRECISION array, dimension (2*N) TAU (workspace) COMPLEX*16 array, dimension (N) WORK (workspace) COMPLEX*16 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 ZGEQPF 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 doublecomplex c_b1 = {0.,0.}; static doublecomplex c_b2 = {1.,0.}; /* 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; doublereal d__1, d__2; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ static integer i__, j; extern logical lsame_(char *, char *); static logical wantq, wantu, wantv; extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zgerq2_( integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zung2r_(integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zunm2r_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), zunmr2_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_( char *, integer *), zgeqpf_(integer *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, doublecomplex *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *); static logical forwrd; extern /* Subroutine */ int zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlapmt_(logical *, integer *, integer *, doublecomplex *, integer *, integer *); #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_("ZGGSVP", &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: */ } zgeqpf_(p, n, &b[b_offset], ldb, &iwork[1], &tau[1], &work[1], &rwork[1], info); /* Update A := A*P */ zlapmt_(&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 ((d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b_ref(i__, i__)), abs(d__2)) > *tolb) { ++(*l); } /* L20: */ } if (wantv) { /* Copy the details of V, and form V. */ zlaset_("Full", p, p, &c_b1, &c_b1, &v[v_offset], ldv); if (*p > 1) { i__1 = *p - 1; zlacpy_("Lower", &i__1, n, &b_ref(2, 1), ldb, &v_ref(2, 1), ldv); } i__1 = min(*p,*n); zung2r_(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., b[i__3].i = 0.; /* L30: */ } /* L40: */ } if (*p > *l) { i__1 = *p - *l; zlaset_("Full", &i__1, n, &c_b1, &c_b1, &b_ref(*l + 1, 1), ldb); } if (wantq) { /* Set Q = I and Update Q := Q*P */ zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq); zlapmt_(&forwrd, n, n, &q[q_offset], ldq, &iwork[1]); } if (*p >= *l && *n != *l) { /* RQ factorization of ( S11 S12 ) = ( 0 S12 )*Z */ zgerq2_(l, n, &b[b_offset], ldb, &tau[1], &work[1], info); /* Update A := A*Z' */ zunmr2_("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' */ zunmr2_("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; zlaset_("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., b[i__3].i = 0.; /* 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; zgeqpf_(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 ((d__1 = a[i__2].r, abs(d__1)) + (d__2 = d_imag(&a_ref(i__, i__)), abs(d__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); zunm2r_("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 */ zlaset_("Full", m, m, &c_b1, &c_b1, &u[u_offset], ldu); if (*m > 1) { i__1 = *m - 1; i__2 = *n - *l; zlacpy_("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); zung2r_(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; zlapmt_(&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., a[i__3].i = 0.; /* L90: */ } /* L100: */ } if (*m > *k) { i__1 = *m - *k; i__2 = *n - *l; zlaset_("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; zgerq2_(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; zunmr2_("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; zlaset_("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., a[i__3].i = 0.; /* L110: */ } /* L120: */ } } if (*m > *k) { /* QR factorization of A( K+1:M,N-L+1:N ) */ i__1 = *m - *k; zgeqr2_(&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); zunm2r_("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., a[i__3].i = 0.; /* L130: */ } /* L140: */ } } return 0; /* End of ZGGSVP */ } /* zggsvp_ */