/* Subroutine */ int zerrtz_(char *path, integer *nunit) { /* Builtin functions */ /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); integer s_wsle(cilist *), e_wsle(void); /* Local variables */ doublecomplex a[4] /* was [2][2] */, w[2]; char c2[2]; doublecomplex tau[2]; integer info; extern /* Subroutine */ int alaesm_(char *, logical *, integer *); extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical *, logical *), ztzrqf_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), ztzrzf_( integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, 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 */ /* ======= */ /* ZERRTZ tests the error exits for ZTZRQF and ZTZRZF. */ /* 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); a[0].r = 1., a[0].i = -1.; a[2].r = 2., a[2].i = -2.; a[3].r = 3., a[3].i = -3.; a[1].r = 4., a[1].i = -4.; w[0].r = 0., w[0].i = 0.; w[1].r = 0., w[1].i = 0.; infoc_1.ok = TRUE_; /* Test error exits for the trapezoidal routines. */ io___4.ciunit = infoc_1.nout; s_wsle(&io___4); e_wsle(); if (lsamen_(&c__2, c2, "TZ")) { /* ZTZRQF */ s_copy(srnamc_1.srnamt, "ZTZRQF", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; ztzrqf_(&c_n1, &c__0, a, &c__1, tau, &info); chkxer_("ZTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; ztzrqf_(&c__1, &c__0, a, &c__1, tau, &info); chkxer_("ZTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; ztzrqf_(&c__2, &c__2, a, &c__1, tau, &info); chkxer_("ZTZRQF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); /* ZTZRZF */ s_copy(srnamc_1.srnamt, "ZTZRZF", (ftnlen)6, (ftnlen)6); infoc_1.infot = 1; ztzrzf_(&c_n1, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("ZTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 2; ztzrzf_(&c__1, &c__0, a, &c__1, tau, w, &c__1, &info); chkxer_("ZTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 4; ztzrzf_(&c__2, &c__2, a, &c__1, tau, w, &c__1, &info); chkxer_("ZTZRZF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, & infoc_1.ok); infoc_1.infot = 7; ztzrzf_(&c__2, &c__2, a, &c__2, tau, w, &c__1, &info); chkxer_("ZTZRZF", &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 ZERRTZ */ } /* zerrtz_ */
/* Subroutine */ int zchktz_(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 *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 */ static integer mode, info; static char path[3]; static integer nrun, i__; extern /* Subroutine */ int alahd_(integer *, char *); static integer k, m, n, nfail, iseed[4], imode, mnmin, nerrs, lwork; extern doublereal zqrt12_(integer *, integer *, doublecomplex *, integer * , doublereal *, doublecomplex *, integer *, doublereal *), zrzt01_(integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), zrzt02_( integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), ztzt01_(integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *), ztzt02_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static integer im, in; extern doublereal dlamch_(char *); extern /* Subroutine */ int dlaord_(char *, integer *, doublereal *, integer *), alasum_(char *, integer *, integer *, integer *, 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 *); static doublereal result[6]; extern /* Subroutine */ int zerrtz_(char *, integer *), ztzrqf_( integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), ztzrzf_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *) ; static integer lda; static doublereal eps; /* Fortran I/O blocks */ static cilist io___21 = { 0, 0, 0, fmt_9999, 0 }; /* -- 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 ======= ZCHKTZ tests ZTZRQF and ZTZRZF. 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 (MMAX*NMAX + 4*NMAX + MMAX) RWORK (workspace) DOUBLE PRECISION array, dimension (2*NMAX) NOUT (input) INTEGER The unit number for output. ===================================================================== Parameter adjustments */ --rwork; --work; --tau; --copys; --s; --copya; --a; --nval; --mval; --dotype; /* Function Body Initialize constants and the random number seed. */ s_copy(path, "Zomplex precision", (ftnlen)1, (ftnlen)17); s_copy(path + 1, "TZ", (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) { zerrtz_(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 for which M .LE. N. */ n = nval[in]; mnmin = min(m,n); /* Computing MAX */ i__3 = 1, i__4 = n * n + (m << 2) + n; lwork = max(i__3,i__4); if (m <= n) { for (imode = 1; imode <= 3; ++imode) { /* Do for each type of singular value distribution. 0: zero matrix 1: one small singular value 2: exponential distribution */ mode = imode - 1; /* Test ZTZRQF Generate test matrix of size m by n using singular value distribution indicated by `mode'. */ if (mode == 0) { zlaset_("Full", &m, &n, &c_b10, &c_b10, &a[1], &lda); i__3 = mnmin; for (i__ = 1; i__ <= i__3; ++i__) { copys[i__] = 0.; /* L20: */ } } else { d__1 = 1. / eps; zlatms_(&m, &n, "Uniform", iseed, "Nonsymmetric", & copys[1], &imode, &d__1, &c_b15, &m, &n, "No packing", &a[1], &lda, &work[1], &info); zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin + 1], &info); i__3 = m - 1; zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], & lda); dlaord_("Decreasing", &mnmin, ©s[1], &c__1); } /* Save A and its singular values */ zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda); /* Call ZTZRQF to reduce the upper trapezoidal matrix to upper triangular form. */ s_copy(srnamc_1.srnamt, "ZTZRQF", (ftnlen)6, (ftnlen)6); ztzrqf_(&m, &n, &a[1], &lda, &tau[1], &info); /* Compute norm(svd(a) - svd(r)) */ result[0] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[ 1], &lwork, &rwork[1]); /* Compute norm( A - R*Q ) */ result[1] = ztzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[ 1], &work[1], &lwork); /* Compute norm(Q'*Q - I). */ result[2] = ztzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1] , &lwork); /* Test ZTZRZF Generate test matrix of size m by n using singular value distribution indicated by `mode'. */ if (mode == 0) { zlaset_("Full", &m, &n, &c_b10, &c_b10, &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, "Nonsymmetric", & copys[1], &imode, &d__1, &c_b15, &m, &n, "No packing", &a[1], &lda, &work[1], &info); zgeqr2_(&m, &n, &a[1], &lda, &work[1], &work[mnmin + 1], &info); i__3 = m - 1; zlaset_("Lower", &i__3, &n, &c_b10, &c_b10, &a[2], & lda); dlaord_("Decreasing", &mnmin, ©s[1], &c__1); } /* Save A and its singular values */ zlacpy_("All", &m, &n, &a[1], &lda, ©a[1], &lda); /* Call ZTZRZF to reduce the upper trapezoidal matrix to upper triangular form. */ s_copy(srnamc_1.srnamt, "ZTZRZF", (ftnlen)6, (ftnlen)6); ztzrzf_(&m, &n, &a[1], &lda, &tau[1], &work[1], &lwork, & info); /* Compute norm(svd(a) - svd(r)) */ result[3] = zqrt12_(&m, &m, &a[1], &lda, ©s[1], &work[ 1], &lwork, &rwork[1]); /* Compute norm( A - R*Q ) */ result[4] = zrzt01_(&m, &n, ©a[1], &a[1], &lda, &tau[ 1], &work[1], &lwork); /* Compute norm(Q'*Q - I). */ result[5] = zrzt02_(&m, &n, &a[1], &lda, &tau[1], &work[1] , &lwork); /* Print information about the tests that did not pass the threshold. */ for (k = 1; k <= 6; ++k) { if (result[k - 1] >= *thresh) { if (nfail == 0 && nerrs == 0) { alahd_(nout, path); } io___21.ciunit = *nout; s_wsfe(&io___21); 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; } /* L40: */ } nrun += 6; /* L50: */ } } /* L60: */ } /* L70: */ } /* Print a summary of the results. */ alasum_(path, nout, &nfail, &nrun, &nerrs); /* End if ZCHKTZ */ return 0; } /* zchktz_ */
/* Subroutine */ int zgelsy_(integer *m, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; doublereal d__1, d__2; doublecomplex z__1; /* Builtin functions */ double z_abs(doublecomplex *); /* Local variables */ static integer i__, j; static doublecomplex c1, c2, s1, s2; static integer nb, mn, nb1, nb2, nb3, nb4; static doublereal anrm, bnrm, smin, smax; static integer iascl, ibscl, ismin, ismax; static doublereal wsize; extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), ztrsm_(char *, char *, char *, char * , integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), zlaic1_(integer *, integer *, doublecomplex *, doublereal *, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *, doublecomplex *), dlabad_(doublereal *, doublereal *), zgeqp3_( integer *, integer *, doublecomplex *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublereal *, integer *); extern doublereal dlamch_(char *, ftnlen); extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, integer *, doublereal *, ftnlen); static doublereal bignum; extern /* Subroutine */ int zlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublecomplex *, integer *, integer *, ftnlen), zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, ftnlen); static doublereal sminpr, smaxpr, smlnum; static integer lwkopt; static logical lquery; extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *, ftnlen, ftnlen), zunmrz_(char *, char *, integer *, integer *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer * , ftnlen, ftnlen), ztzrzf_(integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *) ; /* -- LAPACK driver 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 */ /* ======= */ /* ZGELSY 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. */ /* This routine is basically identical to the original xGELSX except */ /* three differences: */ /* o The permutation of matrix B (the right hand side) is faster and */ /* more simple. */ /* o The call to the subroutine xGEQPF has been substituted by the */ /* the call to the subroutine xGEQP3. This subroutine is a Blas-3 */ /* version of the QR factorization with column pivoting. */ /* o Matrix B (the right hand side) is updated with Blas-3. */ /* 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*16 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*16 array, dimension (LDB,NRHS) */ /* On entry, the M-by-NRHS right hand side matrix B. */ /* On exit, the N-by-NRHS solution matrix X. */ /* 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 permuted */ /* to the front of AP, otherwise column i is a free column. */ /* On exit, if JPVT(i) = k, then the i-th column of A*P */ /* was the k-th column of A. */ /* RCOND (input) DOUBLE PRECISION */ /* 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/output) COMPLEX*16 array, dimension (LWORK) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. */ /* The unblocked strategy requires that: */ /* LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS ) */ /* where MN = min(M,N). */ /* The block algorithm requires that: */ /* LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS ) */ /* where NB is an upper bound on the blocksize returned */ /* by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR, */ /* and ZUNMRZ. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal size of the WORK array, returns */ /* this value as the first entry of the WORK array, and no error */ /* message related to LWORK is issued by XERBLA. */ /* RWORK (workspace) DOUBLE PRECISION array, dimension (2*N) */ /* 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 */ /* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ /* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ /* ===================================================================== */ /* .. 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; nb1 = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)1); nb2 = ilaenv_(&c__1, "ZGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, ( ftnlen)1); nb3 = ilaenv_(&c__1, "ZUNMQR", " ", m, n, nrhs, &c_n1, (ftnlen)6, (ftnlen) 1); nb4 = ilaenv_(&c__1, "ZUNMRQ", " ", m, n, nrhs, &c_n1, (ftnlen)6, (ftnlen) 1); /* Computing MAX */ i__1 = max(nb1,nb2), i__1 = max(i__1,nb3); nb = max(i__1,nb4); /* Computing MAX */ i__1 = 1, i__2 = mn + (*n << 1) + nb * (*n + 1), i__1 = max(i__1,i__2), i__2 = (mn << 1) + nb * *nrhs; lwkopt = max(i__1,i__2); z__1.r = (doublereal) lwkopt, z__1.i = 0.; work[1].r = z__1.r, work[1].i = z__1.i; lquery = *lwork == -1; 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; } else /* if(complicated condition) */ { /* Computing MAX */ i__1 = mn << 1, i__2 = *n + 1, i__1 = max(i__1,i__2), i__2 = mn + *nrhs; if (*lwork < mn + max(i__1,i__2) && ! lquery) { *info = -12; } } } if (*info != 0) { i__1 = -(*info); xerbla_("ZGELSY", &i__1, (ftnlen)6); return 0; } else if (lquery) { 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 = dlamch_("S", (ftnlen)1) / dlamch_("P", (ftnlen)1); bignum = 1. / smlnum; dlabad_(&smlnum, &bignum); /* Scale A, B if max entries outside range [SMLNUM,BIGNUM] */ anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1], (ftnlen)1); iascl = 0; if (anrm > 0. && anrm < smlnum) { /* Scale matrix norm up to SMLNUM */ zlascl_("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 */ zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, info, (ftnlen)1); iascl = 2; } else if (anrm == 0.) { /* Matrix all zero. Return zero solution. */ i__1 = max(*m,*n); zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb, (ftnlen)1); *rank = 0; goto L70; } bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1], (ftnlen)1); ibscl = 0; if (bnrm > 0. && bnrm < smlnum) { /* Scale matrix norm up to SMLNUM */ zlascl_("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 */ zlascl_("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 */ i__1 = *lwork - mn; zgeqp3_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &i__1, &rwork[1], info); i__1 = mn + 1; wsize = mn + work[i__1].r; /* complex workspace: MN+NB*(N+1). 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., work[i__1].i = 0.; i__1 = ismax; work[i__1].r = 1., work[i__1].i = 0.; smax = z_abs(&a[a_dim1 + 1]); smin = smax; if (z_abs(&a[a_dim1 + 1]) == 0.) { *rank = 0; i__1 = max(*m,*n); zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb, (ftnlen)1); goto L70; } else { *rank = 1; } L10: if (*rank < mn) { i__ = *rank + 1; zlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ i__ + i__ * a_dim1], &sminpr, &s1, &c1); zlaic1_(&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; z__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, z__1.i = s1.r * work[i__3].i + s1.i * work[i__3].r; work[i__2].r = z__1.r, work[i__2].i = z__1.i; i__2 = ismax + i__ - 1; i__3 = ismax + i__ - 1; z__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, z__1.i = s2.r * work[i__3].i + s2.i * work[i__3].r; work[i__2].r = z__1.r, work[i__2].i = z__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; } } /* complex workspace: 3*MN. */ /* Logically partition R = [ R11 R12 ] */ /* [ 0 R22 ] */ /* where R11 = R(1:RANK,1:RANK) */ /* [R11,R12] = [ T11, 0 ] * Y */ if (*rank < *n) { i__1 = *lwork - (mn << 1); ztzrzf_(rank, n, &a[a_offset], lda, &work[mn + 1], &work[(mn << 1) + 1], &i__1, info); } /* complex workspace: 2*MN. */ /* Details of Householder rotations stored in WORK(MN+1:2*MN) */ /* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */ i__1 = *lwork - (mn << 1); zunmqr_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, & work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__1, info, ( ftnlen)4, (ftnlen)19); /* Computing MAX */ i__1 = (mn << 1) + 1; d__1 = wsize, d__2 = (mn << 1) + work[i__1].r; wsize = max(d__1,d__2); /* complex workspace: 2*MN+NB*NRHS. */ /* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ ztrsm_("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 = *nrhs; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = *rank + 1; i__ <= i__2; ++i__) { i__3 = i__ + j * b_dim1; b[i__3].r = 0., b[i__3].i = 0.; /* L30: */ } /* L40: */ } /* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) */ if (*rank < *n) { i__1 = *n - *rank; i__2 = *lwork - (mn << 1); zunmrz_("Left", "Conjugate transpose", n, nrhs, rank, &i__1, &a[ a_offset], lda, &work[mn + 1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__2, info, (ftnlen)4, (ftnlen)19); } /* complex workspace: 2*MN+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 = jpvt[i__]; i__4 = i__ + j * b_dim1; work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i; /* L50: */ } zcopy_(n, &work[1], &c__1, &b[j * b_dim1 + 1], &c__1); /* L60: */ } /* complex workspace: N. */ /* Undo scaling */ if (iascl == 1) { zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); zlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], lda, info, (ftnlen)1); } else if (iascl == 2) { zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); zlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], lda, info, (ftnlen)1); } if (ibscl == 1) { zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); } else if (ibscl == 2) { zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, info, (ftnlen)1); } L70: z__1.r = (doublereal) lwkopt, z__1.i = 0.; work[1].r = z__1.r, work[1].i = z__1.i; return 0; /* End of ZGELSY */ } /* zgelsy_ */