From 4619f613cd5d55e23495ca7e0e436f8437161e2a Mon Sep 17 00:00:00 2001 From: Igor Date: Tue, 14 Oct 2025 23:38:08 -0700 Subject: [PATCH 01/63] Addded a DRAFT of DGECS routine. --- SRC/DGECX.f | 1173 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1173 insertions(+) create mode 100644 SRC/DGECX.f diff --git a/SRC/DGECX.f b/SRC/DGECX.f new file mode 100644 index 000000000..8bcb1ee4f --- /dev/null +++ b/SRC/DGECX.f @@ -0,0 +1,1173 @@ +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGECX computes a CX factorization of a real M-by-N matrix A: +*> +*> A * P(K) = C*X + A_resid, where +*> +*> C is an M-by-K matrix which is a subset of K columns selected +*> from the original matrix A, +*> +*> X is a K-by-N matrix that minimizes the Frobenius norm of the +*> residual matrix A_resid, X = pseudoinv(C) * A, +*> +*> P(K) is an N-by-N permutation matrix chosen so that the first +*> K columns of A*P(K) equal C, +*> +*> A_resid is an M-by-N residual matrix. +*> +*> The column selection for the matrix C has two stages. +*> +*> Column selection stage 1. +*> ========================= +*> +*> The user can select N_sel columns and deselect N_desel columns +*> of the matrix A that MUST be included and excluded respectively +*> from the matrix C a priori, before running the column selection +*> algorithm. This is controlled by the flags in the array +*> SEL_DESEL_COLS. The deselected columns are permuted to the right +*> side of the array A and selected columns are permuted to the left +*> side of the array A. The details of the column permutation +*> (i.e. the column permutation matrix P(K)) are stored in the +*> array JPIV. This feature can be used when the goal is to approximate +*> the deselected columns by linear combinations of K selected columns, +*> where the K columns MUST include the N_sel selected columns. +*> +*> Column selection stage 2. +*> ========================= +*> +*> The routine runs the column selection algorithm that can +*> be controlled with three stopping criteria described below. +*> For the column selection, the routine uses a truncated (rank K) in +*> Householder QR factorization with column pivoting algorithm +*> DGEQP3RK routine. Note, that before running the column selection +*> algorithm, the user can deselect M_desel rows of the matrix A that +*> should NOT be considered by the column selection algorithm (i.e. +*> during the factorization). This is controlled by the flags in +*> the array DESEL_ROWS. The deselected rows are permuted to the +*> bottom of the array A. The details of the row permutation (i.e. the +*> row permutation matrix) are stored in the array IPIV. This feature +*> can be used when the goal is to use the deselected rows as test data, +*> and the selected rows as training data. +*> +*> This means that the column selection factorization algorithm is +*> effectively running on the submatrix A_sub=A(1:M_sub,1:N_sub) of +*> the matrix A after the permutations described above. Here M_sub is +*> the number of rows of the matrix A minus the number of deselected +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> of columns of the matrix A minus the number of deselected columns +*> N_desel, i.e. N_sub = N - N_desel. +*> +*> Column selection criteria. +*> ========================== +*> +*> The column selection criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAXFREE, the maximum number of columns +*> to factorize outside of the N_sel preselected columns, +*> i.e. the factorization rank is limited to N_sel + KMAXFREE. +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), the criterion +*> is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the submatrix residual +*> A_sub_resid = A(K+1:M_sub, K+1:N_sub). +*> This means that the factorization stops if this norm is less +*> or equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the submatrix residual +*> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub) divided +*> by the maximum column 2-norm of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub). +*> This means that the factorization stops when the ratio of the +*> maximum column 2-norm of A_sub_resid to the maximum column +*> 2-norm of A_sub is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole submatrix A_sub is factorized. +*> +*> For a full rank factorization of the matrix A_sub, use selection +*> criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) and +*> ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> If the user wants to verify whether the columns of the matrix C are +*> sufficiently linearly independent for their intended use, the user +*> can compute the condition number of its R factor by calling DTRCON +*> on the upper-triangular part of A(1:K,1:K) of the output array A. +*> +*> How N_sel affects the column selection algorithm. +*> ================================================= +*> +*> As mentioned above, the N_sel selected columns are permuted to the +*> right side of the array A, and will be included in the column +*> selection. Then the routine runs the factorization of that block +*> A(1:M_sub,1:N_sel), and if any of the three stopping criteria is met +*> immediately after factoring the first N_sel columns the routine exits +*> (i.e. there is no requirement to select extra columns, +*> if the absolute or relative tolerance of the maximum column 2-norm of +*> the residual is satisfied). In this case, the number +*> of selected columns would be K = N_sel. Otherwise, the factorization +*> routine finds a new column to select with the maximum column 2-norm +*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and permutes that +*> column to the right side of A(1:M,N_sel+1:N_sub). Then the routine +*> checks if the stopping criteria are met in the next residual +*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. +*> +*> Computation of the matrix factors. +*> ================================== +*> +*> When the columns are selected for the factor C, and: +*> a) If the flag RET_C is set, then the routine explicitly returns +*> the matrix C, otherwise the routine returns only the indices of +*> the selected columns from the original matrix A stored in the JPIV +*> array as the first K elements. +*> b) If the flag COMP_X is set, then the routine also explicitly +*> computes and returns the factor X = pseudoinv(C) * A. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies how the factors of CX factorization +*> are returned. +*> +*> = 'P' or 'p' : return only the column permutaion matrix P +*> in the array JPIV. The first K elements +*> of the array JPIV contain indeces of +*> the factor C colums that were selected +*> from the matrix A. +*> (fastest, smallest memory space) +*> +*> = 'C' or 'c' : return the column permutaion matrix P +*> in the array JPIV and the factor C +*> explicitly in the array C +*> (slower, more memory space) +*> +*> = 'X' or 'x' : return the column permutaion matrix P +*> in the array JPIV, and both factors +*> C and X exlplicitly in the arrays +*> C and X respectively. +*> (slowest, largest memory space) +*> \endverbatim +*> +*> \param[in] USESD +*> \verbatim +*> USESD is CHARACTER*1 +*> Specifies if row deselection and column +*> preselection-deselection functionality is turned ON or OFF. +*> +*> = 'N' or 'n' : Both row deselection and column +*> preselection-deselection are OFF. +*> Both arrays DESEL_ROWS and +*> SEL_DESEL_COLS are not used. +*> +*> = 'R' or 'r' : Only row deselection is ON. +*> Column preselection-deselection is OFF. +*> The array SEL_DESEL_COLS is not used. +*> +*> = 'C' or 'c' : Only column preselection-deselection is ON. +*> Row deselection is OFF. +*> The array DESEL_ROWS is not used. +*> +*> = 'A' or 'a' : Means "All". +*> Both row deselection and column +*> preselection-deselection are ON. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (M) +*> This is a row deselection mask array that separates +*. the matrix A rows into 2 sets. +*> +*> a) If DESEL_ROWS(I) = -1, the I-th row of the matrix A is +*> deselected by the user, i.e. chosen to be excluded from +*. the algorithm and will be permuted to the bottom of A. +*> The number of deselected rows is denoted by M_desel. +*> +*> b) If DESEL_ROWS(I) not equal -1, +*> the I-th row of A is a free row and will be used by the +*> algorithm. This defines a set of M_sub = M - M_desel +*> rows that the algorithm will work on. After permutation, +*> this set will be in the top of the matrix A. +*> \endverbatim +*> +*> \param[in] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (N) +*> This is a column preselection/deselection mask array that +*. separates the matrix A columns into 3 sets. +*> +*> a) If SEL_DESEL_COLS(J) = +1, the J-th column of the matrix +*> A is selected by the user to be included in the factor C +*> and will be permuted to the left side of the array A. +*> The number of selected columns is denoted by N_sel. +*> +*> b) If SEL_DESEL_COLS(J) = -1, the J-th column of the matrix +*> A is deselected by the user, i.e. chosen to be excluded +*> from the factor C and will be permuted to the right side +*> of the array A. The number of deselected columns is +*> denoted by N_desel. +*> +*> c) If SEL_DESEL_COLS(J) not equal 1, and not equal -1, +*> the J-th column of A is a free column and will be used by +*> the algorithm to determine if this column has to be +*> selected. This defines a set of +*> N_free = N - N_sel - N_desel. +*> +*> NOTE: Error returned as INFO = -6 means that the number of +*> preselected N_sel colunms is larger than M_sub. +*> Therefore, the factoriaztion of all N_sel preselected +*> columns cannot be completed. +*> \endverbatim +*> +*> \param[in] KMAXFREE +*> \verbatim +*> KMAXFREE is INTEGER +*> +*> The first column selection stopping criterion in the +*> column selection stage 2. +*> +*> The maximum number of columns of the matrix A_sub to select +*> during the factorization stage, KMAXFREE >= 0 +*> +*> KMAXFREE does not include the preselected columns. +*> N_sel + KMAXFREE is the maximum factorization rank of +*> the matrix A_sub = A(1:M_sub, 1:N_sub). +*> +*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this +*> stopping criterion is not used, i.e. columns are selected +*> in the factorization stage depending on +*> ABSTOL and RELTOL. +*> +*> b) If KMAXFREE = 0, then this stopping criterion is +*> satisfied on input and the routine exits without +*> performing column selection stage 2 on the submatrix +*> A_sub. This means that the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified. +*> and A_free is itself the residual for the factorization. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second column selection stopping criterion in the +*> column selection stage 2. +*> +*> Here, SAFMIN = DLAMCH('S'). +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), +*> when K columns were factorized. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> A_sub_resid is less than or equal to ABSTOL. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -8 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, factorize columns depending on KMAXFREE +*> and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Here, maxcol2norm(A_free) is the maximum column 2-norm +*> of the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). +*> +*> If ABSTOL chosen above is >= maxcol2norm(A_free), then +*> this stopping criterion is satisfied after the matrix +*> A_sel = A(1:M_sub, 1:N_sel) is factorized and the +*> routine exits immediately after maxcol2norm(A_free) is +*> computed to return it in MAXC2NORMK. This means that +*> the factorization residual +*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) +*> is not modified. +*> Also RELMAXC2NORMK of A_free is returned. +*> This includes the case ABSTOL = +Inf. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third column selection stopping criterion in the +*> column selection stage 2. +*> +*> Here, EPS = DLAMCH('E'). +*> +*> The tolerance (stopping threshold) for the ratio +*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) of +*> the maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) and +*> the maximum column 2-norm of the original submatrix +*> A_sub = A(1:M_sub, 1:N_sub). The algorithm +*> converges (stops the factorization), when +*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -9 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, factorize columns depending on KMAXFREE +*> and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after A_sel = A(1:M_sub, 1:N_sel)) +*> is factorized and maxcol2norm(A_free) is computed to +*> return it in MAXC2NORMK. This means that +*> the factorization residual +*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) +*> is not modified. +*> Also RELMAXC2NORMK is returned as 1.0. +*> This includes the case RELTOL = +Inf. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL +*> +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> +*> On entry: +*> the M-by-N matrix A. +*> +*> On exit: +*> NOTE DEFINITIONS: M_sub = M_free, +*> N_sub = N_sel + N_free +*> +*> The output parameter K, the number of selected columns, +*> is described later. +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> +*> 2) If K > 0, A(1:M,1:N): contains the following parts: +*> +*> (a) If M_sub < M (which is the same as M_desel > 0), +*> the subarray A(M_sub+1:M,1:N) contains the deselected +*> rows. +*> +*> (b) If N_sub < N ( which is the same as N_desel > 1 ). +*> the subarray A(1:M,N_sub+1:N) contains the +*> deselected columns. +*> +*> (c) If N_sel > 0, +*> the union of the subarray A(1:M_sub, 1:N_sel) +*> and the subarray A(1:N_sel, 1:N_sub) contains parts +*> of the factors obtained by computing Householder QR +*> factorization WITHOUT column pivoting of N_sel +*> preselected columns using DGEQRF routine. +*> +*> (d) The subarray A(N_sel:M_sub, N_sel:N_sub) contains +*> parts of the factors obtained by computing a truncated +*> (rank K) Householder QR factorization with +*> column pivoting using DGEQP3RK on the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) which +*> is the result of applying selection and deselection +*> of columns, applying deselection of rows to the +*> original matrix A, and applying orthogonal +*> transformation from the factorization of the first +*> N_sel columns as described in part (c). +*> +*> 1. The elements below the diagonal of the subarray +*> A_sub(1:M_sub,1:K) together with TAU(1:K) +*> represent the orthogonal matrix Q(K) as a +*> product of K Householder elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A_sub(1:K,1:N_sub) contain +*> K-by-N_sub upper-trapezoidal matrix +*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). +*> NOTE: If K=min(M_sub,N_sub), i.e. full rank +*> factorization, then R_sub_approx(K) is the +*> full factor R which is upper-trapezoidal. +*> If, in addition, M_sub>=N_sub, then R is +*> upper-triangular. +*> +*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains +*> (M_sub-K)-by-(N_sub-K) rectangular matrix +*> A_sub_resid(K). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were selected. +*> (K is the factorization rank) +*> 0 <= K <= min( M_sub, min(N_sel+KMAXFREE, N_sub) ). +*> +*> If K = 0, the arrays A, TAU were not modified. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified +*> and is itself a residual matrix, then MAXC2NRMK equals +*> the maximum column 2-norm of the original matrix A_sub. +*> +*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. +*> +*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no factorization residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K would equal +*> to the diagonal element R_sub(K+1,K+1) of the factor +*> R_sub in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when +*> factorization stopped at rank K) and maximum column 2-norm +*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). +*> RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub was not modified +*> and is itself a residual matrix, +*> then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M_sub,N_sub), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix +*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next +*> factorization step K+1, where R_sub(K+1,K+1) is the +*> diaginal element of the factor R_sub in the next +*> factorization step K+1. +*> \endverbatim +*> +*> \param[out] FNRMK +*> \verbatim +*> FNRMK is DOUBLE PRECISION +*> Frobenius norm of the factorization residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). +*> FNRMK >= 0.0 +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (M) +*> Row permutation indices due to row +*> deselection, for 1 <= i <= M. +*> If IPIV(i)= k, then the row i of A_sub was the +*> the row k of A. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column permutation indices, for 1 <= j <= N. +*> If JPIV(j)= k, then the column j of A*P was the +*> the column k of A. +*> +*> The first K elements of the array JPIV contain +*> indeces of the factor C colums that were selected +*> from the matrix A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= MIN(M_sub,N_sub), only elements TAU(1:K) of +*> the array TAU may be modified. The elements +*> TAU(K+1:min(M_sub,N_sub)) are set to zero. +*> The elements of TAU(min(M_sub,N_sub)+1:N) are not +*> modified. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array. +*> If FACT = 'C' or 'X': +*> If K > 0, C is the M-by-K factor C +*> and array has dimension (LDC,N), +*> If FACT = 'N': +*> array is not used and can have linear dimension >=1. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> If FACT = 'C' or 'X', LDC >= max(1,M). +*> If FACT = 'P', LDC >= 1. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array. +*> If FACT = 'X': +*> If K > 0, C is the K-by-N factor X +*> and array has dimension (LDX,N). +*> If FACT = 'P': +*> array is not used and can have linear dimension >=1. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> If FACT = 'X', LDC >= max(1,M). +*> If FACT = 'P', LDC >= 1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO>=0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 3*N_sub+1. +*> For optimal performance LWORK >= 2*N_sub+( N_sub+1 )*NB, +*> where NB is the optimal blocksize. +*> +*> 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. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N). +*> Is a work array. ( IWORK is used by DGEQP3RK to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine DLAQP3RK ). +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array LIWORK. LIWORK >= N +*> +*> If LIWORK = -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 IWORK array, and no error +*> message related to LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular factor of in the matrix C is zero, +*> so that C does not have full rank; X cannot be +*> computed as the least squares solution to C*X = A. +*> \endverbatim +* ===================================================================== + SUBROUTINE DGECX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, X, LDX, + $ WORK, LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER FACT, USESD + INTEGER INFO, K, KMAXFREE, LDA, LDC, LDX, LIWORK, + $ LWORK, M, N + DOUBLE PRECISION ABSTOL, ABSTOLFREE, MAXC2NRMK, RELTOL, + $ RELTOLFREE, RELMAXC2NRMK, FNRMK +* .. +* .. Array Arguments .. + INTEGER DESEL_ROWS( * ), IPIV( * ), JPIV( * ), + $ SEL_DESEL_COLS( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), + $ X( LDX, *), WORK( * ) +* ===================================================================== +* +* .. Parameters .. + INTEGER INB + PARAMETER ( INB = 1 ) + DOUBLE PRECISION ZERO, TWO, MINUSONE + PARAMETER ( ZERO = 0.0D+0, TWO = 2.0D+0, + $ MINUSONE = -1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LIQUERY, LQUERY, RETURNC, RETURNX, + $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL + INTEGER I, J, NSUB, MFREE, MSUB, MNSUB, NSEL, JDESEL, + $ ITEMP, IINFO, KP, KP0, KFREE, MRESID, NRESID, + $ NRHS, LWKMIN, LWKOPT, JP, JJ, JPW, MINMN, + $ NBOPT + DOUBLE PRECISION EPS, MAXC2NRM, SAFMIN, RELMAXC2NRMKFREE + +* .. External Subroutines .. + EXTERNAL DLACPY, DGELS, DGEQP3RK, DGEQRF, DORMQR, + $ DSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN, LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 + EXTERNAL DISNAN, DLAMCH, DLANGE, DNRM2, IDAMAX, + $ ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + LIQUERY = ( LIWORK.EQ.-1 ) +* + RETURNX = LSAME( FACT, 'X' ) + RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX +* + USE_DESEL_ROWS = LSAME( USESD, 'R' ) .OR. LSAME( USESD, 'A' ) + USE_SEL_DESEL_COLS = LSAME( USESD, 'C') .OR. LSAME( USESD, 'A' ) +* + IF ( .NOT.(RETURNC .OR. LSAME( FACT, 'P') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS + $ .OR. LSAME( USESD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KMAXFREE.LT.0 ) THEN + INFO = -7 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -8 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.RETURNC .AND. LDC.LT.1 )) THEN + INFO = -20 + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.RETURNX .AND. LDX.LT.1 )) THEN + INFO = -22 + END IF +* +* If the above input parameters are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement LWKMIN. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of: (1) LWORK < LWKMIN, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, LWKMIN is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + ELSE + LWKMIN = 3*N + 1 +* +* Assign to NBOPT optimal block size. +* + NBOPT = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = 1000 + END IF + WORK( 1 ) = DBLE( LWKOPT ) +* + IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -24 + END IF + END IF +* +* ================================================================== +* + K = 0 +* + EPS = DLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL only if nonnegative. Negative value means disabled. +* We need to keep negtive value for later use in criterion +* check. +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Ajust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negtive value for later use in criterion +* check. +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* +* If we need to return factor C, copy the original unctouched matrix +* A into the array C. +* + IF( RETURNC ) THEN + CALL DLACPY( 'F', M, N, A, LDA, C, LDC ) + END IF +* +* If we need to return factor X, copy the original unctouched matrix +* A into the array X. +* + IF( RETURNX ) THEN + CALL DLACPY( 'F', M, N, A, LDA, X, LDX ) + END IF +* +* ================================================================== +* Permute the deselected rows to the bottom of the matrix A. +* 1) Order of free rows is preserved. +* 2) Order of deselected rows is not preserved. +* ================================================================== +* +* I is the index of DESEL_ROWS array and row I +* of the matrix A. +* MFREE is the number of free rows, also the pointer to the last +* free row. +* (For each position I, we check if this position is a FREE row. +* If it is a FREE row we increment the MFREE pointer, otherwise we +* do not change the MFREE pointer. Also, if it is a FREE row, we move +* this row from the larger (or same) I index into samaller (or same) +* MFREE index. This way we move all the FREE rows to the lower index +* block preserving FREE row order. Deselected rows will be ) +* + IF( USE_DESEL_ROWS ) THEN +* + MFREE = 0 + DO I = 1, M, 1 +* +* Initialize row pivot array IPIV. + IPIV( I ) = I +* + IF( DESEL_ROWS(I).NE.-1 ) THEN + MFREE = MFREE + 1 +* +* This is the check whether the deselected row is +* on the deselected place already. +* + IF( I.NE.MFREE ) THEN +* +* Here, we swap A(I,1:N) into A(MFREE,1:N) +* + CALL DSWAP( N, A( I, 1 ), LDA, A( MFREE, 1 ), LDA ) + IPIV( I ) = IPIV( MFREE ) + IPIV( MFREE ) = I + ITEMP = DESEL_ROWS( I ) + DESEL_ROWS( I ) = DESEL_ROWS( MFREE ) + DESEL_ROWS( MFREE ) = ITEMP + END IF + END IF +* + END DO +* + ELSE +* +* We do not row deselection DESEL_ROWS array. +* Initialize row pivot array IPIV. +* + DO I = 1, M, 1 + IPIV( I ) = I + END DO +* + MFREE = M + END IF + MSUB = M +* +* ================================================================== +* Permute the pseselected columns to the left and deselected +* columns to the right of the matrix A. +* 1) Order of preselected columns is preserved. +* 2) Order of free columns is not preserved. +* 3) Order of deselected columns is not preserved. +* ================================================================== +* +* J is the index of SEL_DESEL_COLS array and column J +* of the matrix A. +* +* Column selection. +* NSEL is the number of selected columns, also the pointer to the last +* selected column. +* + NSEL = 0 + IF( USE_SEL_DESEL_COLS ) THEN +* + DO J = 1, N, 1 +* +* Initialize column pivot array JPIV. + JPIV( J ) = J +* + IF( SEL_DESEL_COLS(J).EQ.1 ) THEN + NSEL = NSEL + 1 +* +* This is the check whether the selected column is +* on the selected place already. +* + IF( J.NE.NSEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,NSEL) +* + CALL DSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) + JPIV( J ) = JPIV( NSEL ) + JPIV( NSEL ) = J + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) + SEL_DESEL_COLS( NSEL ) = 1 + END IF + END IF + END DO +* +* Column deselection. +* + JDESEL = N+1 + DO J = N, NSEL+1, -1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN + JDESEL = JDESEL - 1 +* +* This is the check whether the deselected column is +* on the deselected place already. +* + IF( J.NE.JDESEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) +* + CALL DSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) + ITEMP = JPIV( J ) + JPIV( J ) = JPIV( JDESEL ) + JPIV( JDESEL ) = ITEMP + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) + SEL_DESEL_COLS( JDESEL ) = -1 + END IF + END IF + END DO +* + NSUB = JDESEL - 1 +* + ELSE +* +* We do not column selection deselection SEL_DESEL_COLS array. +* Initialize column pivot array JPIV. +* + DO J = 1, N, 1 + JPIV( J ) = J + END DO +* + NSUB = N + END IF +* +* ================================================================== +* Compute the complete column 2-norms of the submatrix +* A_sub=A(1:MSUB, 1:NSUB) and store them in WORK(NSUB+1:2*NSUB). +* + DO J = 1, NSUB + WORK( NSUB+J ) = DNRM2( MSUB, A( 1, J ), 1 ) + END DO +* +* Compute the column index and the maximum column 2-norm +* for the submatrix A_sub=A(1:MSUB, 1:NSUB). +* + KP0 = IDAMAX( NSUB, WORK( NSUB+1 ), 1 ) + MAXC2NRM = WORK( NSUB + KP0 ) +* +* ================================================================== +* Process preselected columns +* +* Compute the QR factorization of NSEL preselected columns (1:NSEL) +* the submatrix A_sub=(1:MSUB, 1:NSUB) and update +* remaining NFEE free columns (NSEL+1:NSUB). +* MSUB = MFREE, NSUB = MSEL + NFREE +* + MNSUB = MIN(MSUB, NSUB) + MRESID = MSUB-NSEL + NRESID = NSUB-NSEL + IF( NSEL.GT.0 ) THEN + IF( MSUB.LT.NSEL ) THEN +* TODO: Move this part to the top of the routine. +* a) Case MSUB < NSEL. +* When the number of preselected columns +* is larger than MSUB, hence the factorization of all NSEL +* columns cannot be completed. Return from the routine with the +* error of COL_SEL_DESEL parameter. NSEL cannot be larger than +* MSUB. +* + INFO = -6 + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + ELSE IF( MSUB.EQ.NSEL.OR. + $ ( MSUB.GT.NSEL.AND.NSEL.EQ.NSUB )) THEN +* +* b) Case MSUB = NSEL. +* c-1) Case MSUB > NSEL and NSEL = NSUB. +* +* There will be no residual submatrix after factorization +* of NSEL columns at step K = NSEL: +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). +* Therefore, ther is no need to do the factorization of NSEL +* columns. Set norms to ZERO and return from the routine. +* + K = NSEL + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO +* + DO J = K + 1, MNSUB + TAU( J ) = ZERO + END DO +* +* Factorization is done. Go to computation of the factor C. +* + GO TO 10 + ELSE +* +* (c-2) Case MSUB > NSEL and NSEL < NSUB. +* +* There is a submatrix residual at step K=NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) +* +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL DORMQR( 'Left', 'Transpose', MSUB, NSUB-NSEL, NSEL, + $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, LWORK, IINFO ) +* +* Compute the complete column 2-norms of the submatrix +* residual at step NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) and +* store them in WORK(NSUB+NSEL+1:2*NSUB). +* + DO J = NSEL+1, NSUB + WORK( NSUB+J ) = DNRM2( MRESID, A( NSEL+1, J ), 1 ) + END DO +* +* Compute the column index and the maximum column 2-norm +* and the relative maximum column 2-norm for the submatrix +* residual. +* + KP = IDAMAX( NRESID, WORK( NSUB+NSEL+1 ), 1 ) +* + K = NSEL + MAXC2NRMK = WORK( NSUB + NSEL + KP ) + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* +* Test for the first, second and third tolerance stopping +* criteria after factorizarion of preselected columns. +* If any of them is met, return. Otherwise, +* proceed with factorization of the NFREE free columns. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* + IF( KMAXFREE.EQ.0 + $ .OR. MAXC2NRMK.LE.ABSTOL + $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* NOTE: In this (c-2) case. There is a submatrix +* residual A_sub_resid(NSEL). We do not need to have a check +* for MIN(MRESID, NRESID) = 0 to call DLANGE. +* + FNRMK = DLANGE( 'F', MRESID, NRESID, A(NSEL+1,NSEL+1), + $ LDA, WORK ) +* + DO J = K + 1, MNSUB + TAU( J ) = ZERO + END DO +* +* Factorization is done. Go to computation of the factor C. +* + GO TO 10 + END IF +* +* +* + END IF + END IF +* +* ================================================================== +* +* Factorize NFREE free columns of +* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), +* KFREE is the number of columns that were actually factorized among +* NFREE columns. +* +* Disable RELTOLFREE when calling DGEQP3RK for free columns +* factorization, since it expects RELTOLFREE with respect to +* the residual matrix A_sub_resid(NSEL), not the whole original +* marix A. We can use RELTOL criterion by passing it to +* ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that +* the negative values of ABSTOL and RELTOL are propagated +* to ABSTOLFREE and RELTOLFREE, since negative vaslues means +* that the criterionis is disabled. +* + IF( USETOL ) THEN + ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) + ELSE + ABSTOLFREE = MINUSONE + END IF + RELTOLFREE = MINUSONE + NRHS = 0 +* + CALL DGEQP3RK( MRESID, NRESID, NRHS, KMAXFREE, + $ ABSTOLFREE, RELTOLFREE, + $ A( K+1, K+1 ), LDA, KFREE, MAXC2NRMK, + $ RELMAXC2NRMKFREE, JPIV( K+1 ), TAU( K+1 ), + $ WORK, LWORK, IWORK, IINFO ) +* +* 1) Adjust the return value for the number of factorized +* columns K for the whole submatrix A_sub. +* 2) MAXC2NRMK is returned transparently without change +* as it is returned from DGEQP3RK. +* 3) Adjust the return value RELMAXC2NRMK for the whole +* submatrix A_sub. We do not use RELMAXC2NRMKFREE +* returned from DGEQP3RK. +* + K = K + KFREE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* +* Now, MRESID and NRESID is the number of rows and columns +* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). +* + MRESID = MRESID-KFREE + NRESID = NRESID-KFREE + IF( MIN( MRESID, NRESID ).NE.0 ) THEN + FNRMK = DLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), + $ LDA, WORK ) + ELSE + FNRMK = ZERO + END IF +* +* Compute the factor C. +* + 10 CONTINUE +* + IF( RETURNC .AND. K.GT.0 ) THEN +* +* Apply interchanges to columns 1:K in the matrix C in place, +* which stores the original matrix A. +* IWORK is used to keep track of original column indices, +* when swaping. + + DO J = 1, N, 1 + IWORK( J ) = J + END DO + DO J = 1, K, 1 + JP = JPIV( J ) + IF( J.NE.JP ) THEN + DO JJ = J, N, 1 + IF( JP.EQ.IWORK( JJ ) ) THEN + JPW = JJ + END IF + END DO + IF( J.NE.JPW ) THEN + CALL DSWAP( M, C( 1, J ), 1, C( 1, JPW ), 1 ) + ITEMP = IWORK( J ) + IWORK( J ) = IWORK( JPW ) + IWORK( JPW ) = ITEMP + END IF + END IF + END DO +* + END IF +* +* Return matrix X. +* + IF( RETURNX .AND. K.GT.0 ) THEN +* +* We need to use C and A to compute X = pseudoinv(C) * A, as +* the Linear Least Squares problem C*X = A. We use LLS routine +* that uses QR factorization. For that purpose, we store C into +* WORK array WORK(1:M*K), and the matrix A was copied into +* the array X at the begining of the routine. +* +* Copy matrix C into work array WORK. +* + CALL DLACPY( 'F', M, K, C, LDC, WORK, M ) +* + CALL DGELS( 'N', M, K, N, WORK, M, X, LDX, + $ WORK( M*K+1 ), LWORK, + $ IINFO ) + INFO = IINFO +* + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* DGECX +* + END \ No newline at end of file From df8c7393afdc2b303a87438a71539f60ae61012b Mon Sep 17 00:00:00 2001 From: Igor Date: Tue, 14 Oct 2025 23:56:55 -0700 Subject: [PATCH 02/63] Added dgecx.f, a DRAFT for DGECX routine --- SRC/dgecx.f | 1173 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1173 insertions(+) create mode 100644 SRC/dgecx.f diff --git a/SRC/dgecx.f b/SRC/dgecx.f new file mode 100644 index 000000000..8bcb1ee4f --- /dev/null +++ b/SRC/dgecx.f @@ -0,0 +1,1173 @@ +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGECX computes a CX factorization of a real M-by-N matrix A: +*> +*> A * P(K) = C*X + A_resid, where +*> +*> C is an M-by-K matrix which is a subset of K columns selected +*> from the original matrix A, +*> +*> X is a K-by-N matrix that minimizes the Frobenius norm of the +*> residual matrix A_resid, X = pseudoinv(C) * A, +*> +*> P(K) is an N-by-N permutation matrix chosen so that the first +*> K columns of A*P(K) equal C, +*> +*> A_resid is an M-by-N residual matrix. +*> +*> The column selection for the matrix C has two stages. +*> +*> Column selection stage 1. +*> ========================= +*> +*> The user can select N_sel columns and deselect N_desel columns +*> of the matrix A that MUST be included and excluded respectively +*> from the matrix C a priori, before running the column selection +*> algorithm. This is controlled by the flags in the array +*> SEL_DESEL_COLS. The deselected columns are permuted to the right +*> side of the array A and selected columns are permuted to the left +*> side of the array A. The details of the column permutation +*> (i.e. the column permutation matrix P(K)) are stored in the +*> array JPIV. This feature can be used when the goal is to approximate +*> the deselected columns by linear combinations of K selected columns, +*> where the K columns MUST include the N_sel selected columns. +*> +*> Column selection stage 2. +*> ========================= +*> +*> The routine runs the column selection algorithm that can +*> be controlled with three stopping criteria described below. +*> For the column selection, the routine uses a truncated (rank K) in +*> Householder QR factorization with column pivoting algorithm +*> DGEQP3RK routine. Note, that before running the column selection +*> algorithm, the user can deselect M_desel rows of the matrix A that +*> should NOT be considered by the column selection algorithm (i.e. +*> during the factorization). This is controlled by the flags in +*> the array DESEL_ROWS. The deselected rows are permuted to the +*> bottom of the array A. The details of the row permutation (i.e. the +*> row permutation matrix) are stored in the array IPIV. This feature +*> can be used when the goal is to use the deselected rows as test data, +*> and the selected rows as training data. +*> +*> This means that the column selection factorization algorithm is +*> effectively running on the submatrix A_sub=A(1:M_sub,1:N_sub) of +*> the matrix A after the permutations described above. Here M_sub is +*> the number of rows of the matrix A minus the number of deselected +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> of columns of the matrix A minus the number of deselected columns +*> N_desel, i.e. N_sub = N - N_desel. +*> +*> Column selection criteria. +*> ========================== +*> +*> The column selection criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAXFREE, the maximum number of columns +*> to factorize outside of the N_sel preselected columns, +*> i.e. the factorization rank is limited to N_sel + KMAXFREE. +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), the criterion +*> is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the submatrix residual +*> A_sub_resid = A(K+1:M_sub, K+1:N_sub). +*> This means that the factorization stops if this norm is less +*> or equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the submatrix residual +*> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub) divided +*> by the maximum column 2-norm of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub). +*> This means that the factorization stops when the ratio of the +*> maximum column 2-norm of A_sub_resid to the maximum column +*> 2-norm of A_sub is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole submatrix A_sub is factorized. +*> +*> For a full rank factorization of the matrix A_sub, use selection +*> criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) and +*> ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> If the user wants to verify whether the columns of the matrix C are +*> sufficiently linearly independent for their intended use, the user +*> can compute the condition number of its R factor by calling DTRCON +*> on the upper-triangular part of A(1:K,1:K) of the output array A. +*> +*> How N_sel affects the column selection algorithm. +*> ================================================= +*> +*> As mentioned above, the N_sel selected columns are permuted to the +*> right side of the array A, and will be included in the column +*> selection. Then the routine runs the factorization of that block +*> A(1:M_sub,1:N_sel), and if any of the three stopping criteria is met +*> immediately after factoring the first N_sel columns the routine exits +*> (i.e. there is no requirement to select extra columns, +*> if the absolute or relative tolerance of the maximum column 2-norm of +*> the residual is satisfied). In this case, the number +*> of selected columns would be K = N_sel. Otherwise, the factorization +*> routine finds a new column to select with the maximum column 2-norm +*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and permutes that +*> column to the right side of A(1:M,N_sel+1:N_sub). Then the routine +*> checks if the stopping criteria are met in the next residual +*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. +*> +*> Computation of the matrix factors. +*> ================================== +*> +*> When the columns are selected for the factor C, and: +*> a) If the flag RET_C is set, then the routine explicitly returns +*> the matrix C, otherwise the routine returns only the indices of +*> the selected columns from the original matrix A stored in the JPIV +*> array as the first K elements. +*> b) If the flag COMP_X is set, then the routine also explicitly +*> computes and returns the factor X = pseudoinv(C) * A. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies how the factors of CX factorization +*> are returned. +*> +*> = 'P' or 'p' : return only the column permutaion matrix P +*> in the array JPIV. The first K elements +*> of the array JPIV contain indeces of +*> the factor C colums that were selected +*> from the matrix A. +*> (fastest, smallest memory space) +*> +*> = 'C' or 'c' : return the column permutaion matrix P +*> in the array JPIV and the factor C +*> explicitly in the array C +*> (slower, more memory space) +*> +*> = 'X' or 'x' : return the column permutaion matrix P +*> in the array JPIV, and both factors +*> C and X exlplicitly in the arrays +*> C and X respectively. +*> (slowest, largest memory space) +*> \endverbatim +*> +*> \param[in] USESD +*> \verbatim +*> USESD is CHARACTER*1 +*> Specifies if row deselection and column +*> preselection-deselection functionality is turned ON or OFF. +*> +*> = 'N' or 'n' : Both row deselection and column +*> preselection-deselection are OFF. +*> Both arrays DESEL_ROWS and +*> SEL_DESEL_COLS are not used. +*> +*> = 'R' or 'r' : Only row deselection is ON. +*> Column preselection-deselection is OFF. +*> The array SEL_DESEL_COLS is not used. +*> +*> = 'C' or 'c' : Only column preselection-deselection is ON. +*> Row deselection is OFF. +*> The array DESEL_ROWS is not used. +*> +*> = 'A' or 'a' : Means "All". +*> Both row deselection and column +*> preselection-deselection are ON. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (M) +*> This is a row deselection mask array that separates +*. the matrix A rows into 2 sets. +*> +*> a) If DESEL_ROWS(I) = -1, the I-th row of the matrix A is +*> deselected by the user, i.e. chosen to be excluded from +*. the algorithm and will be permuted to the bottom of A. +*> The number of deselected rows is denoted by M_desel. +*> +*> b) If DESEL_ROWS(I) not equal -1, +*> the I-th row of A is a free row and will be used by the +*> algorithm. This defines a set of M_sub = M - M_desel +*> rows that the algorithm will work on. After permutation, +*> this set will be in the top of the matrix A. +*> \endverbatim +*> +*> \param[in] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (N) +*> This is a column preselection/deselection mask array that +*. separates the matrix A columns into 3 sets. +*> +*> a) If SEL_DESEL_COLS(J) = +1, the J-th column of the matrix +*> A is selected by the user to be included in the factor C +*> and will be permuted to the left side of the array A. +*> The number of selected columns is denoted by N_sel. +*> +*> b) If SEL_DESEL_COLS(J) = -1, the J-th column of the matrix +*> A is deselected by the user, i.e. chosen to be excluded +*> from the factor C and will be permuted to the right side +*> of the array A. The number of deselected columns is +*> denoted by N_desel. +*> +*> c) If SEL_DESEL_COLS(J) not equal 1, and not equal -1, +*> the J-th column of A is a free column and will be used by +*> the algorithm to determine if this column has to be +*> selected. This defines a set of +*> N_free = N - N_sel - N_desel. +*> +*> NOTE: Error returned as INFO = -6 means that the number of +*> preselected N_sel colunms is larger than M_sub. +*> Therefore, the factoriaztion of all N_sel preselected +*> columns cannot be completed. +*> \endverbatim +*> +*> \param[in] KMAXFREE +*> \verbatim +*> KMAXFREE is INTEGER +*> +*> The first column selection stopping criterion in the +*> column selection stage 2. +*> +*> The maximum number of columns of the matrix A_sub to select +*> during the factorization stage, KMAXFREE >= 0 +*> +*> KMAXFREE does not include the preselected columns. +*> N_sel + KMAXFREE is the maximum factorization rank of +*> the matrix A_sub = A(1:M_sub, 1:N_sub). +*> +*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this +*> stopping criterion is not used, i.e. columns are selected +*> in the factorization stage depending on +*> ABSTOL and RELTOL. +*> +*> b) If KMAXFREE = 0, then this stopping criterion is +*> satisfied on input and the routine exits without +*> performing column selection stage 2 on the submatrix +*> A_sub. This means that the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified. +*> and A_free is itself the residual for the factorization. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second column selection stopping criterion in the +*> column selection stage 2. +*> +*> Here, SAFMIN = DLAMCH('S'). +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), +*> when K columns were factorized. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> A_sub_resid is less than or equal to ABSTOL. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -8 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, factorize columns depending on KMAXFREE +*> and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Here, maxcol2norm(A_free) is the maximum column 2-norm +*> of the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). +*> +*> If ABSTOL chosen above is >= maxcol2norm(A_free), then +*> this stopping criterion is satisfied after the matrix +*> A_sel = A(1:M_sub, 1:N_sel) is factorized and the +*> routine exits immediately after maxcol2norm(A_free) is +*> computed to return it in MAXC2NORMK. This means that +*> the factorization residual +*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) +*> is not modified. +*> Also RELMAXC2NORMK of A_free is returned. +*> This includes the case ABSTOL = +Inf. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third column selection stopping criterion in the +*> column selection stage 2. +*> +*> Here, EPS = DLAMCH('E'). +*> +*> The tolerance (stopping threshold) for the ratio +*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) of +*> the maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) and +*> the maximum column 2-norm of the original submatrix +*> A_sub = A(1:M_sub, 1:N_sub). The algorithm +*> converges (stops the factorization), when +*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -9 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, factorize columns depending on KMAXFREE +*> and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after A_sel = A(1:M_sub, 1:N_sel)) +*> is factorized and maxcol2norm(A_free) is computed to +*> return it in MAXC2NORMK. This means that +*> the factorization residual +*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) +*> is not modified. +*> Also RELMAXC2NORMK is returned as 1.0. +*> This includes the case RELTOL = +Inf. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL +*> +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> +*> On entry: +*> the M-by-N matrix A. +*> +*> On exit: +*> NOTE DEFINITIONS: M_sub = M_free, +*> N_sub = N_sel + N_free +*> +*> The output parameter K, the number of selected columns, +*> is described later. +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> +*> 2) If K > 0, A(1:M,1:N): contains the following parts: +*> +*> (a) If M_sub < M (which is the same as M_desel > 0), +*> the subarray A(M_sub+1:M,1:N) contains the deselected +*> rows. +*> +*> (b) If N_sub < N ( which is the same as N_desel > 1 ). +*> the subarray A(1:M,N_sub+1:N) contains the +*> deselected columns. +*> +*> (c) If N_sel > 0, +*> the union of the subarray A(1:M_sub, 1:N_sel) +*> and the subarray A(1:N_sel, 1:N_sub) contains parts +*> of the factors obtained by computing Householder QR +*> factorization WITHOUT column pivoting of N_sel +*> preselected columns using DGEQRF routine. +*> +*> (d) The subarray A(N_sel:M_sub, N_sel:N_sub) contains +*> parts of the factors obtained by computing a truncated +*> (rank K) Householder QR factorization with +*> column pivoting using DGEQP3RK on the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) which +*> is the result of applying selection and deselection +*> of columns, applying deselection of rows to the +*> original matrix A, and applying orthogonal +*> transformation from the factorization of the first +*> N_sel columns as described in part (c). +*> +*> 1. The elements below the diagonal of the subarray +*> A_sub(1:M_sub,1:K) together with TAU(1:K) +*> represent the orthogonal matrix Q(K) as a +*> product of K Householder elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A_sub(1:K,1:N_sub) contain +*> K-by-N_sub upper-trapezoidal matrix +*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). +*> NOTE: If K=min(M_sub,N_sub), i.e. full rank +*> factorization, then R_sub_approx(K) is the +*> full factor R which is upper-trapezoidal. +*> If, in addition, M_sub>=N_sub, then R is +*> upper-triangular. +*> +*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains +*> (M_sub-K)-by-(N_sub-K) rectangular matrix +*> A_sub_resid(K). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were selected. +*> (K is the factorization rank) +*> 0 <= K <= min( M_sub, min(N_sel+KMAXFREE, N_sub) ). +*> +*> If K = 0, the arrays A, TAU were not modified. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified +*> and is itself a residual matrix, then MAXC2NRMK equals +*> the maximum column 2-norm of the original matrix A_sub. +*> +*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. +*> +*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no factorization residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K would equal +*> to the diagonal element R_sub(K+1,K+1) of the factor +*> R_sub in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when +*> factorization stopped at rank K) and maximum column 2-norm +*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). +*> RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub was not modified +*> and is itself a residual matrix, +*> then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M_sub,N_sub), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix +*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next +*> factorization step K+1, where R_sub(K+1,K+1) is the +*> diaginal element of the factor R_sub in the next +*> factorization step K+1. +*> \endverbatim +*> +*> \param[out] FNRMK +*> \verbatim +*> FNRMK is DOUBLE PRECISION +*> Frobenius norm of the factorization residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). +*> FNRMK >= 0.0 +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (M) +*> Row permutation indices due to row +*> deselection, for 1 <= i <= M. +*> If IPIV(i)= k, then the row i of A_sub was the +*> the row k of A. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column permutation indices, for 1 <= j <= N. +*> If JPIV(j)= k, then the column j of A*P was the +*> the column k of A. +*> +*> The first K elements of the array JPIV contain +*> indeces of the factor C colums that were selected +*> from the matrix A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= MIN(M_sub,N_sub), only elements TAU(1:K) of +*> the array TAU may be modified. The elements +*> TAU(K+1:min(M_sub,N_sub)) are set to zero. +*> The elements of TAU(min(M_sub,N_sub)+1:N) are not +*> modified. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array. +*> If FACT = 'C' or 'X': +*> If K > 0, C is the M-by-K factor C +*> and array has dimension (LDC,N), +*> If FACT = 'N': +*> array is not used and can have linear dimension >=1. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> If FACT = 'C' or 'X', LDC >= max(1,M). +*> If FACT = 'P', LDC >= 1. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array. +*> If FACT = 'X': +*> If K > 0, C is the K-by-N factor X +*> and array has dimension (LDX,N). +*> If FACT = 'P': +*> array is not used and can have linear dimension >=1. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> If FACT = 'X', LDC >= max(1,M). +*> If FACT = 'P', LDC >= 1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO>=0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 3*N_sub+1. +*> For optimal performance LWORK >= 2*N_sub+( N_sub+1 )*NB, +*> where NB is the optimal blocksize. +*> +*> 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. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N). +*> Is a work array. ( IWORK is used by DGEQP3RK to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine DLAQP3RK ). +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array LIWORK. LIWORK >= N +*> +*> If LIWORK = -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 IWORK array, and no error +*> message related to LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular factor of in the matrix C is zero, +*> so that C does not have full rank; X cannot be +*> computed as the least squares solution to C*X = A. +*> \endverbatim +* ===================================================================== + SUBROUTINE DGECX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, X, LDX, + $ WORK, LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER FACT, USESD + INTEGER INFO, K, KMAXFREE, LDA, LDC, LDX, LIWORK, + $ LWORK, M, N + DOUBLE PRECISION ABSTOL, ABSTOLFREE, MAXC2NRMK, RELTOL, + $ RELTOLFREE, RELMAXC2NRMK, FNRMK +* .. +* .. Array Arguments .. + INTEGER DESEL_ROWS( * ), IPIV( * ), JPIV( * ), + $ SEL_DESEL_COLS( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), + $ X( LDX, *), WORK( * ) +* ===================================================================== +* +* .. Parameters .. + INTEGER INB + PARAMETER ( INB = 1 ) + DOUBLE PRECISION ZERO, TWO, MINUSONE + PARAMETER ( ZERO = 0.0D+0, TWO = 2.0D+0, + $ MINUSONE = -1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LIQUERY, LQUERY, RETURNC, RETURNX, + $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL + INTEGER I, J, NSUB, MFREE, MSUB, MNSUB, NSEL, JDESEL, + $ ITEMP, IINFO, KP, KP0, KFREE, MRESID, NRESID, + $ NRHS, LWKMIN, LWKOPT, JP, JJ, JPW, MINMN, + $ NBOPT + DOUBLE PRECISION EPS, MAXC2NRM, SAFMIN, RELMAXC2NRMKFREE + +* .. External Subroutines .. + EXTERNAL DLACPY, DGELS, DGEQP3RK, DGEQRF, DORMQR, + $ DSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN, LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 + EXTERNAL DISNAN, DLAMCH, DLANGE, DNRM2, IDAMAX, + $ ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + LIQUERY = ( LIWORK.EQ.-1 ) +* + RETURNX = LSAME( FACT, 'X' ) + RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX +* + USE_DESEL_ROWS = LSAME( USESD, 'R' ) .OR. LSAME( USESD, 'A' ) + USE_SEL_DESEL_COLS = LSAME( USESD, 'C') .OR. LSAME( USESD, 'A' ) +* + IF ( .NOT.(RETURNC .OR. LSAME( FACT, 'P') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS + $ .OR. LSAME( USESD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( KMAXFREE.LT.0 ) THEN + INFO = -7 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -8 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.RETURNC .AND. LDC.LT.1 )) THEN + INFO = -20 + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.RETURNX .AND. LDX.LT.1 )) THEN + INFO = -22 + END IF +* +* If the above input parameters are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement LWKMIN. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of: (1) LWORK < LWKMIN, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, LWKMIN is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + ELSE + LWKMIN = 3*N + 1 +* +* Assign to NBOPT optimal block size. +* + NBOPT = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = 1000 + END IF + WORK( 1 ) = DBLE( LWKOPT ) +* + IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -24 + END IF + END IF +* +* ================================================================== +* + K = 0 +* + EPS = DLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL only if nonnegative. Negative value means disabled. +* We need to keep negtive value for later use in criterion +* check. +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Ajust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negtive value for later use in criterion +* check. +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* +* If we need to return factor C, copy the original unctouched matrix +* A into the array C. +* + IF( RETURNC ) THEN + CALL DLACPY( 'F', M, N, A, LDA, C, LDC ) + END IF +* +* If we need to return factor X, copy the original unctouched matrix +* A into the array X. +* + IF( RETURNX ) THEN + CALL DLACPY( 'F', M, N, A, LDA, X, LDX ) + END IF +* +* ================================================================== +* Permute the deselected rows to the bottom of the matrix A. +* 1) Order of free rows is preserved. +* 2) Order of deselected rows is not preserved. +* ================================================================== +* +* I is the index of DESEL_ROWS array and row I +* of the matrix A. +* MFREE is the number of free rows, also the pointer to the last +* free row. +* (For each position I, we check if this position is a FREE row. +* If it is a FREE row we increment the MFREE pointer, otherwise we +* do not change the MFREE pointer. Also, if it is a FREE row, we move +* this row from the larger (or same) I index into samaller (or same) +* MFREE index. This way we move all the FREE rows to the lower index +* block preserving FREE row order. Deselected rows will be ) +* + IF( USE_DESEL_ROWS ) THEN +* + MFREE = 0 + DO I = 1, M, 1 +* +* Initialize row pivot array IPIV. + IPIV( I ) = I +* + IF( DESEL_ROWS(I).NE.-1 ) THEN + MFREE = MFREE + 1 +* +* This is the check whether the deselected row is +* on the deselected place already. +* + IF( I.NE.MFREE ) THEN +* +* Here, we swap A(I,1:N) into A(MFREE,1:N) +* + CALL DSWAP( N, A( I, 1 ), LDA, A( MFREE, 1 ), LDA ) + IPIV( I ) = IPIV( MFREE ) + IPIV( MFREE ) = I + ITEMP = DESEL_ROWS( I ) + DESEL_ROWS( I ) = DESEL_ROWS( MFREE ) + DESEL_ROWS( MFREE ) = ITEMP + END IF + END IF +* + END DO +* + ELSE +* +* We do not row deselection DESEL_ROWS array. +* Initialize row pivot array IPIV. +* + DO I = 1, M, 1 + IPIV( I ) = I + END DO +* + MFREE = M + END IF + MSUB = M +* +* ================================================================== +* Permute the pseselected columns to the left and deselected +* columns to the right of the matrix A. +* 1) Order of preselected columns is preserved. +* 2) Order of free columns is not preserved. +* 3) Order of deselected columns is not preserved. +* ================================================================== +* +* J is the index of SEL_DESEL_COLS array and column J +* of the matrix A. +* +* Column selection. +* NSEL is the number of selected columns, also the pointer to the last +* selected column. +* + NSEL = 0 + IF( USE_SEL_DESEL_COLS ) THEN +* + DO J = 1, N, 1 +* +* Initialize column pivot array JPIV. + JPIV( J ) = J +* + IF( SEL_DESEL_COLS(J).EQ.1 ) THEN + NSEL = NSEL + 1 +* +* This is the check whether the selected column is +* on the selected place already. +* + IF( J.NE.NSEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,NSEL) +* + CALL DSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) + JPIV( J ) = JPIV( NSEL ) + JPIV( NSEL ) = J + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) + SEL_DESEL_COLS( NSEL ) = 1 + END IF + END IF + END DO +* +* Column deselection. +* + JDESEL = N+1 + DO J = N, NSEL+1, -1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN + JDESEL = JDESEL - 1 +* +* This is the check whether the deselected column is +* on the deselected place already. +* + IF( J.NE.JDESEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) +* + CALL DSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) + ITEMP = JPIV( J ) + JPIV( J ) = JPIV( JDESEL ) + JPIV( JDESEL ) = ITEMP + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) + SEL_DESEL_COLS( JDESEL ) = -1 + END IF + END IF + END DO +* + NSUB = JDESEL - 1 +* + ELSE +* +* We do not column selection deselection SEL_DESEL_COLS array. +* Initialize column pivot array JPIV. +* + DO J = 1, N, 1 + JPIV( J ) = J + END DO +* + NSUB = N + END IF +* +* ================================================================== +* Compute the complete column 2-norms of the submatrix +* A_sub=A(1:MSUB, 1:NSUB) and store them in WORK(NSUB+1:2*NSUB). +* + DO J = 1, NSUB + WORK( NSUB+J ) = DNRM2( MSUB, A( 1, J ), 1 ) + END DO +* +* Compute the column index and the maximum column 2-norm +* for the submatrix A_sub=A(1:MSUB, 1:NSUB). +* + KP0 = IDAMAX( NSUB, WORK( NSUB+1 ), 1 ) + MAXC2NRM = WORK( NSUB + KP0 ) +* +* ================================================================== +* Process preselected columns +* +* Compute the QR factorization of NSEL preselected columns (1:NSEL) +* the submatrix A_sub=(1:MSUB, 1:NSUB) and update +* remaining NFEE free columns (NSEL+1:NSUB). +* MSUB = MFREE, NSUB = MSEL + NFREE +* + MNSUB = MIN(MSUB, NSUB) + MRESID = MSUB-NSEL + NRESID = NSUB-NSEL + IF( NSEL.GT.0 ) THEN + IF( MSUB.LT.NSEL ) THEN +* TODO: Move this part to the top of the routine. +* a) Case MSUB < NSEL. +* When the number of preselected columns +* is larger than MSUB, hence the factorization of all NSEL +* columns cannot be completed. Return from the routine with the +* error of COL_SEL_DESEL parameter. NSEL cannot be larger than +* MSUB. +* + INFO = -6 + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + ELSE IF( MSUB.EQ.NSEL.OR. + $ ( MSUB.GT.NSEL.AND.NSEL.EQ.NSUB )) THEN +* +* b) Case MSUB = NSEL. +* c-1) Case MSUB > NSEL and NSEL = NSUB. +* +* There will be no residual submatrix after factorization +* of NSEL columns at step K = NSEL: +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). +* Therefore, ther is no need to do the factorization of NSEL +* columns. Set norms to ZERO and return from the routine. +* + K = NSEL + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO +* + DO J = K + 1, MNSUB + TAU( J ) = ZERO + END DO +* +* Factorization is done. Go to computation of the factor C. +* + GO TO 10 + ELSE +* +* (c-2) Case MSUB > NSEL and NSEL < NSUB. +* +* There is a submatrix residual at step K=NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) +* +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL DORMQR( 'Left', 'Transpose', MSUB, NSUB-NSEL, NSEL, + $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, LWORK, IINFO ) +* +* Compute the complete column 2-norms of the submatrix +* residual at step NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) and +* store them in WORK(NSUB+NSEL+1:2*NSUB). +* + DO J = NSEL+1, NSUB + WORK( NSUB+J ) = DNRM2( MRESID, A( NSEL+1, J ), 1 ) + END DO +* +* Compute the column index and the maximum column 2-norm +* and the relative maximum column 2-norm for the submatrix +* residual. +* + KP = IDAMAX( NRESID, WORK( NSUB+NSEL+1 ), 1 ) +* + K = NSEL + MAXC2NRMK = WORK( NSUB + NSEL + KP ) + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* +* Test for the first, second and third tolerance stopping +* criteria after factorizarion of preselected columns. +* If any of them is met, return. Otherwise, +* proceed with factorization of the NFREE free columns. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* + IF( KMAXFREE.EQ.0 + $ .OR. MAXC2NRMK.LE.ABSTOL + $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* NOTE: In this (c-2) case. There is a submatrix +* residual A_sub_resid(NSEL). We do not need to have a check +* for MIN(MRESID, NRESID) = 0 to call DLANGE. +* + FNRMK = DLANGE( 'F', MRESID, NRESID, A(NSEL+1,NSEL+1), + $ LDA, WORK ) +* + DO J = K + 1, MNSUB + TAU( J ) = ZERO + END DO +* +* Factorization is done. Go to computation of the factor C. +* + GO TO 10 + END IF +* +* +* + END IF + END IF +* +* ================================================================== +* +* Factorize NFREE free columns of +* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), +* KFREE is the number of columns that were actually factorized among +* NFREE columns. +* +* Disable RELTOLFREE when calling DGEQP3RK for free columns +* factorization, since it expects RELTOLFREE with respect to +* the residual matrix A_sub_resid(NSEL), not the whole original +* marix A. We can use RELTOL criterion by passing it to +* ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that +* the negative values of ABSTOL and RELTOL are propagated +* to ABSTOLFREE and RELTOLFREE, since negative vaslues means +* that the criterionis is disabled. +* + IF( USETOL ) THEN + ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) + ELSE + ABSTOLFREE = MINUSONE + END IF + RELTOLFREE = MINUSONE + NRHS = 0 +* + CALL DGEQP3RK( MRESID, NRESID, NRHS, KMAXFREE, + $ ABSTOLFREE, RELTOLFREE, + $ A( K+1, K+1 ), LDA, KFREE, MAXC2NRMK, + $ RELMAXC2NRMKFREE, JPIV( K+1 ), TAU( K+1 ), + $ WORK, LWORK, IWORK, IINFO ) +* +* 1) Adjust the return value for the number of factorized +* columns K for the whole submatrix A_sub. +* 2) MAXC2NRMK is returned transparently without change +* as it is returned from DGEQP3RK. +* 3) Adjust the return value RELMAXC2NRMK for the whole +* submatrix A_sub. We do not use RELMAXC2NRMKFREE +* returned from DGEQP3RK. +* + K = K + KFREE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* +* Now, MRESID and NRESID is the number of rows and columns +* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). +* + MRESID = MRESID-KFREE + NRESID = NRESID-KFREE + IF( MIN( MRESID, NRESID ).NE.0 ) THEN + FNRMK = DLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), + $ LDA, WORK ) + ELSE + FNRMK = ZERO + END IF +* +* Compute the factor C. +* + 10 CONTINUE +* + IF( RETURNC .AND. K.GT.0 ) THEN +* +* Apply interchanges to columns 1:K in the matrix C in place, +* which stores the original matrix A. +* IWORK is used to keep track of original column indices, +* when swaping. + + DO J = 1, N, 1 + IWORK( J ) = J + END DO + DO J = 1, K, 1 + JP = JPIV( J ) + IF( J.NE.JP ) THEN + DO JJ = J, N, 1 + IF( JP.EQ.IWORK( JJ ) ) THEN + JPW = JJ + END IF + END DO + IF( J.NE.JPW ) THEN + CALL DSWAP( M, C( 1, J ), 1, C( 1, JPW ), 1 ) + ITEMP = IWORK( J ) + IWORK( J ) = IWORK( JPW ) + IWORK( JPW ) = ITEMP + END IF + END IF + END DO +* + END IF +* +* Return matrix X. +* + IF( RETURNX .AND. K.GT.0 ) THEN +* +* We need to use C and A to compute X = pseudoinv(C) * A, as +* the Linear Least Squares problem C*X = A. We use LLS routine +* that uses QR factorization. For that purpose, we store C into +* WORK array WORK(1:M*K), and the matrix A was copied into +* the array X at the begining of the routine. +* +* Copy matrix C into work array WORK. +* + CALL DLACPY( 'F', M, K, C, LDC, WORK, M ) +* + CALL DGELS( 'N', M, K, N, WORK, M, X, LDX, + $ WORK( M*K+1 ), LWORK, + $ IINFO ) + INFO = IINFO +* + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* DGECX +* + END \ No newline at end of file From b36b9b76eb201a5dbbb0daa14ed29b96ed18418e Mon Sep 17 00:00:00 2001 From: Igor Date: Thu, 16 Oct 2025 07:00:56 -0700 Subject: [PATCH 03/63] Fix documentation for ABSTOL and factor flags changed the description of DGECX --- SRC/dgecx.f | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/SRC/dgecx.f b/SRC/dgecx.f index 8bcb1ee4f..b343f8c3c 100644 --- a/SRC/dgecx.f +++ b/SRC/dgecx.f @@ -74,7 +74,7 @@ *> *> 2) The input parameter ABSTOL, the absolute tolerance for *> the maximum column 2-norm of the submatrix residual -*> A_sub_resid = A(K+1:M_sub, K+1:N_sub). +*> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub). *> This means that the factorization stops if this norm is less *> or equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. *> @@ -122,11 +122,11 @@ *> ================================== *> *> When the columns are selected for the factor C, and: -*> a) If the flag RET_C is set, then the routine explicitly returns +*> a) If the flag FACT='C' or 'X', then the routine explicitly returns *> the matrix C, otherwise the routine returns only the indices of *> the selected columns from the original matrix A stored in the JPIV *> array as the first K elements. -*> b) If the flag COMP_X is set, then the routine also explicitly +*> b) If the flag FACT='X', then the routine also explicitly *> computes and returns the factor X = pseudoinv(C) * A. *> *> \endverbatim @@ -1170,4 +1170,4 @@ SUBROUTINE DGECX( FACT, USESD, M, N, * * DGECX * - END \ No newline at end of file + END From de15bcca598274e9f2a615e47c3e9f5e4d8b94c9 Mon Sep 17 00:00:00 2001 From: Igor Date: Tue, 11 Nov 2025 23:23:52 -0800 Subject: [PATCH 04/63] Delete SRC/DGECX.f --- SRC/DGECX.f | 1173 --------------------------------------------------- 1 file changed, 1173 deletions(-) delete mode 100644 SRC/DGECX.f diff --git a/SRC/DGECX.f b/SRC/DGECX.f deleted file mode 100644 index 8bcb1ee4f..000000000 --- a/SRC/DGECX.f +++ /dev/null @@ -1,1173 +0,0 @@ -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGECX computes a CX factorization of a real M-by-N matrix A: -*> -*> A * P(K) = C*X + A_resid, where -*> -*> C is an M-by-K matrix which is a subset of K columns selected -*> from the original matrix A, -*> -*> X is a K-by-N matrix that minimizes the Frobenius norm of the -*> residual matrix A_resid, X = pseudoinv(C) * A, -*> -*> P(K) is an N-by-N permutation matrix chosen so that the first -*> K columns of A*P(K) equal C, -*> -*> A_resid is an M-by-N residual matrix. -*> -*> The column selection for the matrix C has two stages. -*> -*> Column selection stage 1. -*> ========================= -*> -*> The user can select N_sel columns and deselect N_desel columns -*> of the matrix A that MUST be included and excluded respectively -*> from the matrix C a priori, before running the column selection -*> algorithm. This is controlled by the flags in the array -*> SEL_DESEL_COLS. The deselected columns are permuted to the right -*> side of the array A and selected columns are permuted to the left -*> side of the array A. The details of the column permutation -*> (i.e. the column permutation matrix P(K)) are stored in the -*> array JPIV. This feature can be used when the goal is to approximate -*> the deselected columns by linear combinations of K selected columns, -*> where the K columns MUST include the N_sel selected columns. -*> -*> Column selection stage 2. -*> ========================= -*> -*> The routine runs the column selection algorithm that can -*> be controlled with three stopping criteria described below. -*> For the column selection, the routine uses a truncated (rank K) in -*> Householder QR factorization with column pivoting algorithm -*> DGEQP3RK routine. Note, that before running the column selection -*> algorithm, the user can deselect M_desel rows of the matrix A that -*> should NOT be considered by the column selection algorithm (i.e. -*> during the factorization). This is controlled by the flags in -*> the array DESEL_ROWS. The deselected rows are permuted to the -*> bottom of the array A. The details of the row permutation (i.e. the -*> row permutation matrix) are stored in the array IPIV. This feature -*> can be used when the goal is to use the deselected rows as test data, -*> and the selected rows as training data. -*> -*> This means that the column selection factorization algorithm is -*> effectively running on the submatrix A_sub=A(1:M_sub,1:N_sub) of -*> the matrix A after the permutations described above. Here M_sub is -*> the number of rows of the matrix A minus the number of deselected -*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number -*> of columns of the matrix A minus the number of deselected columns -*> N_desel, i.e. N_sub = N - N_desel. -*> -*> Column selection criteria. -*> ========================== -*> -*> The column selection criteria (i.e. when to stop the factorization) -*> can be any of the following: -*> -*> 1) The input parameter KMAXFREE, the maximum number of columns -*> to factorize outside of the N_sel preselected columns, -*> i.e. the factorization rank is limited to N_sel + KMAXFREE. -*> If N_sel + KMAXFREE >= min(M_sub, N_sub), the criterion -*> is not used. -*> -*> 2) The input parameter ABSTOL, the absolute tolerance for -*> the maximum column 2-norm of the submatrix residual -*> A_sub_resid = A(K+1:M_sub, K+1:N_sub). -*> This means that the factorization stops if this norm is less -*> or equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. -*> -*> 3) The input parameter RELTOL, the tolerance for the maximum -*> column 2-norm matrix of the submatrix residual -*> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub) divided -*> by the maximum column 2-norm of the submatrix -*> A_sub = A(1:M_sub, 1:N_sub). -*> This means that the factorization stops when the ratio of the -*> maximum column 2-norm of A_sub_resid to the maximum column -*> 2-norm of A_sub is less than or equal to RELTOL. -*> If RELTOL < 0.0, the criterion is not used. -*> -*> The algorithm stops when any of these conditions is first -*> satisfied, otherwise the whole submatrix A_sub is factorized. -*> -*> For a full rank factorization of the matrix A_sub, use selection -*> criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) and -*> ABSTOL < 0.0 and RELTOL < 0.0. -*> -*> If the user wants to verify whether the columns of the matrix C are -*> sufficiently linearly independent for their intended use, the user -*> can compute the condition number of its R factor by calling DTRCON -*> on the upper-triangular part of A(1:K,1:K) of the output array A. -*> -*> How N_sel affects the column selection algorithm. -*> ================================================= -*> -*> As mentioned above, the N_sel selected columns are permuted to the -*> right side of the array A, and will be included in the column -*> selection. Then the routine runs the factorization of that block -*> A(1:M_sub,1:N_sel), and if any of the three stopping criteria is met -*> immediately after factoring the first N_sel columns the routine exits -*> (i.e. there is no requirement to select extra columns, -*> if the absolute or relative tolerance of the maximum column 2-norm of -*> the residual is satisfied). In this case, the number -*> of selected columns would be K = N_sel. Otherwise, the factorization -*> routine finds a new column to select with the maximum column 2-norm -*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and permutes that -*> column to the right side of A(1:M,N_sel+1:N_sub). Then the routine -*> checks if the stopping criteria are met in the next residual -*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. -*> -*> Computation of the matrix factors. -*> ================================== -*> -*> When the columns are selected for the factor C, and: -*> a) If the flag RET_C is set, then the routine explicitly returns -*> the matrix C, otherwise the routine returns only the indices of -*> the selected columns from the original matrix A stored in the JPIV -*> array as the first K elements. -*> b) If the flag COMP_X is set, then the routine also explicitly -*> computes and returns the factor X = pseudoinv(C) * A. -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] FACT -*> \verbatim -*> FACT is CHARACTER*1 -*> Specifies how the factors of CX factorization -*> are returned. -*> -*> = 'P' or 'p' : return only the column permutaion matrix P -*> in the array JPIV. The first K elements -*> of the array JPIV contain indeces of -*> the factor C colums that were selected -*> from the matrix A. -*> (fastest, smallest memory space) -*> -*> = 'C' or 'c' : return the column permutaion matrix P -*> in the array JPIV and the factor C -*> explicitly in the array C -*> (slower, more memory space) -*> -*> = 'X' or 'x' : return the column permutaion matrix P -*> in the array JPIV, and both factors -*> C and X exlplicitly in the arrays -*> C and X respectively. -*> (slowest, largest memory space) -*> \endverbatim -*> -*> \param[in] USESD -*> \verbatim -*> USESD is CHARACTER*1 -*> Specifies if row deselection and column -*> preselection-deselection functionality is turned ON or OFF. -*> -*> = 'N' or 'n' : Both row deselection and column -*> preselection-deselection are OFF. -*> Both arrays DESEL_ROWS and -*> SEL_DESEL_COLS are not used. -*> -*> = 'R' or 'r' : Only row deselection is ON. -*> Column preselection-deselection is OFF. -*> The array SEL_DESEL_COLS is not used. -*> -*> = 'C' or 'c' : Only column preselection-deselection is ON. -*> Row deselection is OFF. -*> The array DESEL_ROWS is not used. -*> -*> = 'A' or 'a' : Means "All". -*> Both row deselection and column -*> preselection-deselection are ON. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] DESEL_ROWS -*> \verbatim -*> DESEL_ROWS is INTEGER array, dimension (M) -*> This is a row deselection mask array that separates -*. the matrix A rows into 2 sets. -*> -*> a) If DESEL_ROWS(I) = -1, the I-th row of the matrix A is -*> deselected by the user, i.e. chosen to be excluded from -*. the algorithm and will be permuted to the bottom of A. -*> The number of deselected rows is denoted by M_desel. -*> -*> b) If DESEL_ROWS(I) not equal -1, -*> the I-th row of A is a free row and will be used by the -*> algorithm. This defines a set of M_sub = M - M_desel -*> rows that the algorithm will work on. After permutation, -*> this set will be in the top of the matrix A. -*> \endverbatim -*> -*> \param[in] SEL_DESEL_COLS -*> \verbatim -*> SEL_DESEL_COLS is INTEGER array, dimension (N) -*> This is a column preselection/deselection mask array that -*. separates the matrix A columns into 3 sets. -*> -*> a) If SEL_DESEL_COLS(J) = +1, the J-th column of the matrix -*> A is selected by the user to be included in the factor C -*> and will be permuted to the left side of the array A. -*> The number of selected columns is denoted by N_sel. -*> -*> b) If SEL_DESEL_COLS(J) = -1, the J-th column of the matrix -*> A is deselected by the user, i.e. chosen to be excluded -*> from the factor C and will be permuted to the right side -*> of the array A. The number of deselected columns is -*> denoted by N_desel. -*> -*> c) If SEL_DESEL_COLS(J) not equal 1, and not equal -1, -*> the J-th column of A is a free column and will be used by -*> the algorithm to determine if this column has to be -*> selected. This defines a set of -*> N_free = N - N_sel - N_desel. -*> -*> NOTE: Error returned as INFO = -6 means that the number of -*> preselected N_sel colunms is larger than M_sub. -*> Therefore, the factoriaztion of all N_sel preselected -*> columns cannot be completed. -*> \endverbatim -*> -*> \param[in] KMAXFREE -*> \verbatim -*> KMAXFREE is INTEGER -*> -*> The first column selection stopping criterion in the -*> column selection stage 2. -*> -*> The maximum number of columns of the matrix A_sub to select -*> during the factorization stage, KMAXFREE >= 0 -*> -*> KMAXFREE does not include the preselected columns. -*> N_sel + KMAXFREE is the maximum factorization rank of -*> the matrix A_sub = A(1:M_sub, 1:N_sub). -*> -*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this -*> stopping criterion is not used, i.e. columns are selected -*> in the factorization stage depending on -*> ABSTOL and RELTOL. -*> -*> b) If KMAXFREE = 0, then this stopping criterion is -*> satisfied on input and the routine exits without -*> performing column selection stage 2 on the submatrix -*> A_sub. This means that the matrix -*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified. -*> and A_free is itself the residual for the factorization. -*> \endverbatim -*> -*> \param[in] ABSTOL -*> \verbatim -*> ABSTOL is DOUBLE PRECISION, cannot be NaN. -*> -*> The second column selection stopping criterion in the -*> column selection stage 2. -*> -*> Here, SAFMIN = DLAMCH('S'). -*> -*> The absolute tolerance (stopping threshold) for -*> maximum column 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), -*> when K columns were factorized. -*> The algorithm converges (stops the factorization) when -*> the maximum column 2-norm of the residual matrix -*> A_sub_resid is less than or equal to ABSTOL. -*> -*> a) If ABSTOL is NaN, then no computation is performed -*> and an error message ( INFO = -8 ) is issued -*> by XERBLA. -*> -*> b) If ABSTOL < 0.0, then this stopping criterion is not -*> used, factorize columns depending on KMAXFREE -*> and RELTOL. -*> This includes the case ABSTOL = -Inf. -*> -*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN -*> is used. This includes the case ABSTOL = -0.0. -*> -*> d) If 2*SAFMIN <= ABSTOL then the input value -*> of ABSTOL is used. -*> -*> Here, maxcol2norm(A_free) is the maximum column 2-norm -*> of the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). -*> -*> If ABSTOL chosen above is >= maxcol2norm(A_free), then -*> this stopping criterion is satisfied after the matrix -*> A_sel = A(1:M_sub, 1:N_sel) is factorized and the -*> routine exits immediately after maxcol2norm(A_free) is -*> computed to return it in MAXC2NORMK. This means that -*> the factorization residual -*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) -*> is not modified. -*> Also RELMAXC2NORMK of A_free is returned. -*> This includes the case ABSTOL = +Inf. -*> \endverbatim -*> -*> \param[in] RELTOL -*> \verbatim -*> RELTOL is DOUBLE PRECISION, cannot be NaN. -*> -*> The third column selection stopping criterion in the -*> column selection stage 2. -*> -*> Here, EPS = DLAMCH('E'). -*> -*> The tolerance (stopping threshold) for the ratio -*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) of -*> the maximum column 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) and -*> the maximum column 2-norm of the original submatrix -*> A_sub = A(1:M_sub, 1:N_sub). The algorithm -*> converges (stops the factorization), when -*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) is -*> less than or equal to RELTOL. -*> -*> a) If RELTOL is NaN, then no computation is performed -*> and an error message ( INFO = -9 ) is issued -*> by XERBLA. -*> -*> b) If RELTOL < 0.0, then this stopping criterion is not -*> used, factorize columns depending on KMAXFREE -*> and ABSTOL. -*> This includes the case RELTOL = -Inf. -*> -*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. -*> This includes the case RELTOL = -0.0. -*> -*> d) If EPS <= RELTOL then the input value of RELTOL -*> is used. -*> -*> If RELTOL chosen above is >= 1.0, then this stopping -*> criterion is satisfied on input and routine exits -*> immediately after A_sel = A(1:M_sub, 1:N_sel)) -*> is factorized and maxcol2norm(A_free) is computed to -*> return it in MAXC2NORMK. This means that -*> the factorization residual -*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) -*> is not modified. -*> Also RELMAXC2NORMK is returned as 1.0. -*> This includes the case RELTOL = +Inf. -*> -*> NOTE: We recommend RELTOL to satisfy -*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL -*> -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> -*> On entry: -*> the M-by-N matrix A. -*> -*> On exit: -*> NOTE DEFINITIONS: M_sub = M_free, -*> N_sub = N_sel + N_free -*> -*> The output parameter K, the number of selected columns, -*> is described later. -*> -*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. -*> -*> 2) If K > 0, A(1:M,1:N): contains the following parts: -*> -*> (a) If M_sub < M (which is the same as M_desel > 0), -*> the subarray A(M_sub+1:M,1:N) contains the deselected -*> rows. -*> -*> (b) If N_sub < N ( which is the same as N_desel > 1 ). -*> the subarray A(1:M,N_sub+1:N) contains the -*> deselected columns. -*> -*> (c) If N_sel > 0, -*> the union of the subarray A(1:M_sub, 1:N_sel) -*> and the subarray A(1:N_sel, 1:N_sub) contains parts -*> of the factors obtained by computing Householder QR -*> factorization WITHOUT column pivoting of N_sel -*> preselected columns using DGEQRF routine. -*> -*> (d) The subarray A(N_sel:M_sub, N_sel:N_sub) contains -*> parts of the factors obtained by computing a truncated -*> (rank K) Householder QR factorization with -*> column pivoting using DGEQP3RK on the matrix -*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) which -*> is the result of applying selection and deselection -*> of columns, applying deselection of rows to the -*> original matrix A, and applying orthogonal -*> transformation from the factorization of the first -*> N_sel columns as described in part (c). -*> -*> 1. The elements below the diagonal of the subarray -*> A_sub(1:M_sub,1:K) together with TAU(1:K) -*> represent the orthogonal matrix Q(K) as a -*> product of K Householder elementary reflectors. -*> -*> 2. The elements on and above the diagonal of -*> the subarray A_sub(1:K,1:N_sub) contain -*> K-by-N_sub upper-trapezoidal matrix -*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). -*> NOTE: If K=min(M_sub,N_sub), i.e. full rank -*> factorization, then R_sub_approx(K) is the -*> full factor R which is upper-trapezoidal. -*> If, in addition, M_sub>=N_sub, then R is -*> upper-triangular. -*> -*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains -*> (M_sub-K)-by-(N_sub-K) rectangular matrix -*> A_sub_resid(K). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] K -*> \verbatim -*> K is INTEGER -*> The number of columns that were selected. -*> (K is the factorization rank) -*> 0 <= K <= min( M_sub, min(N_sel+KMAXFREE, N_sub) ). -*> -*> If K = 0, the arrays A, TAU were not modified. -*> \endverbatim -*> -*> \param[out] MAXC2NRMK -*> \verbatim -*> MAXC2NRMK is DOUBLE PRECISION -*> The maximum column 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), -*> when factorization stopped at rank K. MAXC2NRMK >= 0. -*> -*> a) If K = 0, i.e. the factorization was not performed, -*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified -*> and is itself a residual matrix, then MAXC2NRMK equals -*> the maximum column 2-norm of the original matrix A_sub. -*> -*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. -*> -*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was -*> factorized and there is no factorization residual matrix, -*> then MAXC2NRMK = 0.0. -*> -*> NOTE: MAXC2NRMK at the factorization step K would equal -*> to the diagonal element R_sub(K+1,K+1) of the factor -*> R_sub in the next factorization step K+1. -*> \endverbatim -*> -*> \param[out] RELMAXC2NRMK -*> \verbatim -*> RELMAXC2NRMK is DOUBLE PRECISION -*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column -*> 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when -*> factorization stopped at rank K) and maximum column 2-norm -*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). -*> RELMAXC2NRMK >= 0. -*> -*> a) If K = 0, i.e. the factorization was not performed, -*> the matrix A_sub was not modified -*> and is itself a residual matrix, -*> then RELMAXC2NRMK = 1.0. -*> -*> b) If 0 < K < min(M_sub,N_sub), then -*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. -*> -*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was -*> factorized and there is no residual matrix -*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. -*> -*> NOTE: RELMAXC2NRMK at the factorization step K would equal -*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next -*> factorization step K+1, where R_sub(K+1,K+1) is the -*> diaginal element of the factor R_sub in the next -*> factorization step K+1. -*> \endverbatim -*> -*> \param[out] FNRMK -*> \verbatim -*> FNRMK is DOUBLE PRECISION -*> Frobenius norm of the factorization residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). -*> FNRMK >= 0.0 -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (M) -*> Row permutation indices due to row -*> deselection, for 1 <= i <= M. -*> If IPIV(i)= k, then the row i of A_sub was the -*> the row k of A. -*> \endverbatim -*> -*> \param[out] JPIV -*> \verbatim -*> JPIV is INTEGER array, dimension (N) -*> Column permutation indices, for 1 <= j <= N. -*> If JPIV(j)= k, then the column j of A*P was the -*> the column k of A. -*> -*> The first K elements of the array JPIV contain -*> indeces of the factor C colums that were selected -*> from the matrix A. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors. -*> -*> If 0 < K <= MIN(M_sub,N_sub), only elements TAU(1:K) of -*> the array TAU may be modified. The elements -*> TAU(K+1:min(M_sub,N_sub)) are set to zero. -*> The elements of TAU(min(M_sub,N_sub)+1:N) are not -*> modified. -*> \endverbatim -*> -*> \param[out] C -*> \verbatim -*> C is DOUBLE PRECISION array. -*> If FACT = 'C' or 'X': -*> If K > 0, C is the M-by-K factor C -*> and array has dimension (LDC,N), -*> If FACT = 'N': -*> array is not used and can have linear dimension >=1. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. -*> If FACT = 'C' or 'X', LDC >= max(1,M). -*> If FACT = 'P', LDC >= 1. -*> \endverbatim -*> -*> \param[out] X -*> \verbatim -*> X is DOUBLE PRECISION array. -*> If FACT = 'X': -*> If K > 0, C is the K-by-N factor X -*> and array has dimension (LDX,N). -*> If FACT = 'P': -*> array is not used and can have linear dimension >=1. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. -*> If FACT = 'X', LDC >= max(1,M). -*> If FACT = 'P', LDC >= 1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO>=0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= 3*N_sub+1. -*> For optimal performance LWORK >= 2*N_sub+( N_sub+1 )*NB, -*> where NB is the optimal blocksize. -*> -*> 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. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (N). -*> Is a work array. ( IWORK is used by DGEQP3RK to store indices -*> of "bad" columns for norm downdating in the residual -*> matrix in the blocked step auxiliary subroutine DLAQP3RK ). -*> \endverbatim -*> -*> \param[out] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array LIWORK. LIWORK >= N -*> -*> If LIWORK = -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 IWORK array, and no error -*> message related to LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if INFO = i, the i-th diagonal element of the -*> triangular factor of in the matrix C is zero, -*> so that C does not have full rank; X cannot be -*> computed as the least squares solution to C*X = A. -*> \endverbatim -* ===================================================================== - SUBROUTINE DGECX( FACT, USESD, M, N, - $ DESEL_ROWS, SEL_DESEL_COLS, - $ KMAXFREE, ABSTOL, RELTOL, A, LDA, - $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, - $ IPIV, JPIV, TAU, C, LDC, X, LDX, - $ WORK, LWORK, IWORK, LIWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER FACT, USESD - INTEGER INFO, K, KMAXFREE, LDA, LDC, LDX, LIWORK, - $ LWORK, M, N - DOUBLE PRECISION ABSTOL, ABSTOLFREE, MAXC2NRMK, RELTOL, - $ RELTOLFREE, RELMAXC2NRMK, FNRMK -* .. -* .. Array Arguments .. - INTEGER DESEL_ROWS( * ), IPIV( * ), JPIV( * ), - $ SEL_DESEL_COLS( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ X( LDX, *), WORK( * ) -* ===================================================================== -* -* .. Parameters .. - INTEGER INB - PARAMETER ( INB = 1 ) - DOUBLE PRECISION ZERO, TWO, MINUSONE - PARAMETER ( ZERO = 0.0D+0, TWO = 2.0D+0, - $ MINUSONE = -1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LIQUERY, LQUERY, RETURNC, RETURNX, - $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL - INTEGER I, J, NSUB, MFREE, MSUB, MNSUB, NSEL, JDESEL, - $ ITEMP, IINFO, KP, KP0, KFREE, MRESID, NRESID, - $ NRHS, LWKMIN, LWKOPT, JP, JJ, JPW, MINMN, - $ NBOPT - DOUBLE PRECISION EPS, MAXC2NRM, SAFMIN, RELMAXC2NRMKFREE - -* .. External Subroutines .. - EXTERNAL DLACPY, DGELS, DGEQP3RK, DGEQRF, DORMQR, - $ DSWAP, XERBLA -* .. -* .. External Functions .. - LOGICAL DISNAN, LSAME - INTEGER IDAMAX, ILAENV - DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 - EXTERNAL DISNAN, DLAMCH, DLANGE, DNRM2, IDAMAX, - $ ILAENV, LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - LIQUERY = ( LIWORK.EQ.-1 ) -* - RETURNX = LSAME( FACT, 'X' ) - RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX -* - USE_DESEL_ROWS = LSAME( USESD, 'R' ) .OR. LSAME( USESD, 'A' ) - USE_SEL_DESEL_COLS = LSAME( USESD, 'C') .OR. LSAME( USESD, 'A' ) -* - IF ( .NOT.(RETURNC .OR. LSAME( FACT, 'P') ) ) THEN - INFO = -1 - ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS - $ .OR. LSAME( USESD, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( KMAXFREE.LT.0 ) THEN - INFO = -7 - ELSE IF( DISNAN( ABSTOL ) ) THEN - INFO = -8 - ELSE IF( DISNAN( RELTOL ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.RETURNC .AND. LDC.LT.1 )) THEN - INFO = -20 - ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.RETURNX .AND. LDX.LT.1 )) THEN - INFO = -22 - END IF -* -* If the above input parameters are valid: -* a) Test the input workspace size LWORK for the minimum -* size requirement LWKMIN. -* b) Determine the optimal block size NB and optimal -* workspace size LWKOPT to be returned in WORK(1) -* in case of: (1) LWORK < LWKMIN, (2) LQUERY = .TRUE., -* (3) when routine exits. -* Here, LWKMIN is the miminum workspace required for unblocked -* code. -* - IF( INFO.EQ.0 ) THEN - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - LWKMIN = 1 - LWKOPT = 1 - ELSE - LWKMIN = 3*N + 1 -* -* Assign to NBOPT optimal block size. -* - NBOPT = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = 1000 - END IF - WORK( 1 ) = DBLE( LWKOPT ) -* - IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN - INFO = -24 - END IF - END IF -* -* ================================================================== -* - K = 0 -* - EPS = DLAMCH('Epsilon') -* - USETOL = .FALSE. -* -* Adjust ABSTOL only if nonnegative. Negative value means disabled. -* We need to keep negtive value for later use in criterion -* check. -* - IF( ABSTOL.GE.ZERO ) THEN - SAFMIN = DLAMCH('Safe minimum') - ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) - USETOL = .TRUE. - END IF -* -* Ajust RELTOL only if nonnegative. Negative value means disabled. -* We need to keep negtive value for later use in criterion -* check. -* - IF( RELTOL.GE.ZERO ) THEN - RELTOL = MAX( RELTOL, EPS ) - USETOL = .TRUE. - END IF -* -* ================================================================== -* -* If we need to return factor C, copy the original unctouched matrix -* A into the array C. -* - IF( RETURNC ) THEN - CALL DLACPY( 'F', M, N, A, LDA, C, LDC ) - END IF -* -* If we need to return factor X, copy the original unctouched matrix -* A into the array X. -* - IF( RETURNX ) THEN - CALL DLACPY( 'F', M, N, A, LDA, X, LDX ) - END IF -* -* ================================================================== -* Permute the deselected rows to the bottom of the matrix A. -* 1) Order of free rows is preserved. -* 2) Order of deselected rows is not preserved. -* ================================================================== -* -* I is the index of DESEL_ROWS array and row I -* of the matrix A. -* MFREE is the number of free rows, also the pointer to the last -* free row. -* (For each position I, we check if this position is a FREE row. -* If it is a FREE row we increment the MFREE pointer, otherwise we -* do not change the MFREE pointer. Also, if it is a FREE row, we move -* this row from the larger (or same) I index into samaller (or same) -* MFREE index. This way we move all the FREE rows to the lower index -* block preserving FREE row order. Deselected rows will be ) -* - IF( USE_DESEL_ROWS ) THEN -* - MFREE = 0 - DO I = 1, M, 1 -* -* Initialize row pivot array IPIV. - IPIV( I ) = I -* - IF( DESEL_ROWS(I).NE.-1 ) THEN - MFREE = MFREE + 1 -* -* This is the check whether the deselected row is -* on the deselected place already. -* - IF( I.NE.MFREE ) THEN -* -* Here, we swap A(I,1:N) into A(MFREE,1:N) -* - CALL DSWAP( N, A( I, 1 ), LDA, A( MFREE, 1 ), LDA ) - IPIV( I ) = IPIV( MFREE ) - IPIV( MFREE ) = I - ITEMP = DESEL_ROWS( I ) - DESEL_ROWS( I ) = DESEL_ROWS( MFREE ) - DESEL_ROWS( MFREE ) = ITEMP - END IF - END IF -* - END DO -* - ELSE -* -* We do not row deselection DESEL_ROWS array. -* Initialize row pivot array IPIV. -* - DO I = 1, M, 1 - IPIV( I ) = I - END DO -* - MFREE = M - END IF - MSUB = M -* -* ================================================================== -* Permute the pseselected columns to the left and deselected -* columns to the right of the matrix A. -* 1) Order of preselected columns is preserved. -* 2) Order of free columns is not preserved. -* 3) Order of deselected columns is not preserved. -* ================================================================== -* -* J is the index of SEL_DESEL_COLS array and column J -* of the matrix A. -* -* Column selection. -* NSEL is the number of selected columns, also the pointer to the last -* selected column. -* - NSEL = 0 - IF( USE_SEL_DESEL_COLS ) THEN -* - DO J = 1, N, 1 -* -* Initialize column pivot array JPIV. - JPIV( J ) = J -* - IF( SEL_DESEL_COLS(J).EQ.1 ) THEN - NSEL = NSEL + 1 -* -* This is the check whether the selected column is -* on the selected place already. -* - IF( J.NE.NSEL ) THEN -* -* Here, we swap the column A(1:M,J) into A(1:M,NSEL) -* - CALL DSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) - JPIV( J ) = JPIV( NSEL ) - JPIV( NSEL ) = J - SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) - SEL_DESEL_COLS( NSEL ) = 1 - END IF - END IF - END DO -* -* Column deselection. -* - JDESEL = N+1 - DO J = N, NSEL+1, -1 - IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN - JDESEL = JDESEL - 1 -* -* This is the check whether the deselected column is -* on the deselected place already. -* - IF( J.NE.JDESEL ) THEN -* -* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) -* - CALL DSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) - ITEMP = JPIV( J ) - JPIV( J ) = JPIV( JDESEL ) - JPIV( JDESEL ) = ITEMP - SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) - SEL_DESEL_COLS( JDESEL ) = -1 - END IF - END IF - END DO -* - NSUB = JDESEL - 1 -* - ELSE -* -* We do not column selection deselection SEL_DESEL_COLS array. -* Initialize column pivot array JPIV. -* - DO J = 1, N, 1 - JPIV( J ) = J - END DO -* - NSUB = N - END IF -* -* ================================================================== -* Compute the complete column 2-norms of the submatrix -* A_sub=A(1:MSUB, 1:NSUB) and store them in WORK(NSUB+1:2*NSUB). -* - DO J = 1, NSUB - WORK( NSUB+J ) = DNRM2( MSUB, A( 1, J ), 1 ) - END DO -* -* Compute the column index and the maximum column 2-norm -* for the submatrix A_sub=A(1:MSUB, 1:NSUB). -* - KP0 = IDAMAX( NSUB, WORK( NSUB+1 ), 1 ) - MAXC2NRM = WORK( NSUB + KP0 ) -* -* ================================================================== -* Process preselected columns -* -* Compute the QR factorization of NSEL preselected columns (1:NSEL) -* the submatrix A_sub=(1:MSUB, 1:NSUB) and update -* remaining NFEE free columns (NSEL+1:NSUB). -* MSUB = MFREE, NSUB = MSEL + NFREE -* - MNSUB = MIN(MSUB, NSUB) - MRESID = MSUB-NSEL - NRESID = NSUB-NSEL - IF( NSEL.GT.0 ) THEN - IF( MSUB.LT.NSEL ) THEN -* TODO: Move this part to the top of the routine. -* a) Case MSUB < NSEL. -* When the number of preselected columns -* is larger than MSUB, hence the factorization of all NSEL -* columns cannot be completed. Return from the routine with the -* error of COL_SEL_DESEL parameter. NSEL cannot be larger than -* MSUB. -* - INFO = -6 - WORK( 1 ) = DBLE( LWKOPT ) - RETURN - ELSE IF( MSUB.EQ.NSEL.OR. - $ ( MSUB.GT.NSEL.AND.NSEL.EQ.NSUB )) THEN -* -* b) Case MSUB = NSEL. -* c-1) Case MSUB > NSEL and NSEL = NSUB. -* -* There will be no residual submatrix after factorization -* of NSEL columns at step K = NSEL: -* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). -* Therefore, ther is no need to do the factorization of NSEL -* columns. Set norms to ZERO and return from the routine. -* - K = NSEL - MAXC2NRMK = ZERO - RELMAXC2NRMK = ZERO - FNRMK = ZERO -* - DO J = K + 1, MNSUB - TAU( J ) = ZERO - END DO -* -* Factorization is done. Go to computation of the factor C. -* - GO TO 10 - ELSE -* -* (c-2) Case MSUB > NSEL and NSEL < NSUB. -* -* There is a submatrix residual at step K=NSEL -* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) -* - CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) -* -* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) -* - CALL DORMQR( 'Left', 'Transpose', MSUB, NSUB-NSEL, NSEL, - $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, LWORK, IINFO ) -* -* Compute the complete column 2-norms of the submatrix -* residual at step NSEL -* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) and -* store them in WORK(NSUB+NSEL+1:2*NSUB). -* - DO J = NSEL+1, NSUB - WORK( NSUB+J ) = DNRM2( MRESID, A( NSEL+1, J ), 1 ) - END DO -* -* Compute the column index and the maximum column 2-norm -* and the relative maximum column 2-norm for the submatrix -* residual. -* - KP = IDAMAX( NRESID, WORK( NSUB+NSEL+1 ), 1 ) -* - K = NSEL - MAXC2NRMK = WORK( NSUB + NSEL + KP ) - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM -* -* Test for the first, second and third tolerance stopping -* criteria after factorizarion of preselected columns. -* If any of them is met, return. Otherwise, -* proceed with factorization of the NFREE free columns. -* NOTE: There is no need to test for ABSTOL.GE.ZERO, since -* MAXC2NRMK is non-negative. Similarly, there is no need -* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is -* non-negative. -* - IF( KMAXFREE.EQ.0 - $ .OR. MAXC2NRMK.LE.ABSTOL - $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN -* -* NOTE: In this (c-2) case. There is a submatrix -* residual A_sub_resid(NSEL). We do not need to have a check -* for MIN(MRESID, NRESID) = 0 to call DLANGE. -* - FNRMK = DLANGE( 'F', MRESID, NRESID, A(NSEL+1,NSEL+1), - $ LDA, WORK ) -* - DO J = K + 1, MNSUB - TAU( J ) = ZERO - END DO -* -* Factorization is done. Go to computation of the factor C. -* - GO TO 10 - END IF -* -* -* - END IF - END IF -* -* ================================================================== -* -* Factorize NFREE free columns of -* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), -* KFREE is the number of columns that were actually factorized among -* NFREE columns. -* -* Disable RELTOLFREE when calling DGEQP3RK for free columns -* factorization, since it expects RELTOLFREE with respect to -* the residual matrix A_sub_resid(NSEL), not the whole original -* marix A. We can use RELTOL criterion by passing it to -* ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that -* the negative values of ABSTOL and RELTOL are propagated -* to ABSTOLFREE and RELTOLFREE, since negative vaslues means -* that the criterionis is disabled. -* - IF( USETOL ) THEN - ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) - ELSE - ABSTOLFREE = MINUSONE - END IF - RELTOLFREE = MINUSONE - NRHS = 0 -* - CALL DGEQP3RK( MRESID, NRESID, NRHS, KMAXFREE, - $ ABSTOLFREE, RELTOLFREE, - $ A( K+1, K+1 ), LDA, KFREE, MAXC2NRMK, - $ RELMAXC2NRMKFREE, JPIV( K+1 ), TAU( K+1 ), - $ WORK, LWORK, IWORK, IINFO ) -* -* 1) Adjust the return value for the number of factorized -* columns K for the whole submatrix A_sub. -* 2) MAXC2NRMK is returned transparently without change -* as it is returned from DGEQP3RK. -* 3) Adjust the return value RELMAXC2NRMK for the whole -* submatrix A_sub. We do not use RELMAXC2NRMKFREE -* returned from DGEQP3RK. -* - K = K + KFREE - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM -* -* Now, MRESID and NRESID is the number of rows and columns -* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). -* - MRESID = MRESID-KFREE - NRESID = NRESID-KFREE - IF( MIN( MRESID, NRESID ).NE.0 ) THEN - FNRMK = DLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), - $ LDA, WORK ) - ELSE - FNRMK = ZERO - END IF -* -* Compute the factor C. -* - 10 CONTINUE -* - IF( RETURNC .AND. K.GT.0 ) THEN -* -* Apply interchanges to columns 1:K in the matrix C in place, -* which stores the original matrix A. -* IWORK is used to keep track of original column indices, -* when swaping. - - DO J = 1, N, 1 - IWORK( J ) = J - END DO - DO J = 1, K, 1 - JP = JPIV( J ) - IF( J.NE.JP ) THEN - DO JJ = J, N, 1 - IF( JP.EQ.IWORK( JJ ) ) THEN - JPW = JJ - END IF - END DO - IF( J.NE.JPW ) THEN - CALL DSWAP( M, C( 1, J ), 1, C( 1, JPW ), 1 ) - ITEMP = IWORK( J ) - IWORK( J ) = IWORK( JPW ) - IWORK( JPW ) = ITEMP - END IF - END IF - END DO -* - END IF -* -* Return matrix X. -* - IF( RETURNX .AND. K.GT.0 ) THEN -* -* We need to use C and A to compute X = pseudoinv(C) * A, as -* the Linear Least Squares problem C*X = A. We use LLS routine -* that uses QR factorization. For that purpose, we store C into -* WORK array WORK(1:M*K), and the matrix A was copied into -* the array X at the begining of the routine. -* -* Copy matrix C into work array WORK. -* - CALL DLACPY( 'F', M, K, C, LDC, WORK, M ) -* - CALL DGELS( 'N', M, K, N, WORK, M, X, LDX, - $ WORK( M*K+1 ), LWORK, - $ IINFO ) - INFO = IINFO -* - END IF -* - WORK( 1 ) = DBLE( LWKOPT ) -* -* DGECX -* - END \ No newline at end of file From b01d1b213b8e62fd9a9478856dc12072a7fa424e Mon Sep 17 00:00:00 2001 From: Igor Date: Tue, 11 Nov 2025 23:24:16 -0800 Subject: [PATCH 05/63] Delete SRC/dgecx.f --- SRC/dgecx.f | 1173 --------------------------------------------------- 1 file changed, 1173 deletions(-) delete mode 100644 SRC/dgecx.f diff --git a/SRC/dgecx.f b/SRC/dgecx.f deleted file mode 100644 index b343f8c3c..000000000 --- a/SRC/dgecx.f +++ /dev/null @@ -1,1173 +0,0 @@ -*> \par Purpose: -* ============= -*> -*> \verbatim -*> -*> DGECX computes a CX factorization of a real M-by-N matrix A: -*> -*> A * P(K) = C*X + A_resid, where -*> -*> C is an M-by-K matrix which is a subset of K columns selected -*> from the original matrix A, -*> -*> X is a K-by-N matrix that minimizes the Frobenius norm of the -*> residual matrix A_resid, X = pseudoinv(C) * A, -*> -*> P(K) is an N-by-N permutation matrix chosen so that the first -*> K columns of A*P(K) equal C, -*> -*> A_resid is an M-by-N residual matrix. -*> -*> The column selection for the matrix C has two stages. -*> -*> Column selection stage 1. -*> ========================= -*> -*> The user can select N_sel columns and deselect N_desel columns -*> of the matrix A that MUST be included and excluded respectively -*> from the matrix C a priori, before running the column selection -*> algorithm. This is controlled by the flags in the array -*> SEL_DESEL_COLS. The deselected columns are permuted to the right -*> side of the array A and selected columns are permuted to the left -*> side of the array A. The details of the column permutation -*> (i.e. the column permutation matrix P(K)) are stored in the -*> array JPIV. This feature can be used when the goal is to approximate -*> the deselected columns by linear combinations of K selected columns, -*> where the K columns MUST include the N_sel selected columns. -*> -*> Column selection stage 2. -*> ========================= -*> -*> The routine runs the column selection algorithm that can -*> be controlled with three stopping criteria described below. -*> For the column selection, the routine uses a truncated (rank K) in -*> Householder QR factorization with column pivoting algorithm -*> DGEQP3RK routine. Note, that before running the column selection -*> algorithm, the user can deselect M_desel rows of the matrix A that -*> should NOT be considered by the column selection algorithm (i.e. -*> during the factorization). This is controlled by the flags in -*> the array DESEL_ROWS. The deselected rows are permuted to the -*> bottom of the array A. The details of the row permutation (i.e. the -*> row permutation matrix) are stored in the array IPIV. This feature -*> can be used when the goal is to use the deselected rows as test data, -*> and the selected rows as training data. -*> -*> This means that the column selection factorization algorithm is -*> effectively running on the submatrix A_sub=A(1:M_sub,1:N_sub) of -*> the matrix A after the permutations described above. Here M_sub is -*> the number of rows of the matrix A minus the number of deselected -*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number -*> of columns of the matrix A minus the number of deselected columns -*> N_desel, i.e. N_sub = N - N_desel. -*> -*> Column selection criteria. -*> ========================== -*> -*> The column selection criteria (i.e. when to stop the factorization) -*> can be any of the following: -*> -*> 1) The input parameter KMAXFREE, the maximum number of columns -*> to factorize outside of the N_sel preselected columns, -*> i.e. the factorization rank is limited to N_sel + KMAXFREE. -*> If N_sel + KMAXFREE >= min(M_sub, N_sub), the criterion -*> is not used. -*> -*> 2) The input parameter ABSTOL, the absolute tolerance for -*> the maximum column 2-norm of the submatrix residual -*> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub). -*> This means that the factorization stops if this norm is less -*> or equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. -*> -*> 3) The input parameter RELTOL, the tolerance for the maximum -*> column 2-norm matrix of the submatrix residual -*> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub) divided -*> by the maximum column 2-norm of the submatrix -*> A_sub = A(1:M_sub, 1:N_sub). -*> This means that the factorization stops when the ratio of the -*> maximum column 2-norm of A_sub_resid to the maximum column -*> 2-norm of A_sub is less than or equal to RELTOL. -*> If RELTOL < 0.0, the criterion is not used. -*> -*> The algorithm stops when any of these conditions is first -*> satisfied, otherwise the whole submatrix A_sub is factorized. -*> -*> For a full rank factorization of the matrix A_sub, use selection -*> criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) and -*> ABSTOL < 0.0 and RELTOL < 0.0. -*> -*> If the user wants to verify whether the columns of the matrix C are -*> sufficiently linearly independent for their intended use, the user -*> can compute the condition number of its R factor by calling DTRCON -*> on the upper-triangular part of A(1:K,1:K) of the output array A. -*> -*> How N_sel affects the column selection algorithm. -*> ================================================= -*> -*> As mentioned above, the N_sel selected columns are permuted to the -*> right side of the array A, and will be included in the column -*> selection. Then the routine runs the factorization of that block -*> A(1:M_sub,1:N_sel), and if any of the three stopping criteria is met -*> immediately after factoring the first N_sel columns the routine exits -*> (i.e. there is no requirement to select extra columns, -*> if the absolute or relative tolerance of the maximum column 2-norm of -*> the residual is satisfied). In this case, the number -*> of selected columns would be K = N_sel. Otherwise, the factorization -*> routine finds a new column to select with the maximum column 2-norm -*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and permutes that -*> column to the right side of A(1:M,N_sel+1:N_sub). Then the routine -*> checks if the stopping criteria are met in the next residual -*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. -*> -*> Computation of the matrix factors. -*> ================================== -*> -*> When the columns are selected for the factor C, and: -*> a) If the flag FACT='C' or 'X', then the routine explicitly returns -*> the matrix C, otherwise the routine returns only the indices of -*> the selected columns from the original matrix A stored in the JPIV -*> array as the first K elements. -*> b) If the flag FACT='X', then the routine also explicitly -*> computes and returns the factor X = pseudoinv(C) * A. -*> -*> \endverbatim -* -* Arguments: -* ========== -* -*> \param[in] FACT -*> \verbatim -*> FACT is CHARACTER*1 -*> Specifies how the factors of CX factorization -*> are returned. -*> -*> = 'P' or 'p' : return only the column permutaion matrix P -*> in the array JPIV. The first K elements -*> of the array JPIV contain indeces of -*> the factor C colums that were selected -*> from the matrix A. -*> (fastest, smallest memory space) -*> -*> = 'C' or 'c' : return the column permutaion matrix P -*> in the array JPIV and the factor C -*> explicitly in the array C -*> (slower, more memory space) -*> -*> = 'X' or 'x' : return the column permutaion matrix P -*> in the array JPIV, and both factors -*> C and X exlplicitly in the arrays -*> C and X respectively. -*> (slowest, largest memory space) -*> \endverbatim -*> -*> \param[in] USESD -*> \verbatim -*> USESD is CHARACTER*1 -*> Specifies if row deselection and column -*> preselection-deselection functionality is turned ON or OFF. -*> -*> = 'N' or 'n' : Both row deselection and column -*> preselection-deselection are OFF. -*> Both arrays DESEL_ROWS and -*> SEL_DESEL_COLS are not used. -*> -*> = 'R' or 'r' : Only row deselection is ON. -*> Column preselection-deselection is OFF. -*> The array SEL_DESEL_COLS is not used. -*> -*> = 'C' or 'c' : Only column preselection-deselection is ON. -*> Row deselection is OFF. -*> The array DESEL_ROWS is not used. -*> -*> = 'A' or 'a' : Means "All". -*> Both row deselection and column -*> preselection-deselection are ON. -*> \endverbatim -*> -*> \param[in] M -*> \verbatim -*> M is INTEGER -*> The number of rows of the matrix A. M >= 0. -*> \endverbatim -*> -*> \param[in] N -*> \verbatim -*> N is INTEGER -*> The number of columns of the matrix A. N >= 0. -*> \endverbatim -*> -*> \param[in] DESEL_ROWS -*> \verbatim -*> DESEL_ROWS is INTEGER array, dimension (M) -*> This is a row deselection mask array that separates -*. the matrix A rows into 2 sets. -*> -*> a) If DESEL_ROWS(I) = -1, the I-th row of the matrix A is -*> deselected by the user, i.e. chosen to be excluded from -*. the algorithm and will be permuted to the bottom of A. -*> The number of deselected rows is denoted by M_desel. -*> -*> b) If DESEL_ROWS(I) not equal -1, -*> the I-th row of A is a free row and will be used by the -*> algorithm. This defines a set of M_sub = M - M_desel -*> rows that the algorithm will work on. After permutation, -*> this set will be in the top of the matrix A. -*> \endverbatim -*> -*> \param[in] SEL_DESEL_COLS -*> \verbatim -*> SEL_DESEL_COLS is INTEGER array, dimension (N) -*> This is a column preselection/deselection mask array that -*. separates the matrix A columns into 3 sets. -*> -*> a) If SEL_DESEL_COLS(J) = +1, the J-th column of the matrix -*> A is selected by the user to be included in the factor C -*> and will be permuted to the left side of the array A. -*> The number of selected columns is denoted by N_sel. -*> -*> b) If SEL_DESEL_COLS(J) = -1, the J-th column of the matrix -*> A is deselected by the user, i.e. chosen to be excluded -*> from the factor C and will be permuted to the right side -*> of the array A. The number of deselected columns is -*> denoted by N_desel. -*> -*> c) If SEL_DESEL_COLS(J) not equal 1, and not equal -1, -*> the J-th column of A is a free column and will be used by -*> the algorithm to determine if this column has to be -*> selected. This defines a set of -*> N_free = N - N_sel - N_desel. -*> -*> NOTE: Error returned as INFO = -6 means that the number of -*> preselected N_sel colunms is larger than M_sub. -*> Therefore, the factoriaztion of all N_sel preselected -*> columns cannot be completed. -*> \endverbatim -*> -*> \param[in] KMAXFREE -*> \verbatim -*> KMAXFREE is INTEGER -*> -*> The first column selection stopping criterion in the -*> column selection stage 2. -*> -*> The maximum number of columns of the matrix A_sub to select -*> during the factorization stage, KMAXFREE >= 0 -*> -*> KMAXFREE does not include the preselected columns. -*> N_sel + KMAXFREE is the maximum factorization rank of -*> the matrix A_sub = A(1:M_sub, 1:N_sub). -*> -*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this -*> stopping criterion is not used, i.e. columns are selected -*> in the factorization stage depending on -*> ABSTOL and RELTOL. -*> -*> b) If KMAXFREE = 0, then this stopping criterion is -*> satisfied on input and the routine exits without -*> performing column selection stage 2 on the submatrix -*> A_sub. This means that the matrix -*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified. -*> and A_free is itself the residual for the factorization. -*> \endverbatim -*> -*> \param[in] ABSTOL -*> \verbatim -*> ABSTOL is DOUBLE PRECISION, cannot be NaN. -*> -*> The second column selection stopping criterion in the -*> column selection stage 2. -*> -*> Here, SAFMIN = DLAMCH('S'). -*> -*> The absolute tolerance (stopping threshold) for -*> maximum column 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), -*> when K columns were factorized. -*> The algorithm converges (stops the factorization) when -*> the maximum column 2-norm of the residual matrix -*> A_sub_resid is less than or equal to ABSTOL. -*> -*> a) If ABSTOL is NaN, then no computation is performed -*> and an error message ( INFO = -8 ) is issued -*> by XERBLA. -*> -*> b) If ABSTOL < 0.0, then this stopping criterion is not -*> used, factorize columns depending on KMAXFREE -*> and RELTOL. -*> This includes the case ABSTOL = -Inf. -*> -*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN -*> is used. This includes the case ABSTOL = -0.0. -*> -*> d) If 2*SAFMIN <= ABSTOL then the input value -*> of ABSTOL is used. -*> -*> Here, maxcol2norm(A_free) is the maximum column 2-norm -*> of the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). -*> -*> If ABSTOL chosen above is >= maxcol2norm(A_free), then -*> this stopping criterion is satisfied after the matrix -*> A_sel = A(1:M_sub, 1:N_sel) is factorized and the -*> routine exits immediately after maxcol2norm(A_free) is -*> computed to return it in MAXC2NORMK. This means that -*> the factorization residual -*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) -*> is not modified. -*> Also RELMAXC2NORMK of A_free is returned. -*> This includes the case ABSTOL = +Inf. -*> \endverbatim -*> -*> \param[in] RELTOL -*> \verbatim -*> RELTOL is DOUBLE PRECISION, cannot be NaN. -*> -*> The third column selection stopping criterion in the -*> column selection stage 2. -*> -*> Here, EPS = DLAMCH('E'). -*> -*> The tolerance (stopping threshold) for the ratio -*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) of -*> the maximum column 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) and -*> the maximum column 2-norm of the original submatrix -*> A_sub = A(1:M_sub, 1:N_sub). The algorithm -*> converges (stops the factorization), when -*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) is -*> less than or equal to RELTOL. -*> -*> a) If RELTOL is NaN, then no computation is performed -*> and an error message ( INFO = -9 ) is issued -*> by XERBLA. -*> -*> b) If RELTOL < 0.0, then this stopping criterion is not -*> used, factorize columns depending on KMAXFREE -*> and ABSTOL. -*> This includes the case RELTOL = -Inf. -*> -*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. -*> This includes the case RELTOL = -0.0. -*> -*> d) If EPS <= RELTOL then the input value of RELTOL -*> is used. -*> -*> If RELTOL chosen above is >= 1.0, then this stopping -*> criterion is satisfied on input and routine exits -*> immediately after A_sel = A(1:M_sub, 1:N_sel)) -*> is factorized and maxcol2norm(A_free) is computed to -*> return it in MAXC2NORMK. This means that -*> the factorization residual -*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) -*> is not modified. -*> Also RELMAXC2NORMK is returned as 1.0. -*> This includes the case RELTOL = +Inf. -*> -*> NOTE: We recommend RELTOL to satisfy -*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL -*> -*> \endverbatim -*> -*> \param[in,out] A -*> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N) -*> -*> On entry: -*> the M-by-N matrix A. -*> -*> On exit: -*> NOTE DEFINITIONS: M_sub = M_free, -*> N_sub = N_sel + N_free -*> -*> The output parameter K, the number of selected columns, -*> is described later. -*> -*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. -*> -*> 2) If K > 0, A(1:M,1:N): contains the following parts: -*> -*> (a) If M_sub < M (which is the same as M_desel > 0), -*> the subarray A(M_sub+1:M,1:N) contains the deselected -*> rows. -*> -*> (b) If N_sub < N ( which is the same as N_desel > 1 ). -*> the subarray A(1:M,N_sub+1:N) contains the -*> deselected columns. -*> -*> (c) If N_sel > 0, -*> the union of the subarray A(1:M_sub, 1:N_sel) -*> and the subarray A(1:N_sel, 1:N_sub) contains parts -*> of the factors obtained by computing Householder QR -*> factorization WITHOUT column pivoting of N_sel -*> preselected columns using DGEQRF routine. -*> -*> (d) The subarray A(N_sel:M_sub, N_sel:N_sub) contains -*> parts of the factors obtained by computing a truncated -*> (rank K) Householder QR factorization with -*> column pivoting using DGEQP3RK on the matrix -*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) which -*> is the result of applying selection and deselection -*> of columns, applying deselection of rows to the -*> original matrix A, and applying orthogonal -*> transformation from the factorization of the first -*> N_sel columns as described in part (c). -*> -*> 1. The elements below the diagonal of the subarray -*> A_sub(1:M_sub,1:K) together with TAU(1:K) -*> represent the orthogonal matrix Q(K) as a -*> product of K Householder elementary reflectors. -*> -*> 2. The elements on and above the diagonal of -*> the subarray A_sub(1:K,1:N_sub) contain -*> K-by-N_sub upper-trapezoidal matrix -*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). -*> NOTE: If K=min(M_sub,N_sub), i.e. full rank -*> factorization, then R_sub_approx(K) is the -*> full factor R which is upper-trapezoidal. -*> If, in addition, M_sub>=N_sub, then R is -*> upper-triangular. -*> -*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains -*> (M_sub-K)-by-(N_sub-K) rectangular matrix -*> A_sub_resid(K). -*> \endverbatim -*> -*> \param[in] LDA -*> \verbatim -*> LDA is INTEGER -*> The leading dimension of the array A. LDA >= max(1,M). -*> \endverbatim -*> -*> \param[out] K -*> \verbatim -*> K is INTEGER -*> The number of columns that were selected. -*> (K is the factorization rank) -*> 0 <= K <= min( M_sub, min(N_sel+KMAXFREE, N_sub) ). -*> -*> If K = 0, the arrays A, TAU were not modified. -*> \endverbatim -*> -*> \param[out] MAXC2NRMK -*> \verbatim -*> MAXC2NRMK is DOUBLE PRECISION -*> The maximum column 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), -*> when factorization stopped at rank K. MAXC2NRMK >= 0. -*> -*> a) If K = 0, i.e. the factorization was not performed, -*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified -*> and is itself a residual matrix, then MAXC2NRMK equals -*> the maximum column 2-norm of the original matrix A_sub. -*> -*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. -*> -*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was -*> factorized and there is no factorization residual matrix, -*> then MAXC2NRMK = 0.0. -*> -*> NOTE: MAXC2NRMK at the factorization step K would equal -*> to the diagonal element R_sub(K+1,K+1) of the factor -*> R_sub in the next factorization step K+1. -*> \endverbatim -*> -*> \param[out] RELMAXC2NRMK -*> \verbatim -*> RELMAXC2NRMK is DOUBLE PRECISION -*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column -*> 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when -*> factorization stopped at rank K) and maximum column 2-norm -*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). -*> RELMAXC2NRMK >= 0. -*> -*> a) If K = 0, i.e. the factorization was not performed, -*> the matrix A_sub was not modified -*> and is itself a residual matrix, -*> then RELMAXC2NRMK = 1.0. -*> -*> b) If 0 < K < min(M_sub,N_sub), then -*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. -*> -*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was -*> factorized and there is no residual matrix -*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. -*> -*> NOTE: RELMAXC2NRMK at the factorization step K would equal -*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next -*> factorization step K+1, where R_sub(K+1,K+1) is the -*> diaginal element of the factor R_sub in the next -*> factorization step K+1. -*> \endverbatim -*> -*> \param[out] FNRMK -*> \verbatim -*> FNRMK is DOUBLE PRECISION -*> Frobenius norm of the factorization residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). -*> FNRMK >= 0.0 -*> \endverbatim -*> -*> \param[out] IPIV -*> \verbatim -*> IPIV is INTEGER array, dimension (M) -*> Row permutation indices due to row -*> deselection, for 1 <= i <= M. -*> If IPIV(i)= k, then the row i of A_sub was the -*> the row k of A. -*> \endverbatim -*> -*> \param[out] JPIV -*> \verbatim -*> JPIV is INTEGER array, dimension (N) -*> Column permutation indices, for 1 <= j <= N. -*> If JPIV(j)= k, then the column j of A*P was the -*> the column k of A. -*> -*> The first K elements of the array JPIV contain -*> indeces of the factor C colums that were selected -*> from the matrix A. -*> \endverbatim -*> -*> \param[out] TAU -*> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) -*> The scalar factors of the elementary reflectors. -*> -*> If 0 < K <= MIN(M_sub,N_sub), only elements TAU(1:K) of -*> the array TAU may be modified. The elements -*> TAU(K+1:min(M_sub,N_sub)) are set to zero. -*> The elements of TAU(min(M_sub,N_sub)+1:N) are not -*> modified. -*> \endverbatim -*> -*> \param[out] C -*> \verbatim -*> C is DOUBLE PRECISION array. -*> If FACT = 'C' or 'X': -*> If K > 0, C is the M-by-K factor C -*> and array has dimension (LDC,N), -*> If FACT = 'N': -*> array is not used and can have linear dimension >=1. -*> \endverbatim -*> -*> \param[in] LDC -*> \verbatim -*> LDC is INTEGER -*> The leading dimension of the array C. -*> If FACT = 'C' or 'X', LDC >= max(1,M). -*> If FACT = 'P', LDC >= 1. -*> \endverbatim -*> -*> \param[out] X -*> \verbatim -*> X is DOUBLE PRECISION array. -*> If FACT = 'X': -*> If K > 0, C is the K-by-N factor X -*> and array has dimension (LDX,N). -*> If FACT = 'P': -*> array is not used and can have linear dimension >=1. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. -*> If FACT = 'X', LDC >= max(1,M). -*> If FACT = 'P', LDC >= 1. -*> \endverbatim -*> -*> \param[out] WORK -*> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) -*> On exit, if INFO>=0, WORK(1) returns the optimal LWORK. -*> \endverbatim -*> -*> \param[in] LWORK -*> \verbatim -*> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= 3*N_sub+1. -*> For optimal performance LWORK >= 2*N_sub+( N_sub+1 )*NB, -*> where NB is the optimal blocksize. -*> -*> 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. -*> \endverbatim -*> -*> \param[out] IWORK -*> \verbatim -*> IWORK is INTEGER array, dimension (N). -*> Is a work array. ( IWORK is used by DGEQP3RK to store indices -*> of "bad" columns for norm downdating in the residual -*> matrix in the blocked step auxiliary subroutine DLAQP3RK ). -*> \endverbatim -*> -*> \param[out] LIWORK -*> \verbatim -*> LIWORK is INTEGER -*> The dimension of the array LIWORK. LIWORK >= N -*> -*> If LIWORK = -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 IWORK array, and no error -*> message related to LIWORK is issued by XERBLA. -*> \endverbatim -*> -*> \param[out] INFO -*> \verbatim -*> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. -*> > 0: if INFO = i, the i-th diagonal element of the -*> triangular factor of in the matrix C is zero, -*> so that C does not have full rank; X cannot be -*> computed as the least squares solution to C*X = A. -*> \endverbatim -* ===================================================================== - SUBROUTINE DGECX( FACT, USESD, M, N, - $ DESEL_ROWS, SEL_DESEL_COLS, - $ KMAXFREE, ABSTOL, RELTOL, A, LDA, - $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, - $ IPIV, JPIV, TAU, C, LDC, X, LDX, - $ WORK, LWORK, IWORK, LIWORK, INFO ) -* -* -- LAPACK computational routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. - CHARACTER FACT, USESD - INTEGER INFO, K, KMAXFREE, LDA, LDC, LDX, LIWORK, - $ LWORK, M, N - DOUBLE PRECISION ABSTOL, ABSTOLFREE, MAXC2NRMK, RELTOL, - $ RELTOLFREE, RELMAXC2NRMK, FNRMK -* .. -* .. Array Arguments .. - INTEGER DESEL_ROWS( * ), IPIV( * ), JPIV( * ), - $ SEL_DESEL_COLS( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ X( LDX, *), WORK( * ) -* ===================================================================== -* -* .. Parameters .. - INTEGER INB - PARAMETER ( INB = 1 ) - DOUBLE PRECISION ZERO, TWO, MINUSONE - PARAMETER ( ZERO = 0.0D+0, TWO = 2.0D+0, - $ MINUSONE = -1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LIQUERY, LQUERY, RETURNC, RETURNX, - $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL - INTEGER I, J, NSUB, MFREE, MSUB, MNSUB, NSEL, JDESEL, - $ ITEMP, IINFO, KP, KP0, KFREE, MRESID, NRESID, - $ NRHS, LWKMIN, LWKOPT, JP, JJ, JPW, MINMN, - $ NBOPT - DOUBLE PRECISION EPS, MAXC2NRM, SAFMIN, RELMAXC2NRMKFREE - -* .. External Subroutines .. - EXTERNAL DLACPY, DGELS, DGEQP3RK, DGEQRF, DORMQR, - $ DSWAP, XERBLA -* .. -* .. External Functions .. - LOGICAL DISNAN, LSAME - INTEGER IDAMAX, ILAENV - DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 - EXTERNAL DISNAN, DLAMCH, DLANGE, DNRM2, IDAMAX, - $ ILAENV, LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LQUERY = ( LWORK.EQ.-1 ) - LIQUERY = ( LIWORK.EQ.-1 ) -* - RETURNX = LSAME( FACT, 'X' ) - RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX -* - USE_DESEL_ROWS = LSAME( USESD, 'R' ) .OR. LSAME( USESD, 'A' ) - USE_SEL_DESEL_COLS = LSAME( USESD, 'C') .OR. LSAME( USESD, 'A' ) -* - IF ( .NOT.(RETURNC .OR. LSAME( FACT, 'P') ) ) THEN - INFO = -1 - ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS - $ .OR. LSAME( USESD, 'N' ) ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( KMAXFREE.LT.0 ) THEN - INFO = -7 - ELSE IF( DISNAN( ABSTOL ) ) THEN - INFO = -8 - ELSE IF( DISNAN( RELTOL ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.RETURNC .AND. LDC.LT.1 )) THEN - INFO = -20 - ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.RETURNX .AND. LDX.LT.1 )) THEN - INFO = -22 - END IF -* -* If the above input parameters are valid: -* a) Test the input workspace size LWORK for the minimum -* size requirement LWKMIN. -* b) Determine the optimal block size NB and optimal -* workspace size LWKOPT to be returned in WORK(1) -* in case of: (1) LWORK < LWKMIN, (2) LQUERY = .TRUE., -* (3) when routine exits. -* Here, LWKMIN is the miminum workspace required for unblocked -* code. -* - IF( INFO.EQ.0 ) THEN - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - LWKMIN = 1 - LWKOPT = 1 - ELSE - LWKMIN = 3*N + 1 -* -* Assign to NBOPT optimal block size. -* - NBOPT = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = 1000 - END IF - WORK( 1 ) = DBLE( LWKOPT ) -* - IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN - INFO = -24 - END IF - END IF -* -* ================================================================== -* - K = 0 -* - EPS = DLAMCH('Epsilon') -* - USETOL = .FALSE. -* -* Adjust ABSTOL only if nonnegative. Negative value means disabled. -* We need to keep negtive value for later use in criterion -* check. -* - IF( ABSTOL.GE.ZERO ) THEN - SAFMIN = DLAMCH('Safe minimum') - ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) - USETOL = .TRUE. - END IF -* -* Ajust RELTOL only if nonnegative. Negative value means disabled. -* We need to keep negtive value for later use in criterion -* check. -* - IF( RELTOL.GE.ZERO ) THEN - RELTOL = MAX( RELTOL, EPS ) - USETOL = .TRUE. - END IF -* -* ================================================================== -* -* If we need to return factor C, copy the original unctouched matrix -* A into the array C. -* - IF( RETURNC ) THEN - CALL DLACPY( 'F', M, N, A, LDA, C, LDC ) - END IF -* -* If we need to return factor X, copy the original unctouched matrix -* A into the array X. -* - IF( RETURNX ) THEN - CALL DLACPY( 'F', M, N, A, LDA, X, LDX ) - END IF -* -* ================================================================== -* Permute the deselected rows to the bottom of the matrix A. -* 1) Order of free rows is preserved. -* 2) Order of deselected rows is not preserved. -* ================================================================== -* -* I is the index of DESEL_ROWS array and row I -* of the matrix A. -* MFREE is the number of free rows, also the pointer to the last -* free row. -* (For each position I, we check if this position is a FREE row. -* If it is a FREE row we increment the MFREE pointer, otherwise we -* do not change the MFREE pointer. Also, if it is a FREE row, we move -* this row from the larger (or same) I index into samaller (or same) -* MFREE index. This way we move all the FREE rows to the lower index -* block preserving FREE row order. Deselected rows will be ) -* - IF( USE_DESEL_ROWS ) THEN -* - MFREE = 0 - DO I = 1, M, 1 -* -* Initialize row pivot array IPIV. - IPIV( I ) = I -* - IF( DESEL_ROWS(I).NE.-1 ) THEN - MFREE = MFREE + 1 -* -* This is the check whether the deselected row is -* on the deselected place already. -* - IF( I.NE.MFREE ) THEN -* -* Here, we swap A(I,1:N) into A(MFREE,1:N) -* - CALL DSWAP( N, A( I, 1 ), LDA, A( MFREE, 1 ), LDA ) - IPIV( I ) = IPIV( MFREE ) - IPIV( MFREE ) = I - ITEMP = DESEL_ROWS( I ) - DESEL_ROWS( I ) = DESEL_ROWS( MFREE ) - DESEL_ROWS( MFREE ) = ITEMP - END IF - END IF -* - END DO -* - ELSE -* -* We do not row deselection DESEL_ROWS array. -* Initialize row pivot array IPIV. -* - DO I = 1, M, 1 - IPIV( I ) = I - END DO -* - MFREE = M - END IF - MSUB = M -* -* ================================================================== -* Permute the pseselected columns to the left and deselected -* columns to the right of the matrix A. -* 1) Order of preselected columns is preserved. -* 2) Order of free columns is not preserved. -* 3) Order of deselected columns is not preserved. -* ================================================================== -* -* J is the index of SEL_DESEL_COLS array and column J -* of the matrix A. -* -* Column selection. -* NSEL is the number of selected columns, also the pointer to the last -* selected column. -* - NSEL = 0 - IF( USE_SEL_DESEL_COLS ) THEN -* - DO J = 1, N, 1 -* -* Initialize column pivot array JPIV. - JPIV( J ) = J -* - IF( SEL_DESEL_COLS(J).EQ.1 ) THEN - NSEL = NSEL + 1 -* -* This is the check whether the selected column is -* on the selected place already. -* - IF( J.NE.NSEL ) THEN -* -* Here, we swap the column A(1:M,J) into A(1:M,NSEL) -* - CALL DSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) - JPIV( J ) = JPIV( NSEL ) - JPIV( NSEL ) = J - SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) - SEL_DESEL_COLS( NSEL ) = 1 - END IF - END IF - END DO -* -* Column deselection. -* - JDESEL = N+1 - DO J = N, NSEL+1, -1 - IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN - JDESEL = JDESEL - 1 -* -* This is the check whether the deselected column is -* on the deselected place already. -* - IF( J.NE.JDESEL ) THEN -* -* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) -* - CALL DSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) - ITEMP = JPIV( J ) - JPIV( J ) = JPIV( JDESEL ) - JPIV( JDESEL ) = ITEMP - SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) - SEL_DESEL_COLS( JDESEL ) = -1 - END IF - END IF - END DO -* - NSUB = JDESEL - 1 -* - ELSE -* -* We do not column selection deselection SEL_DESEL_COLS array. -* Initialize column pivot array JPIV. -* - DO J = 1, N, 1 - JPIV( J ) = J - END DO -* - NSUB = N - END IF -* -* ================================================================== -* Compute the complete column 2-norms of the submatrix -* A_sub=A(1:MSUB, 1:NSUB) and store them in WORK(NSUB+1:2*NSUB). -* - DO J = 1, NSUB - WORK( NSUB+J ) = DNRM2( MSUB, A( 1, J ), 1 ) - END DO -* -* Compute the column index and the maximum column 2-norm -* for the submatrix A_sub=A(1:MSUB, 1:NSUB). -* - KP0 = IDAMAX( NSUB, WORK( NSUB+1 ), 1 ) - MAXC2NRM = WORK( NSUB + KP0 ) -* -* ================================================================== -* Process preselected columns -* -* Compute the QR factorization of NSEL preselected columns (1:NSEL) -* the submatrix A_sub=(1:MSUB, 1:NSUB) and update -* remaining NFEE free columns (NSEL+1:NSUB). -* MSUB = MFREE, NSUB = MSEL + NFREE -* - MNSUB = MIN(MSUB, NSUB) - MRESID = MSUB-NSEL - NRESID = NSUB-NSEL - IF( NSEL.GT.0 ) THEN - IF( MSUB.LT.NSEL ) THEN -* TODO: Move this part to the top of the routine. -* a) Case MSUB < NSEL. -* When the number of preselected columns -* is larger than MSUB, hence the factorization of all NSEL -* columns cannot be completed. Return from the routine with the -* error of COL_SEL_DESEL parameter. NSEL cannot be larger than -* MSUB. -* - INFO = -6 - WORK( 1 ) = DBLE( LWKOPT ) - RETURN - ELSE IF( MSUB.EQ.NSEL.OR. - $ ( MSUB.GT.NSEL.AND.NSEL.EQ.NSUB )) THEN -* -* b) Case MSUB = NSEL. -* c-1) Case MSUB > NSEL and NSEL = NSUB. -* -* There will be no residual submatrix after factorization -* of NSEL columns at step K = NSEL: -* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). -* Therefore, ther is no need to do the factorization of NSEL -* columns. Set norms to ZERO and return from the routine. -* - K = NSEL - MAXC2NRMK = ZERO - RELMAXC2NRMK = ZERO - FNRMK = ZERO -* - DO J = K + 1, MNSUB - TAU( J ) = ZERO - END DO -* -* Factorization is done. Go to computation of the factor C. -* - GO TO 10 - ELSE -* -* (c-2) Case MSUB > NSEL and NSEL < NSUB. -* -* There is a submatrix residual at step K=NSEL -* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) -* - CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) -* -* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) -* - CALL DORMQR( 'Left', 'Transpose', MSUB, NSUB-NSEL, NSEL, - $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, LWORK, IINFO ) -* -* Compute the complete column 2-norms of the submatrix -* residual at step NSEL -* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) and -* store them in WORK(NSUB+NSEL+1:2*NSUB). -* - DO J = NSEL+1, NSUB - WORK( NSUB+J ) = DNRM2( MRESID, A( NSEL+1, J ), 1 ) - END DO -* -* Compute the column index and the maximum column 2-norm -* and the relative maximum column 2-norm for the submatrix -* residual. -* - KP = IDAMAX( NRESID, WORK( NSUB+NSEL+1 ), 1 ) -* - K = NSEL - MAXC2NRMK = WORK( NSUB + NSEL + KP ) - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM -* -* Test for the first, second and third tolerance stopping -* criteria after factorizarion of preselected columns. -* If any of them is met, return. Otherwise, -* proceed with factorization of the NFREE free columns. -* NOTE: There is no need to test for ABSTOL.GE.ZERO, since -* MAXC2NRMK is non-negative. Similarly, there is no need -* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is -* non-negative. -* - IF( KMAXFREE.EQ.0 - $ .OR. MAXC2NRMK.LE.ABSTOL - $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN -* -* NOTE: In this (c-2) case. There is a submatrix -* residual A_sub_resid(NSEL). We do not need to have a check -* for MIN(MRESID, NRESID) = 0 to call DLANGE. -* - FNRMK = DLANGE( 'F', MRESID, NRESID, A(NSEL+1,NSEL+1), - $ LDA, WORK ) -* - DO J = K + 1, MNSUB - TAU( J ) = ZERO - END DO -* -* Factorization is done. Go to computation of the factor C. -* - GO TO 10 - END IF -* -* -* - END IF - END IF -* -* ================================================================== -* -* Factorize NFREE free columns of -* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), -* KFREE is the number of columns that were actually factorized among -* NFREE columns. -* -* Disable RELTOLFREE when calling DGEQP3RK for free columns -* factorization, since it expects RELTOLFREE with respect to -* the residual matrix A_sub_resid(NSEL), not the whole original -* marix A. We can use RELTOL criterion by passing it to -* ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that -* the negative values of ABSTOL and RELTOL are propagated -* to ABSTOLFREE and RELTOLFREE, since negative vaslues means -* that the criterionis is disabled. -* - IF( USETOL ) THEN - ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) - ELSE - ABSTOLFREE = MINUSONE - END IF - RELTOLFREE = MINUSONE - NRHS = 0 -* - CALL DGEQP3RK( MRESID, NRESID, NRHS, KMAXFREE, - $ ABSTOLFREE, RELTOLFREE, - $ A( K+1, K+1 ), LDA, KFREE, MAXC2NRMK, - $ RELMAXC2NRMKFREE, JPIV( K+1 ), TAU( K+1 ), - $ WORK, LWORK, IWORK, IINFO ) -* -* 1) Adjust the return value for the number of factorized -* columns K for the whole submatrix A_sub. -* 2) MAXC2NRMK is returned transparently without change -* as it is returned from DGEQP3RK. -* 3) Adjust the return value RELMAXC2NRMK for the whole -* submatrix A_sub. We do not use RELMAXC2NRMKFREE -* returned from DGEQP3RK. -* - K = K + KFREE - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM -* -* Now, MRESID and NRESID is the number of rows and columns -* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). -* - MRESID = MRESID-KFREE - NRESID = NRESID-KFREE - IF( MIN( MRESID, NRESID ).NE.0 ) THEN - FNRMK = DLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), - $ LDA, WORK ) - ELSE - FNRMK = ZERO - END IF -* -* Compute the factor C. -* - 10 CONTINUE -* - IF( RETURNC .AND. K.GT.0 ) THEN -* -* Apply interchanges to columns 1:K in the matrix C in place, -* which stores the original matrix A. -* IWORK is used to keep track of original column indices, -* when swaping. - - DO J = 1, N, 1 - IWORK( J ) = J - END DO - DO J = 1, K, 1 - JP = JPIV( J ) - IF( J.NE.JP ) THEN - DO JJ = J, N, 1 - IF( JP.EQ.IWORK( JJ ) ) THEN - JPW = JJ - END IF - END DO - IF( J.NE.JPW ) THEN - CALL DSWAP( M, C( 1, J ), 1, C( 1, JPW ), 1 ) - ITEMP = IWORK( J ) - IWORK( J ) = IWORK( JPW ) - IWORK( JPW ) = ITEMP - END IF - END IF - END DO -* - END IF -* -* Return matrix X. -* - IF( RETURNX .AND. K.GT.0 ) THEN -* -* We need to use C and A to compute X = pseudoinv(C) * A, as -* the Linear Least Squares problem C*X = A. We use LLS routine -* that uses QR factorization. For that purpose, we store C into -* WORK array WORK(1:M*K), and the matrix A was copied into -* the array X at the begining of the routine. -* -* Copy matrix C into work array WORK. -* - CALL DLACPY( 'F', M, K, C, LDC, WORK, M ) -* - CALL DGELS( 'N', M, K, N, WORK, M, X, LDX, - $ WORK( M*K+1 ), LWORK, - $ IINFO ) - INFO = IINFO -* - END IF -* - WORK( 1 ) = DBLE( LWKOPT ) -* -* DGECX -* - END From 3833d89e01af26d68e2e9b2be312ff86bbecc28f Mon Sep 17 00:00:00 2001 From: Igor Date: Tue, 11 Nov 2025 23:33:19 -0800 Subject: [PATCH 06/63] Added DGECXX routine in dgecxx.f --- SRC/dgecxx.f | 1437 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1437 insertions(+) create mode 100644 SRC/dgecxx.f diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f new file mode 100644 index 000000000..3ba1c52f8 --- /dev/null +++ b/SRC/dgecxx.f @@ -0,0 +1,1437 @@ +*> \brief \b DGECXX computes a CX factorization of a real M-by-N matrix A using a truncated (rank k) Householder QR factorization with column pivoting algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGECXX( FACT, USESD, M, N, +* $ DESEL_ROWS, SEL_DESEL_COLS, +* $ KMAXFREE, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, +* $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, +* $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER FACT, USESD +* INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, +* $ LDX, LIWORK, LWORK, M, N +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, +* $ RELMAXC2NRMK, FNRMK +* .. +* .. Array Arguments .. +* INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), +* $ JPIV( * ), SEL_DESEL_COLS( * ) +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), +* $ TAU( * ), WORK( * ), X( LDX, *) +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGECXX computes a CX factorization of a real M-by-N matrix A using +*> a truncated (rank k) Householder QR factorization with column +*> pivoting algorithm implemented in DGEQP3RK routine. +*> +*> A * P(K) = C*X + A_resid, where +*> +*> C is an M-by-K matrix which is a subset of K columns selected +*> from the original matrix A, +*> +*> X is a K-by-N matrix that minimizes the Frobenius norm of the +*> residual matrix A_resid, X = pseudoinv(C) * A, +*> +*> P(K) is an N-by-N permutation matrix chosen so that the first +*> K columns of A*P(K) equal C, +*> +*> A_resid is an M-by-N residual matrix. +*> +*> The column selection for the matrix C has two stages. +*> +*> Column selection stage 1. +*> ========================= +*> +*> The user can select N_sel columns and deselect N_desel columns +*> of the matrix A that MUST be included and excluded respectively +*> from the matrix C a priori, before running the column selection +*> algorithm. This is controlled by the flags in the array +*> SEL_DESEL_COLS. The deselected columns are permuted to the right +*> side of the array A and selected columns are permuted to the left +*> side of the array A. The details of the column permutation +*> (i.e. the column permutation matrix P(K)) are stored in the +*> array JPIV. This feature can be used when the goal is to approximate +*> the deselected columns by linear combinations of K selected columns, +*> where the K columns MUST include the N_sel selected columns. +*> +*> Column selection stage 2. +*> ========================= +*> +*> The routine runs the column selection algorithm that can +*> be controlled with three stopping criteria described below. +*> For the column selection, the routine uses a truncated (rank K) +*> Householder QR factorization with column pivoting algorithm using +*> DGEQP3RK routine. Note, that before running the column selection +*> algorithm, the user can deselect M_desel rows of the matrix A that +*> should NOT be considered by the column selection algorithm (i.e. +*> during the factorization). This is controlled by the flags in +*> the array DESEL_ROWS. The deselected rows are permuted to the +*> bottom of the array A. The details of the row permutation (i.e. the +*> row permutation matrix) are stored in the array IPIV. This feature +*> can be used when the goal is to use the deselected rows as test data, +*> and the selected rows as training data. +*> +*> This means that the column selection factorization algorithm is +*> effectively running on the submatrix A_sub = A(1:M_sub,1:N_sub) of +*> the matrix A after the permutations described above. Here M_sub is +*> the number of rows of the matrix A minus the number of deselected +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> of columns of the matrix A minus the number of deselected columns +*> N_desel, i.e. N_sub = N - N_desel. +*> +*> Column selection criteria. +*> ========================== +*> +*> The column selection criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAXFREE, the maximum number of columns +*> to factorize outside of the N_sel preselected columns, +*> i.e. the factorization rank is limited to N_sel + KMAXFREE. +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), the criterion +*> is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the submatrix residual +*> A_sub_resid = A(K+1:M_sub, K+1:N_sub). +*> This means that the factorization stops if this norm is less +*> or equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the submatrix residual +*> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub) divided +*> by the maximum column 2-norm of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub). +*> This means that the factorization stops when the ratio of the +*> maximum column 2-norm of A_sub_resid to the maximum column +*> 2-norm of A_sub is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole submatrix A_sub is factorized. +*> +*> For a full rank factorization of the matrix A_sub, use selection +*> criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) and +*> ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> If the user wants to verify whether the columns of the matrix C are +*> sufficiently linearly independent for their intended use, the user +*> can compute the condition number of its R factor by calling DTRCON +*> on the upper-triangular part of QRC(1:K,1:K) of the output +*> array QRC. +*> +*> How N_sel affects the column selection algorithm. +*> ================================================= +*> +*> As mentioned above, the N_sel selected columns are permuted to the +*> right side of the array A, and will be included in the column +*> selection. Then the routine runs the factorization of that block +*> A(1:M_sub,1:N_sel), and if any of the three stopping criteria is met +*> immediately after factoring the first N_sel columns the routine exits +*> (i.e. the user does not want to select KMAXFREE extra columns, or +*> if the absolute or relative tolerance of the maximum column 2-norm of +*> the residual is satisfied). In this case, the number +*> of selected columns would be K = N_sel. Otherwise, the factorization +*> routine finds a new column to select with the maximum column 2-norm +*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and permutes that +*> column to the right side of A(1:M,N_sel+1:N_sub). Then the routine +*> checks if the stopping criteria are met in the next residual +*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. +*> +*> Computation of the matrix factors. +*> ================================== +*> +*> When the columns are selected for the factor C, and: +*> (a) If the flag FACT = 'P', the routine returns only the indices of +*> the selected columns from the original matrix A that are stored +*> in the JPIV array as the first K elements. +*> (b) If the flag FACT = 'C', then in addition to (a), the routine +*> explicitly returns the matrix C in the array C. +*> (c) If the flag FACT = 'X', then in addition to (b), the routine +*> explicitly computes and returns the factor +*> X = pseudoinv(C) * A in the array X, and it returns +*> the factor R alongside the Householder vectors +*> of the QR factorization of the matrix C in the array QRC. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> Specifies how the factors of a CX factorization +*> are returned. +*> +*> = 'P' or 'p' : return only the column permutation matrix P +*> in the array JPIV. The first K elements +*> of the array JPIV contain indices of +*> the factor C columns that were selected +*> from the matrix A. +*> (fastest, smallest memory space) +*> +*> = 'C' or 'c' : return the column permutation matrix P +*> in the array JPIV and the factor C +*> explicitly in the array C +*> (slower, more memory space) +*> +*> = 'X' or 'x' : return the column permutation matrix P +*> in the array JPIV, and both factors +*> C and X explicitly in the arrays +*> C and X respectively. In addition, +*> the factor R and the Householder vectors +*> of the QR factorization of the factor C +*> are returned in the array QRC. +*> (R factor may be useful for checking +*> the factor C for singularity (R will +*> have zero on the diagonal), and in this +*> case the factor X cannot be computed.) +*> (slowest, largest memory space) +*> \endverbatim +*> +*> \param[in] USESD +*> \verbatim +*> USESD is CHARACTER*1 +*> Specifies if row deselection and column +*> preselection-deselection functionality is turned ON or OFF. +*> +*> = 'N' or 'n' : Both row deselection and column +*> preselection-deselection are OFF. +*> Both arrays DESEL_ROWS and +*> SEL_DESEL_COLS are not used. +*> +*> = 'R' or 'r' : Only row deselection is ON. +*> Column preselection-deselection is OFF. +*> The array SEL_DESEL_COLS is not used. +*> +*> = 'C' or 'c' : Only column preselection-deselection is ON. +*> Row deselection is OFF. +*> The array DESEL_ROWS is not used. +*> +*> = 'A' or 'a' : Means "All". +*> Both row deselection and column +*> preselection-deselection are ON. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (M) +*> This is a row deselection mask array that separates +*. the matrix A rows into 2 sets. +*> +*> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is +*> deselected by the user, i.e. chosen to be excluded from +*. the algorithm and will be permuted to the bottom of A. +*> The number of deselected rows is denoted by M_desel. +*> +*> b) If DESEL_ROWS(i) not equal -1, +*> the i-th row of A is a free row and will be used by the +*> algorithm. This defines a set of M_sub = M - M_desel +*> rows that the algorithm will work on. After permutation, +*> this set will be in the top of the matrix A. +*> \endverbatim +*> +*> \param[in] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (N) +*> This is a column preselection/deselection mask array that +*. separates the matrix A columns into 3 sets. +*> +*> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix +*> A is selected by the user to be included in the factor C +*> and will be permuted to the left side of the array A. +*> The number of selected columns is denoted by N_sel. +*> +*> b) If SEL_DESEL_COLS(j) = -1, the j-th column of the matrix +*> A is deselected by the user, i.e. chosen to be excluded +*> from the factor C and will be permuted to the right side +*> of the array A. The number of deselected columns is +*> denoted by N_desel. +*> +*> c) If SEL_DESEL_COLS(j) not equal 1, and not equal -1, +*> the j-th column of A is a free column and will be used by +*> the algorithm to determine if this column has to be +*> selected. This defines a set of +*> N_free = N - N_sel - N_desel. +*> +*> NOTE: Error returned as INFO = -6 means that the number of +*> preselected N_sel colunms is larger than M_sub. +*> Therefore, the QR factorization of all N_sel preselected +*> columns cannot be completed. +*> \endverbatim +*> +*> \param[in] KMAXFREE +*> \verbatim +*> KMAXFREE is INTEGER +*> +*> The first column selection stopping criterion in the +*> column selection stage 2. +*> +*> The maximum number of columns of the matrix A_sub to select +*> during the factorization stage, KMAXFREE >= 0. +*> +*> KMAXFREE does not include the preselected columns. +*> N_sel + KMAXFREE is the maximum factorization rank of +*> the matrix A_sub = A(1:M_sub, 1:N_sub). +*> +*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this +*> stopping criterion is not used, i.e. columns are selected +*> in the factorization stage depending on +*> ABSTOL and RELTOL. +*> +*> b) If KMAXFREE = 0, then this stopping criterion is +*> satisfied on input and the routine exits without +*> performing column selection stage 2 on the submatrix +*> A_sub. This means that the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified. +*> and A_free is itself the residual for the factorization. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second column selection stopping criterion in the +*> column selection stage 2. +*> +*> Here, SAFMIN = DLAMCH('S'). +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), +*> when K columns were factorized. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> A_sub_resid is less than or equal to ABSTOL. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -8 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, factorize columns depending on KMAXFREE +*> and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Here, maxcol2norm(A_free) is the maximum column 2-norm +*> of the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). +*> +*> If ABSTOL chosen above is >= maxcol2norm(A_free), then +*> this stopping criterion is satisfied after the matrix +*> A_sel = A(1:M_sub, 1:N_sel) is factorized and the +*> routine exits immediately after maxcol2norm(A_free) is +*> computed to return it in MAXC2NORMK. This means that +*> the factorization residual +*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) +*> is not modified. +*> Also RELMAXC2NORMK of A_free is returned. +*> This includes the case ABSTOL = +Inf. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third column selection stopping criterion in the +*> column selection stage 2. +*> +*> Here, EPS = DLAMCH('E'). +*> +*> The tolerance (stopping threshold) for the ratio +*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) of +*> the maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) and +*> the maximum column 2-norm of the original submatrix +*> A_sub = A(1:M_sub, 1:N_sub). The algorithm +*> converges (stops the factorization), when +*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -9 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, factorize columns depending on KMAXFREE +*> and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after A_sel = A(1:M_sub, 1:N_sel)) +*> is factorized and maxcol2norm(A_free) is computed to +*> return it in MAXC2NORMK. This means that +*> the factorization residual +*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) +*> is not modified. +*> Also RELMAXC2NORMK is returned as 1.0. +*> This includes the case RELTOL = +Inf. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL +*> +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> +*> On entry: +*> the M-by-N matrix A. +*> +*> On exit: +*> NOTE DEFINITIONS: M_sub = M_free, +*> N_sub = N_sel + N_free +*> +*> The output parameter K, the number of selected columns, +*> is described later. +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> +*> 2) If K > 0, A(1:M,1:N): contains the following parts: +*> +*> (a) If M_sub < M (which is the same as M_desel > 0), +*> the subarray A(M_sub+1:M,1:N) contains the deselected +*> rows. +*> +*> (b) If N_sub < N ( which is the same as N_desel > 1 ). +*> the subarray A(1:M,N_sub+1:N) contains the +*> deselected columns. +*> +*> (c) If N_sel > 0, +*> the union of the subarray A(1:M_sub, 1:N_sel) +*> and the subarray A(1:N_sel, 1:N_sub) contains parts +*> of the factors obtained by computing Householder QR +*> factorization WITHOUT column pivoting of N_sel +*> preselected columns using DGEQRF routine. +*> +*> (d) The subarray A(N_sel:M_sub, N_sel:N_sub) contains +*> parts of the factors obtained by computing a truncated +*> (rank K) Householder QR factorization with +*> column pivoting using DGEQP3RK on the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) which +*> is the result of applying selection and deselection +*> of columns, applying deselection of rows to the +*> original matrix A, and applying orthogonal +*> transformation from the factorization of the first +*> N_sel columns as described in part (c). +*> +*> 1. The elements below the diagonal of the subarray +*> A_sub(1:M_sub,1:K) together with TAU(1:K) +*> represent the orthogonal matrix Q(K) as a +*> product of K Householder elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A_sub(1:K,1:N_sub) contain +*> K-by-N_sub upper-trapezoidal matrix +*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). +*> NOTE: If K=min(M_sub,N_sub), i.e. full rank +*> factorization, then R_sub_approx(K) is the +*> full factor R which is upper-trapezoidal. +*> If, in addition, M_sub>=N_sub, then R is +*> upper-triangular. +*> +*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains +*> (M_sub-K)-by-(N_sub-K) rectangular matrix +*> A_sub_resid(K). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were selected. +*> (K is the factorization rank) +*> 0 <= K <= min( M_sub, min(N_sel+KMAXFREE, N_sub) ). +*> +*> If K = 0, the arrays A, TAU were not modified. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified +*> and is itself a residual matrix, then MAXC2NRMK equals +*> the maximum column 2-norm of the original matrix A_sub. +*> +*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. +*> +*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no factorization residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K would equal +*> to the diagonal element R_sub(K+1,K+1) of the factor +*> R_sub in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when +*> factorization stopped at rank K) and maximum column 2-norm +*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). +*> RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub was not modified +*> and is itself a residual matrix, +*> then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M_sub,N_sub), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix +*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next +*> factorization step K+1, where R_sub(K+1,K+1) is the +*> diaginal element of the factor R_sub in the next +*> factorization step K+1. +*> \endverbatim +*> +*> \param[out] FNRMK +*> \verbatim +*> FNRMK is DOUBLE PRECISION +*> Frobenius norm of the factorization residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). +*> FNRMK >= 0.0 +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (M) +*> Row permutation indices due to row +*> deselection, for 1 <= i <= M. +*> If IPIV(i)= k, then the row i of A_sub was the +*> the row k of A. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column permutation indices, for 1 <= j <= N. +*> If JPIV(j)= k, then the column j of A*P was the +*> the column k of A. +*> +*> The first K elements of the array JPIV contain +*> indices of the factor C columns that were selected +*> from the matrix A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M_sub,N_sub)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= min(M_sub,N_sub), only elements TAU(1:K) of +*> the array TAU may be modified. The elements +*> TAU(K+1:min(M_sub,N_sub)) are set to zero. +*> If K = 0, all elements of TAU are set to zero. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array. +*> If FACT = 'P': +*> the array is not used and can have linear dimension >=1. +*> If FACT = 'C' or 'X': +*> If USESD = ’N’, the array dimension is (LDC,min(M,N)). +*> If USESD = 'C' or 'R' or 'A', +*> the array dimension (LDC,min(M_sub,N_sub)). +*> +*> If K = 0, the array is not used. +*> If K > 0, the array C stores the M-by-K factor C. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> If FACT = 'P', LDC >= 1. +*> If FACT = 'C' or 'X', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array. +*> If FACT = 'P' or 'C': array is not used +*> and can have linear dimension >=1. +*> If FACT = 'X': array has dimension (LDX,N). +*> If K = 0, the array is not used. +*> If K > 0, the array X stores the K-by-N factor X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> If FACT = 'P' or 'C': LDX >= 1. +*> If FACT = 'X': +*> If USESD = ’N’, LDX >= max(1,min(M,N)). +*> If USESD = 'C' or 'R' or 'A', +*> LDX >= max(1,min(M_sub,N_sub)). +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is DOUBLE PRECISION array. +*> If FACT = 'P' or 'C': +*> the array is not used and can have linear dimension >=1. +*> If FACT = 'X': +*> If USESD = ’N’, the array dimension is (LDQRC,min(M,N)), +*> If USESD = 'C' or 'R' or 'A', +*> the array dimension (LDC,min(M_sub,N_sub)). +*> +*> If K > 0, the array is not used. +*> If K > 0, QRC(1:M_sub,1:K) stores two components from +*> the QR factorization of the factor C. The K-by-K +*> factor R is stored in the upper triangle. +*> The Householder vectors are stored in the lower +*> trapezoid below the diagonal. +*> \endverbatim +*> +*> \param[in] LDQRC +*> \verbatim +*> LDQRC is INTEGER +*> The leading dimension of the array QRC. +*> If FACT = 'P', LDQRC >= 1. +*> If FACT = 'C' or 'X', LDQRC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)). +*> +*> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If FACT = 'P' or 'C': +*> minimal LWORK >= max( 1, NSUB, NSEL, 3*NFREE+1 ). +*> If FACT = 'X': +*> minimal LWORK >= max( 1, NSUB, 3*NFREE+1, min(M,N)+N ). +*> +*> For good performance, LWORK should generally be larger, and +*> the user should query the routine for the optimal LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK and IWORK arrays, +*> returns these values as the first entry of the WORK and IWORK +*> arrays respectively, and no error message related to LWORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N). +*> Is a work array. ( IWORK is used by DGEQP3RK to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine DLAQP3RK ). +*> +*> On exit, if INFO >= 0, WORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[out] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array LIWORK. +*> If FACT = 'P': minimal LIWORK >= max(1,N-1). +*> If FACT = 'C' or 'X': minimal LIWORK >= max(1,N). +*> Optimal LIWORK is the same as minimal LIWORK. +*> The user can still query the routine for the optimal LIWORK. +*> +*> If LIWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK and IWORK arrays, +*> returns these values as the first entry of the WORK and IWORK +*> arrays respectively, and no error message related to LIWORK +*> is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular R factor of the QR factorization of +*> the matrix C is zero, so that C does not have +*> full rank, X cannot be computed as the least +*> squares solution to C*X = A. +*> (R is stored in the array QRC.) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gecxx +* +* ===================================================================== + SUBROUTINE DGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER FACT, USESD + INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, + $ LDX, LIWORK, LWORK, M, N + DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, + $ RELMAXC2NRMK, FNRMK +* .. +* .. Array Arguments .. + INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), + $ JPIV( * ), SEL_DESEL_COLS( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), + $ TAU( * ), WORK( * ), X( LDX, *) +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, TWO, MINUSONE + PARAMETER ( ZERO = 0.0D+0, TWO = 2.0D+0, + $ MINUSONE = -1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LIQUERY, LQUERY, RETURNC, RETURNX, + $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL + INTEGER I, J, NSUB, MFREE, MSUB, MNSUB, NSEL, JDESEL, + $ ITEMP, IINFO, KP, KP0, KFREE, MRESID, NRESID, + $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, JP, JJ, JPW, + $ MINMN, MDESEL, NDESEL, NFREE + DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, + $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN + +* .. External Subroutines .. + EXTERNAL DLACPY, DGELS, DGEQP3RK, DGEQRF, DORMQR, + $ DSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN, LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 + EXTERNAL DISNAN, DLAMCH, DLANGE, DNRM2, IDAMAX, + $ ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MDESEL = 0 + NSEL = 0 + NDESEL = 0 + MSUB = M + NSUB = N + MFREE = MSUB + NFREE = NSUB +* + LQUERY = ( LWORK.EQ.-1 ) + LIQUERY = ( LIWORK.EQ.-1 ) +* + RETURNX = LSAME( FACT, 'X' ) + RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX +* + USE_DESEL_ROWS = LSAME( USESD, 'R' ) .OR. LSAME( USESD, 'A' ) + USE_SEL_DESEL_COLS = LSAME( USESD, 'C') .OR. LSAME( USESD, 'A' ) +* + IF ( .NOT.(RETURNC .OR. LSAME( FACT, 'P') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS + $ .OR. LSAME( USESD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + END IF +* +* This is to check that NSEL cannot be larger than MSUB. +* When the number of preselected columns is larger than MSUB, +* the factorization of all NSEL columns cannot be completed. +* MSUB also will be used for LDX argument check later. +* + IF( USE_DESEL_ROWS ) THEN +* +* Count the number of free rows MSUB. +* + DO I = 1, M + IF( DESEL_ROWS( I ).EQ.-1) MDESEL = MDESEL + 1 + END DO + MSUB = M - MDESEL + MFREE = MSUB + END IF +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Count the number of preselected columns NSEL and the +* number of preselected and freecolumns NSUB = N - NDESEL. +* + DO J = 1, N + IF( SEL_DESEL_COLS( J ).EQ.1) NSEL = NSEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.-1) NDESEL = NDESEL + 1 + END DO + NSUB = N - NDESEL + MFREE = MSUB - NSEL + NFREE = NSUB - NSEL +* + IF( NSEL.GT.MSUB ) THEN + INFO = -6 + END IF + END IF +* + IF( KMAXFREE.LT.0 ) THEN + INFO = -7 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -8 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF +* + IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN + INFO = -20 + ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN + INFO = -22 + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, MAX(MSUB, NSUB) ) ) .OR. + $ ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN + INFO = -24 + END IF +* +* ================================================================== +* +* a) Test the input workspace size LWORK and LIWORK for the +* minimum size requirement LWKMIN and LIWKMIN respectively. +* b) Determine the optimal workspace sizes LWKOPT LIWKOPT to be +* returned in WORK( 1 ) and IWORK( 1 ) respectively, +* if INFO >= 0 in cases: +* (1) LQUERY = .TRUE., +* (2) LIQUERY = .TRUE., +* (3) when the routine exits. +* Here, LWKMIN and LIWORK are the miminum workspaces required for +* unblocked code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + LIWKMIN = 1 + LIWKOPT = 1 + ELSE +* + IF( LSAME( USESD, 'N') ) THEN +* + LWKMIN = MAX( 1, 3*N + 1 ) +* +* Optimal workspace for column 2-norm computation. +* + LWKOPT = N +* +* Query for optimal workspace size for DGEQP3RK. +* + CALL DGEQP3RK( M, N, 0, N, + $ MINUSONE, MINUSONE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), + $ WORK, -1, IWORK, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* + LIWKMIN = MAX( 1, N-1 ) + LIWKOPT = LIWKMIN +* + IF( RETURNC ) THEN + LIWKMIN = MAX( LIWKOPT, N ) + LIWKOPT = LIWKMIN + END IF +* + IF( RETURNX ) THEN +* + LWKMIN = MAX( LWKMIN, MIN(M,N) + N ) +* +* Query for optimal workspace size for DGELS. +* + CALL DGELS( 'N', M, N, N, QRC, LDQRC, X, LDX, + $ WORK, -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) +* + END IF +* +* End IF( LSAME( USESD, 'N') ) +* + ELSE +* + LWKMIN = MAX( MAX( 1, NSUB ), 3*NFREE + 1 ) +* +* Optimal workspace for column 2-norm computation. +* + LWKOPT = NSUB +* +* Query for optimal workspace size for DGEQRF. +* + CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, -1, IINFO ) + LWKMIN = MAX( LWKMIN, NSEL ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* Query for optimal workspace size for DGEQP3RK. +* + CALL DGEQP3RK( MFREE, NFREE, 0, NFREE, + $ MINUSONE, MINUSONE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), + $ WORK, -1, IWORK, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* + LIWKMIN = MAX( 1, N-1 ) + LIWKOPT = LIWKMIN +* + IF( RETURNC ) THEN + LIWKMIN = MAX( LIWKOPT, N ) + LIWKOPT = LIWKMIN + END IF +* + IF( RETURNX ) THEN +* + LWKMIN = MAX( LWKMIN, MIN(M,N) + N ) +* +* Query for optimal workspace size for DGELS. +* + CALL DGELS( 'N', M, N, N, QRC, LDQRC, X, LDX, + $ WORK, -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) +* + END IF +* +* +* End of ELSE( LSAME( USESD, 'N') ) +* + END IF +* +* End of ELSE for IF( MINMN.EQ.0 ) +* + END IF +* + IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -26 + ELSE IF( ( LIWORK.LT.LIWKMIN ) .AND. .NOT.LIQUERY ) THEN + INFO = -28 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + IWORK( 1 ) = LIWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGECXX', -INFO ) + RETURN + ELSE IF( LQUERY.OR.LIQUERY) THEN + RETURN + END IF +* +* ================================================================== +* + K = 0 +* +* If we need to return factor C, copy the original untouched matrix +* A into the array C. +* + IF( RETURNC ) THEN + CALL DLACPY( 'F', M, N, A, LDA, C, LDC ) + END IF +* +* If we need to return factor X, copy the original unctouched matrix +* A into the array X. +* + IF( RETURNX ) THEN + CALL DLACPY( 'F', M, N, A, LDA, X, LDX ) + END IF +* +* ================================================================== +* Permute the deselected rows to the bottom of the matrix A. +* 1) Order of free rows is preserved. +* 2) Order of deselected rows is not preserved. +* ================================================================== +* +* I is the index of DESEL_ROWS array and row I +* of the matrix A. +* MFREE is the number of free rows, also the pointer to the last +* free row. +* (For each position I, we check if this position is a FREE row. +* If it is a FREE row we increment the MFREE pointer, otherwise we +* do not change the MFREE pointer. Also, if it is a FREE row, we move +* this row from the larger (or same) I index into samaller (or same) +* MFREE index. This way we move all the FREE rows to the lower index +* block preserving FREE row order. Deselected rows will be ) +* + IF( USE_DESEL_ROWS ) THEN +* + MFREE = 0 + DO I = 1, M, 1 +* +* Initialize row pivot array IPIV. + IPIV( I ) = I +* + IF( DESEL_ROWS(I).NE.-1 ) THEN + MFREE = MFREE + 1 +* +* This is the check whether the deselected row is +* on the deselected place already. +* + IF( I.NE.MFREE ) THEN +* +* Here, we swap A(I,1:N) into A(MFREE,1:N) +* + CALL DSWAP( N, A( I, 1 ), LDA, A( MFREE, 1 ), LDA ) + IPIV( I ) = IPIV( MFREE ) + IPIV( MFREE ) = I + ITEMP = DESEL_ROWS( I ) + DESEL_ROWS( I ) = DESEL_ROWS( MFREE ) + DESEL_ROWS( MFREE ) = ITEMP + END IF + END IF +* + END DO +* + ELSE +* +* We do not row deselection DESEL_ROWS array. +* Initialize row pivot array IPIV. +* + DO I = 1, M, 1 + IPIV( I ) = I + END DO +* + MFREE = M + END IF + MSUB = M +* +* ================================================================== +* Permute the pseselected columns to the left and deselected +* columns to the right of the matrix A. +* 1) Order of preselected columns is preserved. +* 2) Order of free columns is not preserved. +* 3) Order of deselected columns is not preserved. +* ================================================================== +* +* J is the index of SEL_DESEL_COLS array and column J +* of the matrix A. +* +* Column selection. +* NSEL is the number of selected columns, also the pointer to the last +* selected column. +* + NSEL = 0 + IF( USE_SEL_DESEL_COLS ) THEN +* + DO J = 1, N, 1 +* +* Initialize column pivot array JPIV. + JPIV( J ) = J +* + IF( SEL_DESEL_COLS(J).EQ.1 ) THEN + NSEL = NSEL + 1 +* +* This is the check whether the selected column is +* on the selected place already. +* + IF( J.NE.NSEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,NSEL) +* + CALL DSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) + JPIV( J ) = JPIV( NSEL ) + JPIV( NSEL ) = J + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) + SEL_DESEL_COLS( NSEL ) = 1 + END IF + END IF + END DO +* +* Column deselection. +* + JDESEL = N+1 + DO J = N, NSEL+1, -1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN + JDESEL = JDESEL - 1 +* +* This is the check whether the deselected column is +* on the deselected place already. +* + IF( J.NE.JDESEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) +* + CALL DSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) + ITEMP = JPIV( J ) + JPIV( J ) = JPIV( JDESEL ) + JPIV( JDESEL ) = ITEMP + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) + SEL_DESEL_COLS( JDESEL ) = -1 + END IF + END IF + END DO +* + NSUB = JDESEL - 1 +* + ELSE +* +* We do not column selection deselection SEL_DESEL_COLS array. +* Initialize column pivot array JPIV. +* + DO J = 1, N, 1 + JPIV( J ) = J + END DO +* + NSUB = N + END IF +* +* ================================================================== +* Compute the complete column 2-norms of the submatrix +* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). +* + DO J = 1, NSUB + WORK( J ) = DNRM2( MSUB, A( 1, J ), 1 ) + END DO +* +* Compute the column index of the maximum column 2-norm and +* the maximum column 2-norm itself for the submatrix +* A_sub = A(1:MSUB, 1:NSUB). +* + KP0 = IDAMAX( NSUB, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP0 ) +* +* ================================================================== +* Process preselected columns +* +* Compute the QR factorization of NSEL preselected columns (1:NSEL) +* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update +* remaining NFEE free columns (NSEL+1:NSUB). +* MSUB = MFREE, NSUB = MSEL + NFREE +* + MNSUB = MIN( MSUB, NSUB ) + MRESID = MSUB-NSEL + NRESID = NSUB-NSEL + IF( NSEL.GT.0 ) THEN +* (a) Case MSUB < NSEL. +* This is handled at the argument check stage in the begining +* of the routine. When the number of preselected columns +* is larger than MSUB, hence the factorization of all NSEL +* columns cannot be completed. Return from the routine with +* the error of COL_SEL_DESEL parameter. +* + IF( MSUB.EQ.NSEL.OR. + $ ( MSUB.GT.NSEL.AND.NSEL.EQ.NSUB )) THEN +* +* (b) Case MSUB = NSEL. +* (c-1) Case MSUB > NSEL and NSEL = NSUB. +* +* There will be no residual submatrix after factorization +* of NSEL columns at step K = NSEL: +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). +* Therefore, ther is no need to do the factorization of NSEL +* columns. Set norms to ZERO and return from the routine. +* + K = NSEL + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO +* +* Zero out TAU(K+1, MSUB) +* + DO J = K + 1, MNSUB + TAU( J ) = ZERO + END DO +* +* Go to the construction of the matrix C. +* + GO TO 10 + ELSE +* +* (c-2) Case MSUB > NSEL and NSEL < NSUB. +* +* There is a submatrix residual at step K=NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) +* +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL DORMQR( 'Left', 'Transpose', MSUB, NSUB-NSEL, NSEL, + $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, LWORK, IINFO ) +* +* Compute the complete column 2-norms of the submatrix +* residual at step NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) and +* store them in WORK(NSUB+NSEL+1:2*NSUB). +* + DO J = NSEL+1, NSUB + WORK( NSUB+J ) = DNRM2( MRESID, A( NSEL+1, J ), 1 ) + END DO +* +* Compute the column index and the maximum column 2-norm +* and the relative maximum column 2-norm for the submatrix +* residual. +* + KP = IDAMAX( NRESID, WORK( NSUB+NSEL+1 ), 1 ) +* + K = NSEL + MAXC2NRMK = WORK( NSUB + NSEL + KP ) + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* +* Test for the first, second and third tolerance stopping +* criteria after factorizarion of preselected columns. +* If any of them is met, return. Otherwise, +* proceed with factorization of the NFREE free columns. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* + IF( KMAXFREE.EQ.0 + $ .OR. MAXC2NRMK.LE.ABSTOL + $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* NOTE: In this (c-2) case. There is a submatrix +* residual A_sub_resid(NSEL). We do not need to have a check +* for MIN(MRESID, NRESID) = 0 to call DLANGE. +* + FNRMK = DLANGE( 'F', MRESID, NRESID, A(NSEL+1,NSEL+1), + $ LDA, WORK ) +* +* Zero out TAU(K+1, MSUB) +* + DO J = K + 1, MNSUB + TAU( J ) = ZERO + END DO +* +* Go to the construction of the matrix C. +* + GO TO 10 + END IF +* + END IF +* +* End of IF(NSEL.GT.0) +* + END IF +* +* ================================================================== +* +* Factorize NFREE free columns of +* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), +* KFREE is the number of columns that were actually factorized among +* NFREE columns. +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL only if nonnegative. Negative value means disabled. +* We need to keep negtive value for later use in criterion +* check. +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Ajust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negtive value for later use in criterion +* check. +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* +* Disable RELTOLFREE when calling DGEQP3RK for free columns +* factorization, since it expects RELTOLFREE with respect to +* the residual matrix A_sub_resid(NSEL), not the whole original +* marix A. We can use RELTOL criterion by passing it to +* ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that +* the negative values of ABSTOL and RELTOL are propagated +* to ABSTOLFREE and RELTOLFREE, since negative vaslues means +* that the criterionis is disabled. +* + IF( USETOL ) THEN + ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) + ELSE + ABSTOLFREE = MINUSONE + END IF + RELTOLFREE = MINUSONE +* + CALL DGEQP3RK( MRESID, NRESID, 0, KMAXFREE, + $ ABSTOLFREE, RELTOLFREE, + $ A( K+1, K+1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( K+1 ), TAU( K+1 ), + $ WORK, LWORK, IWORK, IINFO ) +* +* 1) Adjust the return value for the number of factorized +* columns K for the whole submatrix A_sub. +* 2) MAXC2NRMK is returned transparently without change +* as MAXC2NRMKFREE is returned from DGEQP3RK. +* 3) Adjust the return value RELMAXC2NRMK for the whole +* submatrix A_sub. We do not use RELMAXC2NRMKFREE +* returned from DGEQP3RK. +* + K = K + KFREE + MAXC2NRMK = MAXC2NRMKFREE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* +* Now, MRESID and NRESID is the number of rows and columns +* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). +* + MRESID = MRESID-KFREE + NRESID = NRESID-KFREE + IF( MIN( MRESID, NRESID ).NE.0 ) THEN + FNRMK = DLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), + $ LDA, WORK ) + ELSE + FNRMK = ZERO + END IF +* +* Construct matrix C. +* + 10 CONTINUE +* + IF( RETURNC .AND. K.GT.0 ) THEN +* +* Apply interchanges to columns 1:K in the matrix C in place, +* which stores the original matrix A. +* IWORK(1:N) is used to keep track of original column indices, +* when swaping columns. +* + DO J = 1, N, 1 + IWORK( J ) = J + END DO + DO J = 1, K, 1 + JP = JPIV( J ) + IF( J.NE.JP ) THEN + DO JJ = J, N, 1 + IF( JP.EQ.IWORK( JJ ) ) THEN + JPW = JJ + END IF + END DO + IF( J.NE.JPW ) THEN + CALL DSWAP( M, C( 1, J ), 1, C( 1, JPW ), 1 ) + ITEMP = IWORK( J ) + IWORK( J ) = IWORK( JPW ) + IWORK( JPW ) = ITEMP + END IF + END IF + END DO +* + END IF +* +* Return matrix X. +* + IF( RETURNX .AND. K.GT.0 ) THEN +* +* We need to use C and A to compute X = pseudoinv(C) * A, as +* the Linear Least Squares problem C*X = A. We use LLS routine +* that uses QR factorization. For that purpose, we store +* the matrix C into the arrray QRC, and the matrix A was copied +* into the array X at the begining of the routine. +* + CALL DLACPY( 'F', M, K, C, LDC, QRC, LDQRC ) +* + CALL DGELS( 'N', M, K, N, QRC, LDQRC, X, LDX, + $ WORK, LWORK, IINFO ) + INFO = IINFO + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) + IWORK( 1 ) = LIWKOPT +* +* DGECXX +* + END From 3497aaae889fa0c776af62ee3dead559197335d3 Mon Sep 17 00:00:00 2001 From: Igor Date: Thu, 11 Dec 2025 06:55:25 -0800 Subject: [PATCH 07/63] Edited leading comments in dgecxx.f --- SRC/dgecxx.f | 533 +++++++++++++++++++++++++++------------------------ 1 file changed, 282 insertions(+), 251 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 3ba1c52f8..b8b55b07e 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -1,4 +1,4 @@ -*> \brief \b DGECXX computes a CX factorization of a real M-by-N matrix A using a truncated (rank k) Householder QR factorization with column pivoting algorithm. +*> \brief \b DGECXX computes a CX factorization of a real M-by-N matrix A using a truncated (rank k) Householder QR factorization with column pivoting. * * =========== DOCUMENTATION =========== * @@ -6,7 +6,7 @@ * http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DGEQP3RK + dependencies +*> Download DGECXX + dependencies *> *> [TGZ] *> @@ -45,52 +45,52 @@ *> \verbatim *> *> DGECXX computes a CX factorization of a real M-by-N matrix A using -*> a truncated (rank k) Householder QR factorization with column -*> pivoting algorithm implemented in DGEQP3RK routine. +*> a truncated rank-K Householder QR factorization with a column +*> pivoting algorithm, which is implemented in the DGEQP3RK routine. *> -*> A * P(K) = C*X + A_resid, where +*> A * P = C*X + A_resid, where *> -*> C is an M-by-K matrix which is a subset of K columns selected +*> C is an M-by-K matrix consisting of K columns selected *> from the original matrix A, *> *> X is a K-by-N matrix that minimizes the Frobenius norm of the *> residual matrix A_resid, X = pseudoinv(C) * A, *> -*> P(K) is an N-by-N permutation matrix chosen so that the first -*> K columns of A*P(K) equal C, +*> P is an N-by-N permutation matrix chosen so that the first +*> K columns of A*P equal C, *> *> A_resid is an M-by-N residual matrix. *> *> The column selection for the matrix C has two stages. *> -*> Column selection stage 1. -*> ========================= +*> Column preselection stage 1. +*> ============================ *> *> The user can select N_sel columns and deselect N_desel columns *> of the matrix A that MUST be included and excluded respectively *> from the matrix C a priori, before running the column selection -*> algorithm. This is controlled by the flags in the array +*> algorithm. This is controlled by flags in the array *> SEL_DESEL_COLS. The deselected columns are permuted to the right -*> side of the array A and selected columns are permuted to the left -*> side of the array A. The details of the column permutation -*> (i.e. the column permutation matrix P(K)) are stored in the +*> side of the matrix A and selected columns are permuted to the left +*> side of the matrix A. The details of the column permutation +*> (i.e. the column permutation matrix P) are stored in the *> array JPIV. This feature can be used when the goal is to approximate *> the deselected columns by linear combinations of K selected columns, -*> where the K columns MUST include the N_sel selected columns. +*> where the K columns MUST include the N_sel preselected columns. *> *> Column selection stage 2. *> ========================= *> -*> The routine runs the column selection algorithm that can -*> be controlled with three stopping criteria described below. -*> For the column selection, the routine uses a truncated (rank K) +*> The routine runs a column selection algorithm that can +*> be controlled by three stopping criteria described below. +*> For column selection, the routine uses a truncated (rank-K) *> Householder QR factorization with column pivoting algorithm using -*> DGEQP3RK routine. Note, that before running the column selection +*> the routine DGEQP3RK. Note that before running the column selection *> algorithm, the user can deselect M_desel rows of the matrix A that *> should NOT be considered by the column selection algorithm (i.e. -*> during the factorization). This is controlled by the flags in +*> during the factorization). This is controlled by flags in *> the array DESEL_ROWS. The deselected rows are permuted to the -*> bottom of the array A. The details of the row permutation (i.e. the +*> bottom of the matrix A. The details of the row permutation (i.e. the *> row permutation matrix) are stored in the array IPIV. This feature *> can be used when the goal is to use the deselected rows as test data, *> and the selected rows as training data. @@ -109,56 +109,57 @@ *> The column selection criteria (i.e. when to stop the factorization) *> can be any of the following: *> -*> 1) The input parameter KMAXFREE, the maximum number of columns -*> to factorize outside of the N_sel preselected columns, -*> i.e. the factorization rank is limited to N_sel + KMAXFREE. -*> If N_sel + KMAXFREE >= min(M_sub, N_sub), the criterion +*> 1) KMAXFREE: This input parameter specifies the maximum number of +*> columns to factorize outside of the N_sel preselected columns. +*> The factorization rank is limited to N_sel + KMAXFREE. +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), this criterion *> is not used. *> -*> 2) The input parameter ABSTOL, the absolute tolerance for -*> the maximum column 2-norm of the submatrix residual -*> A_sub_resid = A(K+1:M_sub, K+1:N_sub). +*> 2) ABSTOL: This input parameter specifies the absolute tolerance +*> for the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub). *> This means that the factorization stops if this norm is less -*> or equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> than or equal to ABSTOL. If ABSTOL < 0.0, this criterion is +*> not used. *> -*> 3) The input parameter RELTOL, the tolerance for the maximum -*> column 2-norm matrix of the submatrix residual +*> 3) RELTOL: This input parameter specifies the tolerance for +*> the maximum column 2-norm of the submatrix residual *> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub) divided *> by the maximum column 2-norm of the submatrix *> A_sub = A(1:M_sub, 1:N_sub). *> This means that the factorization stops when the ratio of the -*> maximum column 2-norm of A_sub_resid to the maximum column +*> maximum column 2-norm of A_sub_resid(K) to the maximum column *> 2-norm of A_sub is less than or equal to RELTOL. -*> If RELTOL < 0.0, the criterion is not used. +*> If RELTOL < 0.0, this criterion is not used. *> *> The algorithm stops when any of these conditions is first -*> satisfied, otherwise the whole submatrix A_sub is factorized. +*> satisfied, otherwise the entire submatrix A_sub is factorized. *> -*> For a full rank factorization of the matrix A_sub, use selection -*> criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) and -*> ABSTOL < 0.0 and RELTOL < 0.0. +*> To perform a full-rank factorization of the matrix A_sub, use +*> selection criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) +*> and ABSTOL < 0.0 and RELTOL < 0.0. *> -*> If the user wants to verify whether the columns of the matrix C are +*> If the user wishes to verify that the columns of the matrix C are *> sufficiently linearly independent for their intended use, the user *> can compute the condition number of its R factor by calling DTRCON -*> on the upper-triangular part of QRC(1:K,1:K) of the output -*> array QRC. +*> on the upper-triangular part of QRC(1:K,1:K) in the output +*> array QRC. *> *> How N_sel affects the column selection algorithm. *> ================================================= *> -*> As mentioned above, the N_sel selected columns are permuted to the -*> right side of the array A, and will be included in the column -*> selection. Then the routine runs the factorization of that block -*> A(1:M_sub,1:N_sel), and if any of the three stopping criteria is met -*> immediately after factoring the first N_sel columns the routine exits +*> As mentioned above, the N_sel preselected columns are permuted to the +*> left side of the matrix A, and will be included in the column +*> selection. Then the routine factorizes that block A(1:M_sub,1:N_sel), +*> and if any of the three stopping criteria is met immediately after +*> factoring the first N_sel columns the routine exits *> (i.e. the user does not want to select KMAXFREE extra columns, or *> if the absolute or relative tolerance of the maximum column 2-norm of *> the residual is satisfied). In this case, the number *> of selected columns would be K = N_sel. Otherwise, the factorization *> routine finds a new column to select with the maximum column 2-norm *> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and permutes that -*> column to the right side of A(1:M,N_sel+1:N_sub). Then the routine +*> column to the left side of A(1:M,N_sel+1:N_sub). Then the routine *> checks if the stopping criteria are met in the next residual *> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. *> @@ -167,13 +168,13 @@ *> *> When the columns are selected for the factor C, and: *> (a) If the flag FACT = 'P', the routine returns only the indices of -*> the selected columns from the original matrix A that are stored -*> in the JPIV array as the first K elements. +*> the selected columns from the original matrix A, which are +*> stored in the first K elements of the JPIV array. *> (b) If the flag FACT = 'C', then in addition to (a), the routine *> explicitly returns the matrix C in the array C. *> (c) If the flag FACT = 'X', then in addition to (b), the routine *> explicitly computes and returns the factor -*> X = pseudoinv(C) * A in the array X, and it returns +*> X = pseudoinv(C) * A in the array X, and it also returns *> the factor R alongside the Householder vectors *> of the QR factorization of the matrix C in the array QRC. *> @@ -185,57 +186,60 @@ *> \param[in] FACT *> \verbatim *> FACT is CHARACTER*1 -*> Specifies how the factors of a CX factorization +*> The flag specifies how the factors of a CX factorization *> are returned. *> -*> = 'P' or 'p' : return only the column permutation matrix P -*> in the array JPIV. The first K elements -*> of the array JPIV contain indices of -*> the factor C columns that were selected -*> from the matrix A. -*> (fastest, smallest memory space) -*> -*> = 'C' or 'c' : return the column permutation matrix P -*> in the array JPIV and the factor C -*> explicitly in the array C -*> (slower, more memory space) -*> -*> = 'X' or 'x' : return the column permutation matrix P -*> in the array JPIV, and both factors -*> C and X explicitly in the arrays -*> C and X respectively. In addition, -*> the factor R and the Householder vectors -*> of the QR factorization of the factor C -*> are returned in the array QRC. -*> (R factor may be useful for checking -*> the factor C for singularity (R will -*> have zero on the diagonal), and in this -*> case the factor X cannot be computed.) -*> (slowest, largest memory space) +*> = 'P': the routine returns: +*> (1) only the column permutation matrix P in +*> the array JPIV. +*> ( The first K elements of the array JPIV +*> contain indices of the columns that were +*> selected from the matrix A to form the +*> factor C. ) +*> (fastest option, smallest memory space) +*> +*> = 'C': the routine returns: +*> (1) the column permutation matrix P +*> in the array JPIV. +*> (2) the factor C explicitly in the array C. +*> (slower option, more memory space) +*> +*> = 'X': the routine returns: +*> (1) the column permutation matrix P in +*> the array JPIV. +*> (2) the factor C explicitly in the array C. +*> (3) the factor X explicitly in the array X. +*> (4) the factor R and the Householder vectors +*> of the QR factorization of the factor C +*> in the array QRC. +*> ( The factor R may be useful for checking +*> the factor C for singularity, in which case +*> R will have a zero on the diagonal, and +*> the factor X cannot be computed. ) +*> (slowest option, largest memory space) *> \endverbatim *> *> \param[in] USESD *> \verbatim *> USESD is CHARACTER*1 -*> Specifies if row deselection and column +*> The flag specifies whether the row deselection and column *> preselection-deselection functionality is turned ON or OFF. *> -*> = 'N' or 'n' : Both row deselection and column -*> preselection-deselection are OFF. -*> Both arrays DESEL_ROWS and -*> SEL_DESEL_COLS are not used. +*> = 'N': Both row deselection and column +*> preselection-deselection are OFF. +*> Both arrays DESEL_ROWS and SEL_DESEL_COLS +*> are not used. *> -*> = 'R' or 'r' : Only row deselection is ON. -*> Column preselection-deselection is OFF. -*> The array SEL_DESEL_COLS is not used. +*> = 'R': Only row deselection is ON. +*> Column preselection-deselection is OFF. +*> Only the array SEL_DESEL_COLS is not used. *> -*> = 'C' or 'c' : Only column preselection-deselection is ON. -*> Row deselection is OFF. -*> The array DESEL_ROWS is not used. +*> = 'C': Only column preselection-deselection is ON. +*> Row deselection is OFF. +*> Only the array DESEL_ROWS is not used. *> -*> = 'A' or 'a' : Means "All". -*> Both row deselection and column -*> preselection-deselection are ON. +*> = 'A': Means "All". Both row deselection and column +*> preselection-deselection are ON. *> \endverbatim *> *> \param[in] M @@ -253,31 +257,38 @@ *> \param[in] DESEL_ROWS *> \verbatim *> DESEL_ROWS is INTEGER array, dimension (M) +*> DESEL_ROWS is only accessed, if USESD = 'R' or 'A'. *> This is a row deselection mask array that separates -*. the matrix A rows into 2 sets. +*> the matrix A rows into 2 sets. *> *> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is *> deselected by the user, i.e. chosen to be excluded from -*. the algorithm and will be permuted to the bottom of A. -*> The number of deselected rows is denoted by M_desel. +*> the column selection algorithm (in both preselection and +*> selection stages) and will be permuted to the bottom +*> of the matrix A. +*> The number of deselected rows is denoted by M_desel. *> -*> b) If DESEL_ROWS(i) not equal -1, -*> the i-th row of A is a free row and will be used by the -*> algorithm. This defines a set of M_sub = M - M_desel -*> rows that the algorithm will work on. After permutation, -*> this set will be in the top of the matrix A. +*> b) If DESEL_ROWS(i) is not equal -1, +*> the i-th row of A will be used in the column selection +*> algorithm (in both preselection and selection stages). +*> This defines a set of M_sub = M - M_desel rows that +*> the algorithm will use to select columns. +*> After the permutation, this set will be at the top +*> of the matrix A. *> \endverbatim *> *> \param[in] SEL_DESEL_COLS *> \verbatim *> SEL_DESEL_COLS is INTEGER array, dimension (N) -*> This is a column preselection/deselection mask array that -*. separates the matrix A columns into 3 sets. +*> SEL_DESEL_COLS is only accessed, if USESD = 'C' or 'A'. +*> This is a column preselection-deselection mask array that +*> separates the matrix A columns into 3 sets. *> *> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix -*> A is selected by the user to be included in the factor C -*> and will be permuted to the left side of the array A. -*> The number of selected columns is denoted by N_sel. +*> A is preselected by the user to be included +*> in the factor C and will be permuted to the left side +*> of the array A. The number of selected columns is +*> denoted by N_sel. *> *> b) If SEL_DESEL_COLS(j) = -1, the j-th column of the matrix *> A is deselected by the user, i.e. chosen to be excluded @@ -285,118 +296,135 @@ *> of the array A. The number of deselected columns is *> denoted by N_desel. *> -*> c) If SEL_DESEL_COLS(j) not equal 1, and not equal -1, -*> the j-th column of A is a free column and will be used by -*> the algorithm to determine if this column has to be -*> selected. This defines a set of -*> N_free = N - N_sel - N_desel. +*> c) If SEL_DESEL_COLS(j) is not equal 1 and not equal -1, +*> the j-th column of A is a free column and will be used +*> by the column selection algorithm to determine if this +*> column will be selected. This defines a set of +*> columns of size N_free = N - N_sel - N_desel. *> -*> NOTE: Error returned as INFO = -6 means that the number of -*> preselected N_sel colunms is larger than M_sub. +*> NOTE: An error returned as INFO = -6 means that the number +*> of preselected N_sel columns is larger than M_sub. *> Therefore, the QR factorization of all N_sel preselected *> columns cannot be completed. *> \endverbatim *> *> \param[in] KMAXFREE *> \verbatim -*> KMAXFREE is INTEGER +*> KMAXFREE is INTEGER, KMAXFREE >= 0. *> -*> The first column selection stopping criterion in the -*> column selection stage 2. +*> The first column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. *> -*> The maximum number of columns of the matrix A_sub to select -*> during the factorization stage, KMAXFREE >= 0. +*> KMAXFREE is the maximum number of columns of the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) to select +*> during the column selection stage 2. *> -*> KMAXFREE does not include the preselected columns. +*> KMAXFREE does not include the preselected N_sel columns. *> N_sel + KMAXFREE is the maximum factorization rank of -*> the matrix A_sub = A(1:M_sub, 1:N_sub). +*> the matrix A_sub. *> *> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this -*> stopping criterion is not used, i.e. columns are selected -*> in the factorization stage depending on -*> ABSTOL and RELTOL. +*> stopping criterion is not used, i.e. columns are +*> selected in the factorization stage 2 depending +*> on ABSTOL and RELTOL. *> *> b) If KMAXFREE = 0, then this stopping criterion is -*> satisfied on input and the routine exits without -*> performing column selection stage 2 on the submatrix -*> A_sub. This means that the matrix -*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified. -*> and A_free is itself the residual for the factorization. +*> satisfied on input and the routine exits without +*> performing column selection stage 2 +*> on the submatrix A_sub. This means that the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified. +*> and A_free is itself the residual for the factorization. *> \endverbatim *> *> \param[in] ABSTOL *> \verbatim *> ABSTOL is DOUBLE PRECISION, cannot be NaN. *> -*> The second column selection stopping criterion in the -*> column selection stage 2. -*> -*> Here, SAFMIN = DLAMCH('S'). +*> The second column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. *> -*> The absolute tolerance (stopping threshold) for -*> maximum column 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), -*> when K columns were factorized. -*> The algorithm converges (stops the factorization) when -*> the maximum column 2-norm of the residual matrix -*> A_sub_resid is less than or equal to ABSTOL. +*> ABSTOL is the absolute tolerance (stopping threshold) +*> for maxcol2norm(A_sub_resid(K)), where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> The column selection algorithm converges (stops +*> the factorization) when +*> maxcol2norm(A_sub_resid(K)) <= ABSTOL, where K >= N_sel. +*> +*> Here, SAFMIN = DLAMCH('S'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> maxcol2norm(A_free) is the maximum column 2-norm +*> of the matrix A_free. *> *> a) If ABSTOL is NaN, then no computation is performed *> and an error message ( INFO = -8 ) is issued *> by XERBLA. *> *> b) If ABSTOL < 0.0, then this stopping criterion is not -*> used, factorize columns depending on KMAXFREE -*> and RELTOL. -*> This includes the case ABSTOL = -Inf. +*> used, and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and RELTOL. +*> This includes the case where ABSTOL = -Inf. *> *> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN -*> is used. This includes the case ABSTOL = -0.0. +*> is used. This includes the case where ABSTOL = -0.0. *> *> d) If 2*SAFMIN <= ABSTOL then the input value *> of ABSTOL is used. *> -*> Here, maxcol2norm(A_free) is the maximum column 2-norm -*> of the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). -*> *> If ABSTOL chosen above is >= maxcol2norm(A_free), then -*> this stopping criterion is satisfied after the matrix -*> A_sel = A(1:M_sub, 1:N_sel) is factorized and the -*> routine exits immediately after maxcol2norm(A_free) is -*> computed to return it in MAXC2NORMK. This means that -*> the factorization residual -*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) -*> is not modified. -*> Also RELMAXC2NORMK of A_free is returned. -*> This includes the case ABSTOL = +Inf. +*> this stopping criterion is satisfied on input, and +*> the routine only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. The routine +*> then computes maxcol2norm(A_free) and returns it +*> in MAXC2NORMK, computes and returns RELMAXC2NORMK of A_free, +*> and exits immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified. +*> This includes the case where ABSTOL = +Inf. *> \endverbatim *> *> \param[in] RELTOL *> \verbatim *> RELTOL is DOUBLE PRECISION, cannot be NaN. *> -*> The third column selection stopping criterion in the -*> column selection stage 2. +*> The third column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> RELTOL is the tolerance (stopping threshold) for the ratio +*> relmaxcol2norm(A_sub_resid(K)) = +*> = maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub), +*> where K >= N_sel. *> -*> Here, EPS = DLAMCH('E'). +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> maxcol2norm(A_sub) is the maximum column 2-norm +*> of the original submatrix A_sub = A(1:M_sub, 1:N_sub). +*> The column selection algorithm converges +*> (stops the factorization) when the ratio +*> relmaxcol2norm(A_sub_resid(K)) <= RELTOL, where K >= N_sel. *> -*> The tolerance (stopping threshold) for the ratio -*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) of -*> the maximum column 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) and -*> the maximum column 2-norm of the original submatrix -*> A_sub = A(1:M_sub, 1:N_sub). The algorithm -*> converges (stops the factorization), when -*> maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub) is -*> less than or equal to RELTOL. +*> Here, EPS = DLAMCH('E'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). *> *> a) If RELTOL is NaN, then no computation is performed *> and an error message ( INFO = -9 ) is issued *> by XERBLA. *> *> b) If RELTOL < 0.0, then this stopping criterion is not -*> used, factorize columns depending on KMAXFREE -*> and ABSTOL. +*> used and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and ABSTOL. *> This includes the case RELTOL = -Inf. *> *> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. @@ -406,19 +434,20 @@ *> is used. *> *> If RELTOL chosen above is >= 1.0, then this stopping -*> criterion is satisfied on input and routine exits -*> immediately after A_sel = A(1:M_sub, 1:N_sel)) -*> is factorized and maxcol2norm(A_free) is computed to -*> return it in MAXC2NORMK. This means that -*> the factorization residual -*> A_sub_resid = A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) +*> criterion is satisfied on input, and the routine +*> only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. +*> The routine then computes maxcol2norm(A_free) and returns +*> it in MAXC2NORMK, returns RELMAXC2NORMK as 1.0, and exits +*> immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) *> is not modified. -*> Also RELMAXC2NORMK is returned as 1.0. *> This includes the case RELTOL = +Inf. *> *> NOTE: We recommend RELTOL to satisfy *> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL -*> *> \endverbatim *> *> \param[in,out] A @@ -429,60 +458,60 @@ *> the M-by-N matrix A. *> *> On exit: -*> NOTE DEFINITIONS: M_sub = M_free, -*> N_sub = N_sel + N_free *> -*> The output parameter K, the number of selected columns, -*> is described later. +*> NOTE: +*> The output parameter K, the number of selected +*> columns, is described later. +*> A_sub = A(1:M_sub, 1:N_sub). *> *> 1) If K = 0, A(1:M,1:N) contains the original matrix A. *> -*> 2) If K > 0, A(1:M,1:N): contains the following parts: +*> 2) If K > 0, A(1:M,1:N) contains the following parts: *> *> (a) If M_sub < M (which is the same as M_desel > 0), -*> the subarray A(M_sub+1:M,1:N) contains the deselected -*> rows. +*> the subarray A(M_sub+1:M,1:N) contains the deselected +*> rows. *> -*> (b) If N_sub < N ( which is the same as N_desel > 1 ). -*> the subarray A(1:M,N_sub+1:N) contains the -*> deselected columns. +*> (b) If N_sub < N ( which is the same as N_desel > 0 ), +*> the subarray A(1:M,N_sub+1:N) contains the +*> deselected columns. *> *> (c) If N_sel > 0, -*> the union of the subarray A(1:M_sub, 1:N_sel) -*> and the subarray A(1:N_sel, 1:N_sub) contains parts -*> of the factors obtained by computing Householder QR -*> factorization WITHOUT column pivoting of N_sel -*> preselected columns using DGEQRF routine. +*> the union of the subarray A(1:M_sub, 1:N_sel) +*> and the subarray A(1:N_sel, 1:N_sub) contains parts +*> of the factors obtained by computing Householder QR +*> factorization WITHOUT column pivoting of N_sel +*> preselected columns using the routine DGEQRF. *> -*> (d) The subarray A(N_sel:M_sub, N_sel:N_sub) contains -*> parts of the factors obtained by computing a truncated -*> (rank K) Householder QR factorization with -*> column pivoting using DGEQP3RK on the matrix -*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) which -*> is the result of applying selection and deselection -*> of columns, applying deselection of rows to the -*> original matrix A, and applying orthogonal -*> transformation from the factorization of the first -*> N_sel columns as described in part (c). -*> -*> 1. The elements below the diagonal of the subarray -*> A_sub(1:M_sub,1:K) together with TAU(1:K) -*> represent the orthogonal matrix Q(K) as a -*> product of K Householder elementary reflectors. -*> -*> 2. The elements on and above the diagonal of -*> the subarray A_sub(1:K,1:N_sub) contain -*> K-by-N_sub upper-trapezoidal matrix -*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). -*> NOTE: If K=min(M_sub,N_sub), i.e. full rank -*> factorization, then R_sub_approx(K) is the -*> full factor R which is upper-trapezoidal. -*> If, in addition, M_sub>=N_sub, then R is -*> upper-triangular. -*> -*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains -*> (M_sub-K)-by-(N_sub-K) rectangular matrix -*> A_sub_resid(K). +*> (d) The subarray A(N_sel+1:M_sub, N_sel+1:N_sub) +*> contains parts of the factors obtained by computing +*> a truncated (rank K) Householder QR factorization with +*> column pivoting using the routine DGEQP3RK on +*> the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> which is the result of applying selection and +*> deselection of columns, applying deselection of rows +*> to the original matrix A, and applying orthogonal +*> transformation from the factorization of the first +*> N_sel columns as described in part (c). +*> +*> 1. The elements below the diagonal of the subarray +*> A_sub(1:M_sub,1:K) together with TAU(1:K) +*> represent the orthogonal matrix Q(K) as a +*> product of K Householder elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A_sub(1:K,1:N_sub) contain the +*> K-by-N_sub upper-trapezoidal matrix +*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). +*> NOTE: If K = min(M_sub,N_sub), i.e. full rank +*> factorization, then R_sub_approx(K) is the +*> full factor R which is upper-trapezoidal. +*> If, in addition, M_sub >= N_sub, then R is +*> upper-triangular. +*> +*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains +*> the (M_sub-K)-by-(N_sub-K) rectangular matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). *> \endverbatim *> *> \param[in] LDA @@ -494,8 +523,8 @@ *> \param[out] K *> \verbatim *> K is INTEGER -*> The number of columns that were selected. -*> (K is the factorization rank) +*> The number of columns that were selected +*> (K is the factorization rank). *> 0 <= K <= min( M_sub, min(N_sel+KMAXFREE, N_sub) ). *> *> If K = 0, the arrays A, TAU were not modified. @@ -516,10 +545,10 @@ *> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. *> *> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was -*> factorized and there is no factorization residual matrix, +*> factorized and there is no residual matrix, *> then MAXC2NRMK = 0.0. *> -*> NOTE: MAXC2NRMK at the factorization step K would equal +*> NOTE: MAXC2NRMK at the factorization step K is equal *> to the diagonal element R_sub(K+1,K+1) of the factor *> R_sub in the next factorization step K+1. *> \endverbatim @@ -527,9 +556,9 @@ *> \param[out] RELMAXC2NRMK *> \verbatim *> RELMAXC2NRMK is DOUBLE PRECISION -*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column -*> 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when +*> The ratio MAXC2NRMK / MAXC2NRM +*> of the maximum column 2-norm MAXC2NRMK of the residual +*> matrix A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when *> factorization stopped at rank K) and maximum column 2-norm *> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). *> RELMAXC2NRMK >= 0. @@ -549,14 +578,14 @@ *> NOTE: RELMAXC2NRMK at the factorization step K would equal *> abs(R_sub(K+1,K+1))/MAXC2NRM in the next *> factorization step K+1, where R_sub(K+1,K+1) is the -*> diaginal element of the factor R_sub in the next +*> diagonal element of the factor R_sub in the next *> factorization step K+1. *> \endverbatim *> *> \param[out] FNRMK *> \verbatim *> FNRMK is DOUBLE PRECISION -*> Frobenius norm of the factorization residual matrix +*> Frobenius norm of the residual matrix *> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). *> FNRMK >= 0.0 *> \endverbatim @@ -564,9 +593,9 @@ *> \param[out] IPIV *> \verbatim *> IPIV is INTEGER array, dimension (M) -*> Row permutation indices due to row -*> deselection, for 1 <= i <= M. -*> If IPIV(i)= k, then the row i of A_sub was the +*> Row permutation indices due to row deselection, +*> for 1 <= i <= M. +*> If IPIV(i)= k, then the row i of A_sub was *> the row k of A. *> \endverbatim *> @@ -574,11 +603,11 @@ *> \verbatim *> JPIV is INTEGER array, dimension (N) *> Column permutation indices, for 1 <= j <= N. -*> If JPIV(j)= k, then the column j of A*P was the +*> If JPIV(j)= k, then the column j of A*P (and of A_sub) was *> the column k of A. *> *> The first K elements of the array JPIV contain -*> indices of the factor C columns that were selected +*> indices of the columns of the factor C that were selected *> from the matrix A. *> \endverbatim *> @@ -597,9 +626,9 @@ *> \verbatim *> C is DOUBLE PRECISION array. *> If FACT = 'P': -*> the array is not used and can have linear dimension >=1. +*> the array is not used, the array dimension >= (1,1). *> If FACT = 'C' or 'X': -*> If USESD = ’N’, the array dimension is (LDC,min(M,N)). +*> If USESD = 'N', the array dimension is (LDC,min(M,N)). *> If USESD = 'C' or 'R' or 'A', *> the array dimension (LDC,min(M_sub,N_sub)). *> @@ -618,9 +647,10 @@ *> \param[out] X *> \verbatim *> X is DOUBLE PRECISION array. -*> If FACT = 'P' or 'C': array is not used -*> and can have linear dimension >=1. -*> If FACT = 'X': array has dimension (LDX,N). +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> If FACT = 'X': +*> The array dimension is (LDX,N). *> If K = 0, the array is not used. *> If K > 0, the array X stores the K-by-N factor X. *> \endverbatim @@ -631,7 +661,7 @@ *> The leading dimension of the array X. *> If FACT = 'P' or 'C': LDX >= 1. *> If FACT = 'X': -*> If USESD = ’N’, LDX >= max(1,min(M,N)). +*> If USESD = 'N', LDX >= max(1,min(M,N)). *> If USESD = 'C' or 'R' or 'A', *> LDX >= max(1,min(M_sub,N_sub)). *> \endverbatim @@ -639,14 +669,15 @@ *> \param[out] QRC *> \verbatim *> QRC is DOUBLE PRECISION array. -*> If FACT = 'P' or 'C': -*> the array is not used and can have linear dimension >=1. +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). *> If FACT = 'X': -*> If USESD = ’N’, the array dimension is (LDQRC,min(M,N)), +*> If USESD = 'N', +*> the array dimension is (LDQRC,min(M,N)). *> If USESD = 'C' or 'R' or 'A', -*> the array dimension (LDC,min(M_sub,N_sub)). +*> the array dimension is (LDC,min(M_sub,N_sub)). *> -*> If K > 0, the array is not used. +*> If K = 0, the array is not used. *> If K > 0, QRC(1:M_sub,1:K) stores two components from *> the QR factorization of the factor C. The K-by-K *> factor R is stored in the upper triangle. @@ -674,9 +705,9 @@ *> LWORK is INTEGER *> The dimension of the array WORK. *> If FACT = 'P' or 'C': -*> minimal LWORK >= max( 1, NSUB, NSEL, 3*NFREE+1 ). +*> the minimal LWORK >= max( 1, NSUB, NSEL, 3*NFREE+1 ). *> If FACT = 'X': -*> minimal LWORK >= max( 1, NSUB, 3*NFREE+1, min(M,N)+N ). +*> the minimal LWORK >= max( 1, NSUB, 3*NFREE+1, min(M,N)+N ). *> *> For good performance, LWORK should generally be larger, and *> the user should query the routine for the optimal LWORK. @@ -695,16 +726,16 @@ *> of "bad" columns for norm downdating in the residual *> matrix in the blocked step auxiliary subroutine DLAQP3RK ). *> -*> On exit, if INFO >= 0, WORK(1) returns the optimal LIWORK. +*> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim *> -*> \param[out] LIWORK +*> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER *> The dimension of the array LIWORK. -*> If FACT = 'P': minimal LIWORK >= max(1,N-1). -*> If FACT = 'C' or 'X': minimal LIWORK >= max(1,N). -*> Optimal LIWORK is the same as minimal LIWORK. +*> If FACT = 'P': the minimal LIWORK >= max(1,N-1). +*> If FACT = 'C' or 'X': the minimal LIWORK >= max(1,N). +*> The optimal LIWORK is the same as the minimal LIWORK. *> The user can still query the routine for the optimal LIWORK. *> *> If LIWORK = -1, then a workspace query is assumed; the routine @@ -721,8 +752,8 @@ *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, the i-th diagonal element of the *> triangular R factor of the QR factorization of -*> the matrix C is zero, so that C does not have -*> full rank, X cannot be computed as the least +*> the matrix C is zero. Consequently, C does not have +*> full rank, and X cannot be computed as the least *> squares solution to C*X = A. *> (R is stored in the array QRC.) *> \endverbatim @@ -737,7 +768,7 @@ * *> \ingroup gecxx * -* ===================================================================== +* ===================================================================== SUBROUTINE DGECXX( FACT, USESD, M, N, $ DESEL_ROWS, SEL_DESEL_COLS, $ KMAXFREE, ABSTOL, RELTOL, A, LDA, From be99d8943ca340e9f934c403a68156df04cd4c9f Mon Sep 17 00:00:00 2001 From: Igor Date: Wed, 11 Feb 2026 09:52:06 -0800 Subject: [PATCH 08/63] Refactor comments and some efficiency improvements --- SRC/dgecxx.f | 542 +++++++++++++++++++++++++-------------------------- 1 file changed, 270 insertions(+), 272 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index b8b55b07e..7dc60173f 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -24,6 +24,7 @@ * $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, * $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, * $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) +* IMPLICIT NONE * * .. Scalar Arguments .. * CHARACTER FACT, USESD @@ -63,8 +64,8 @@ *> *> The column selection for the matrix C has two stages. *> -*> Column preselection stage 1. -*> ============================ +*> Column preselection stage 1 (optional). +*> ======================================= *> *> The user can select N_sel columns and deselect N_desel columns *> of the matrix A that MUST be included and excluded respectively @@ -85,7 +86,9 @@ *> be controlled by three stopping criteria described below. *> For column selection, the routine uses a truncated (rank-K) *> Householder QR factorization with column pivoting algorithm using -*> the routine DGEQP3RK. Note that before running the column selection +*> the routine DGEQP3RK. +*> +*> Optionally, before running the column selection *> algorithm, the user can deselect M_desel rows of the matrix A that *> should NOT be considered by the column selection algorithm (i.e. *> during the factorization). This is controlled by flags in @@ -103,6 +106,9 @@ *> of columns of the matrix A minus the number of deselected columns *> N_desel, i.e. N_sub = N - N_desel. *> +*> The reported column selection error metrics MAXC2NRMK, RELMAXC2NRMK +*> and FNRMK described below are computed using only A_sub. +*> *> Column selection criteria. *> ========================== *> @@ -110,23 +116,26 @@ *> can be any of the following: *> *> 1) KMAXFREE: This input parameter specifies the maximum number of -*> columns to factorize outside of the N_sel preselected columns. -*> The factorization rank is limited to N_sel + KMAXFREE. +*> columns to factorize in addition to the N_sel preselected +*> columns. The factorization rank is limited to N_sel + KMAXFREE. *> If N_sel + KMAXFREE >= min(M_sub, N_sub), this criterion *> is not used. *> *> 2) ABSTOL: This input parameter specifies the absolute tolerance *> for the maximum column 2-norm of the submatrix residual -*> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub). +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), where +*> A_sub(K) denotes the contents of the array +*> A_sub = A(1:M_sub, 1:N_sub) after K columns were factorized. *> This means that the factorization stops if this norm is less *> than or equal to ABSTOL. If ABSTOL < 0.0, this criterion is *> not used. *> *> 3) RELTOL: This input parameter specifies the tolerance for *> the maximum column 2-norm of the submatrix residual -*> A_sub_resid(K) = A(K+1:M_sub, K+1:N_sub) divided +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) divided *> by the maximum column 2-norm of the submatrix -*> A_sub = A(1:M_sub, 1:N_sub). +*> A_sub = A(1:M_sub, 1:N_sub), where A_sub(K) denotes the contents +*> of the array A_sub after K columns were factorized. *> This means that the factorization stops when the ratio of the *> maximum column 2-norm of A_sub_resid(K) to the maximum column *> 2-norm of A_sub is less than or equal to RELTOL. @@ -153,13 +162,13 @@ *> selection. Then the routine factorizes that block A(1:M_sub,1:N_sel), *> and if any of the three stopping criteria is met immediately after *> factoring the first N_sel columns the routine exits -*> (i.e. the user does not want to select KMAXFREE extra columns, or -*> if the absolute or relative tolerance of the maximum column 2-norm of -*> the residual is satisfied). In this case, the number +*> (i.e. if the user does not want to select KMAXFREE > 0 extra columns, +*> or if the absolute or relative tolerance of the maximum column 2-norm +*> of the residual is satisfied). In this case, the number *> of selected columns would be K = N_sel. Otherwise, the factorization *> routine finds a new column to select with the maximum column 2-norm -*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and permutes that -*> column to the left side of A(1:M,N_sel+1:N_sub). Then the routine +*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and swaps that +*> column with the first column of A(1:M,N_sel+1:N_sub). Then the routine *> checks if the stopping criteria are met in the next residual *> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. *> @@ -172,8 +181,8 @@ *> stored in the first K elements of the JPIV array. *> (b) If the flag FACT = 'C', then in addition to (a), the routine *> explicitly returns the matrix C in the array C. -*> (c) If the flag FACT = 'X', then in addition to (b), the routine -*> explicitly computes and returns the factor +*> (c) If the flag FACT = 'X', then in addition to (a) and (b), +*> the routine explicitly computes and returns the factor *> X = pseudoinv(C) * A in the array X, and it also returns *> the factor R alongside the Householder vectors *> of the QR factorization of the matrix C in the array QRC. @@ -192,10 +201,10 @@ *> = 'P': the routine returns: *> (1) only the column permutation matrix P in *> the array JPIV. -*> ( The first K elements of the array JPIV +*> (The first K elements of the array JPIV *> contain indices of the columns that were *> selected from the matrix A to form the -*> factor C. ) +*> factor C.) *> (fastest option, smallest memory space) *> *> = 'C': the routine returns: @@ -232,11 +241,11 @@ *> *> = 'R': Only row deselection is ON. *> Column preselection-deselection is OFF. -*> Only the array SEL_DESEL_COLS is not used. +*> The array SEL_DESEL_COLS is not used. *> *> = 'C': Only column preselection-deselection is ON. *> Row deselection is OFF. -*> Only the array DESEL_ROWS is not used. +*> The array DESEL_ROWS is not used. *> *> = 'A': Means "All". Both row deselection and column *> preselection-deselection are ON. @@ -257,9 +266,9 @@ *> \param[in] DESEL_ROWS *> \verbatim *> DESEL_ROWS is INTEGER array, dimension (M) -*> DESEL_ROWS is only accessed, if USESD = 'R' or 'A'. +*> DESEL_ROWS is only accessed if USESD = 'R' or 'A'. *> This is a row deselection mask array that separates -*> the matrix A rows into 2 sets. +*> the rows of matrix A into 2 sets. *> *> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is *> deselected by the user, i.e. chosen to be excluded from @@ -280,9 +289,9 @@ *> \param[in] SEL_DESEL_COLS *> \verbatim *> SEL_DESEL_COLS is INTEGER array, dimension (N) -*> SEL_DESEL_COLS is only accessed, if USESD = 'C' or 'A'. +*> SEL_DESEL_COLS is only accessed if USESD = 'C' or 'A'. *> This is a column preselection-deselection mask array that -*> separates the matrix A columns into 3 sets. +*> separates the columns of matrix A into 3 sets. *> *> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix *> A is preselected by the user to be included @@ -296,9 +305,9 @@ *> of the array A. The number of deselected columns is *> denoted by N_desel. *> -*> c) If SEL_DESEL_COLS(j) is not equal 1 and not equal -1, -*> the j-th column of A is a free column and will be used -*> by the column selection algorithm to determine if this +*> c) If SEL_DESEL_COLS(j) is not equal to 1 and not equal +*> to -1, the j-th column of A is a free column and will be +*> used by the column selection algorithm to determine if this *> column will be selected. This defines a set of *> columns of size N_free = N - N_sel - N_desel. *> @@ -333,7 +342,8 @@ *> satisfied on input and the routine exits without *> performing column selection stage 2 *> on the submatrix A_sub. This means that the matrix -*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified. +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified +*> in the column selection stage 2 *> and A_free is itself the residual for the factorization. *> \endverbatim *> @@ -350,13 +360,14 @@ *> *> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm *> of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) *> when K columns have been factorized. -*> The column selection algorithm converges (stops -*> the factorization) when +*> The column selection algorithm converges +*> (stops the factorization) when *> maxcol2norm(A_sub_resid(K)) <= ABSTOL, where K >= N_sel. *> -*> Here, SAFMIN = DLAMCH('S'), +*> In the following, +*> SAFMIN = DLAMCH('S'), *> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), *> maxcol2norm(A_free) is the maximum column 2-norm *> of the matrix A_free. @@ -387,7 +398,7 @@ *> and exits immediately. *> This means that the factorization residual *> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) -*> is not modified. +*> is not modified in the column selection stage 2. *> This includes the case where ABSTOL = +Inf. *> \endverbatim *> @@ -406,7 +417,7 @@ *> *> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm *> of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) *> when K columns have been factorized. *> maxcol2norm(A_sub) is the maximum column 2-norm *> of the original submatrix A_sub = A(1:M_sub, 1:N_sub). @@ -414,7 +425,8 @@ *> (stops the factorization) when the ratio *> relmaxcol2norm(A_sub_resid(K)) <= RELTOL, where K >= N_sel. *> -*> Here, EPS = DLAMCH('E'), +*> In the following, +*> EPS = DLAMCH('E'), *> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). *> *> a) If RELTOL is NaN, then no computation is performed @@ -511,7 +523,7 @@ *> *> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains *> the (M_sub-K)-by-(N_sub-K) rectangular matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub). *> \endverbatim *> *> \param[in] LDA @@ -525,7 +537,7 @@ *> K is INTEGER *> The number of columns that were selected *> (K is the factorization rank). -*> 0 <= K <= min( M_sub, min(N_sel+KMAXFREE, N_sub) ). +*> 0 <= K <= min( M_sub, N_sel+KMAXFREE, N_sub ). *> *> If K = 0, the arrays A, TAU were not modified. *> \endverbatim @@ -534,10 +546,10 @@ *> \verbatim *> MAXC2NRMK is DOUBLE PRECISION *> The maximum column 2-norm of the residual matrix -*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub), +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), *> when factorization stopped at rank K. MAXC2NRMK >= 0. *> -*> a) If K = 0, i.e. the factorization was not performed, +*> a) If K = 0, i.e. the factorization was not performed, so *> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified *> and is itself a residual matrix, then MAXC2NRMK equals *> the maximum column 2-norm of the original matrix A_sub. @@ -630,7 +642,7 @@ *> If FACT = 'C' or 'X': *> If USESD = 'N', the array dimension is (LDC,min(M,N)). *> If USESD = 'C' or 'R' or 'A', -*> the array dimension (LDC,min(M_sub,N_sub)). +*> the array dimension is (LDC,min(M_sub,N_sub)). *> *> If K = 0, the array is not used. *> If K > 0, the array C stores the M-by-K factor C. @@ -705,9 +717,9 @@ *> LWORK is INTEGER *> The dimension of the array WORK. *> If FACT = 'P' or 'C': -*> the minimal LWORK >= max( 1, NSUB, NSEL, 3*NFREE+1 ). +*> the minimal LWORK >= max( 1, N_sub, N_sel, 3*N_free+1 ). *> If FACT = 'X': -*> the minimal LWORK >= max( 1, NSUB, 3*NFREE+1, min(M,N)+N ). +*> the minimal LWORK >= max( 1, N_sub, 3*N_free+1, min(M,N)+N ). *> *> For good performance, LWORK should generally be larger, and *> the user should query the routine for the optimal LWORK. @@ -722,9 +734,9 @@ *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (N). -*> Is a work array. ( IWORK is used by DGEQP3RK to store indices +*> Is a work array. (IWORK is used by DGEQP3RK to store indices *> of "bad" columns for norm downdating in the residual -*> matrix in the blocked step auxiliary subroutine DLAQP3RK ). +*> matrix in the blocked step auxiliary subroutine DLAQP3RK.) *> *> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim @@ -733,8 +745,8 @@ *> \verbatim *> LIWORK is INTEGER *> The dimension of the array LIWORK. -*> If FACT = 'P': the minimal LIWORK >= max(1,N-1). -*> If FACT = 'C' or 'X': the minimal LIWORK >= max(1,N). +*> If FACT = 'P': the minimal LIWORK >= max(1,2N-2). +*> If FACT = 'C' or 'X': the minimal LIWORK >= max(1,3N-1). *> The optimal LIWORK is the same as the minimal LIWORK. *> The user can still query the routine for the optimal LIWORK. *> @@ -768,13 +780,14 @@ * *> \ingroup gecxx * -* ===================================================================== - SUBROUTINE DGECXX( FACT, USESD, M, N, +* ===================================================================== + SUBROUTINE DGECXX22( FACT, USESD, M, N, $ DESEL_ROWS, SEL_DESEL_COLS, $ KMAXFREE, ABSTOL, RELTOL, A, LDA, $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -802,8 +815,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * .. Local Scalars .. LOGICAL LIQUERY, LQUERY, RETURNC, RETURNX, $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL - INTEGER I, J, NSUB, MFREE, MSUB, MNSUB, NSEL, JDESEL, - $ ITEMP, IINFO, KP, KP0, KFREE, MRESID, NRESID, + INTEGER I, J, NSUB, MFREE, MSUB, NSEL, JDESEL, + $ ITEMP, IINFO, KP0, KFREE, MRESID, NRESID, $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, JP, JJ, JPW, $ MINMN, MDESEL, NDESEL, NFREE DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, @@ -823,7 +836,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN * .. -* .. Executable Statements .. +* .. Executable Statements .. * * Test the input arguments * @@ -856,20 +869,22 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, INFO = -4 END IF * -* This is to check that NSEL cannot be larger than MSUB. -* When the number of preselected columns is larger than MSUB, -* the factorization of all NSEL columns cannot be completed. +* This is to check that the number of preselected columns NSEL +* cannot be larger than MSUB, which is the number of rows +* without MDESEL deselected rows. When the number of +* preselected columns NSEL is larger than MSUB, the factorization +* of all preselected NSEL columns cannot be completed. * MSUB also will be used for LDX argument check later. * IF( USE_DESEL_ROWS ) THEN * -* Count the number of free rows MSUB. +* Count the number of free rows MSUB. * - DO I = 1, M - IF( DESEL_ROWS( I ).EQ.-1) MDESEL = MDESEL + 1 - END DO - MSUB = M - MDESEL - MFREE = MSUB + DO I = 1, M + IF( DESEL_ROWS( I ).EQ.-1 ) MDESEL = MDESEL + 1 + END DO + MSUB = M - MDESEL + MFREE = MSUB END IF * IF( USE_SEL_DESEL_COLS ) THEN @@ -878,8 +893,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * number of preselected and freecolumns NSUB = N - NDESEL. * DO J = 1, N - IF( SEL_DESEL_COLS( J ).EQ.1) NSEL = NSEL + 1 - IF( SEL_DESEL_COLS( J ).EQ.-1) NDESEL = NDESEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 END DO NSUB = N - NDESEL MFREE = MSUB - NSEL @@ -899,15 +914,20 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -11 END IF -* +* +* +* This is a check for LDC IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) .OR. $ ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN INFO = -20 +* This is a check for LDQRC ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) .OR. $ ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN - INFO = -22 + + INFO = -22 +* This is a check for LDX ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, MAX(MSUB, NSUB) ) ) .OR. - $ ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN + $ ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN INFO = -24 END IF * @@ -915,13 +935,13 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * a) Test the input workspace size LWORK and LIWORK for the * minimum size requirement LWKMIN and LIWKMIN respectively. -* b) Determine the optimal workspace sizes LWKOPT LIWKOPT to be +* b) Determine the optimal workspace sizes LWKOPT and LIWKOPT to be * returned in WORK( 1 ) and IWORK( 1 ) respectively, * if INFO >= 0 in cases: * (1) LQUERY = .TRUE., * (2) LIQUERY = .TRUE., * (3) when the routine exits. -* Here, LWKMIN and LIWORK are the miminum workspaces required for +* Here, LWKMIN and LIWKMIN are the miminum workspaces required for * unblocked code. * IF( INFO.EQ.0 ) THEN @@ -960,7 +980,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( RETURNX ) THEN * - LWKMIN = MAX( LWKMIN, MIN(M,N) + N ) + LWKMIN = MAX( LWKMIN, MINMN + N ) * * Query for optimal workspace size for DGELS. * @@ -970,10 +990,12 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * END IF * -* End IF( LSAME( USESD, 'N') ) +* End IF( LSAME( USESD, 'N') ) * ELSE -* +* +* Begin of ELSE( LSAME( USESD, 'N') ) +* LWKMIN = MAX( MAX( 1, NSUB ), 3*NFREE + 1 ) * * Optimal workspace for column 2-norm computation. @@ -996,6 +1018,11 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) * LIWKMIN = MAX( 1, N-1 ) +* +* Integer workspace for JPIV ajustment. +* + LIWKMIN = LIWKMIN + N-1 +* LIWKOPT = LIWKMIN * IF( RETURNC ) THEN @@ -1013,10 +1040,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ WORK, -1, IINFO ) LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) * - END IF -* + END IF * -* End of ELSE( LSAME( USESD, 'N') ) +* End of ELSE( LSAME( USESD, 'N') ) * END IF * @@ -1063,45 +1089,49 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * ================================================================== * Permute the deselected rows to the bottom of the matrix A. -* 1) Order of free rows is preserved. -* 2) Order of deselected rows is not preserved. +* 1) The order of free rows is preserved. +* 2) The order of deselected rows is not preserved. * ================================================================== * -* I is the index of DESEL_ROWS array and row I -* of the matrix A. -* MFREE is the number of free rows, also the pointer to the last -* free row. -* (For each position I, we check if this position is a FREE row. -* If it is a FREE row we increment the MFREE pointer, otherwise we -* do not change the MFREE pointer. Also, if it is a FREE row, we move -* this row from the larger (or same) I index into samaller (or same) -* MFREE index. This way we move all the FREE rows to the lower index -* block preserving FREE row order. Deselected rows will be ) +* I is the index of DESEL_ROWS array and row I of the matrix A. +* MSUB is the number of included rows, i.e rows of the matrix A without +* deselected rows. +* (For each position I, we check if this position is an included row. +* If it is an included row, we increment MSUB, which is also a pointer +* to the last included row, otherwise we do not change MSUB pointer. +* Also, if it is an included row, we move this row from the larger +* (or same) I index into samaller (or same) MSUB index. This way +* we move all the included rows to the larger index block preserving +* included row order. The deselected rows will be at the bottom of the +* matrix A.) * IF( USE_DESEL_ROWS ) THEN * - MFREE = 0 + MSUB = 0 DO I = 1, M, 1 * -* Initialize row pivot array IPIV. +* Initialize the row pivot array IPIV. IPIV( I ) = I * - IF( DESEL_ROWS(I).NE.-1 ) THEN - MFREE = MFREE + 1 +* The row at the index I is an included row and should be +* moved to the top of the matrix A. * -* This is the check whether the deselected row is -* on the deselected place already. + IF( DESEL_ROWS( I ).NE.-1 ) THEN + MSUB = MSUB + 1 +* +* This is a check whether the included row is +* on the included place already. * - IF( I.NE.MFREE ) THEN + IF( I.NE.MSUB ) THEN * -* Here, we swap A(I,1:N) into A(MFREE,1:N) +* Here, we swap A(I,1:N) into A(MSUB,1:N) * - CALL DSWAP( N, A( I, 1 ), LDA, A( MFREE, 1 ), LDA ) - IPIV( I ) = IPIV( MFREE ) - IPIV( MFREE ) = I + CALL DSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) + IPIV( I ) = IPIV( MSUB ) + IPIV( MSUB ) = I ITEMP = DESEL_ROWS( I ) - DESEL_ROWS( I ) = DESEL_ROWS( MFREE ) - DESEL_ROWS( MFREE ) = ITEMP + DESEL_ROWS( I ) = DESEL_ROWS( MSUB ) + DESEL_ROWS( MSUB ) = ITEMP END IF END IF * @@ -1109,35 +1139,34 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * ELSE * -* We do not row deselection DESEL_ROWS array. -* Initialize row pivot array IPIV. +* We do not use the row deselection DESEL_ROWS array. +* Initialize the row pivot array IPIV. +* NOTE: MSUB=M has default value, +* which is set at the beginning of the routine, before argument checks. * DO I = 1, M, 1 IPIV( I ) = I END DO -* - MFREE = M END IF - MSUB = M * * ================================================================== * Permute the pseselected columns to the left and deselected * columns to the right of the matrix A. -* 1) Order of preselected columns is preserved. -* 2) Order of free columns is not preserved. -* 3) Order of deselected columns is not preserved. +* 1) The order of preselected columns is preserved. +* 2) The order of free columns is not preserved. +* 3) The order of deselected columns is not preserved. * ================================================================== * * J is the index of SEL_DESEL_COLS array and column J * of the matrix A. * -* Column selection. -* NSEL is the number of selected columns, also the pointer to the last -* selected column. -* - NSEL = 0 IF( USE_SEL_DESEL_COLS ) THEN -* +* +* Column selection. +* NSEL is the number of selected columns, also the pointer to the last +* selected column. +* + NSEL = 0 DO J = 1, N, 1 * * Initialize column pivot array JPIV. @@ -1163,6 +1192,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, END DO * * Column deselection. +* JDEEL the pointer to the last +* deselected column counting right-to-left. * JDESEL = N+1 DO J = N, NSEL+1, -1 @@ -1190,16 +1221,18 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * ELSE * -* We do not column selection deselection SEL_DESEL_COLS array. +* We do not use the column selection deselection +* SEL_DESEL_COLS array. * Initialize column pivot array JPIV. +* NOTE: NSUB=N has default value, +* which is set at the beginning of the routine, before argument checks. * DO J = 1, N, 1 JPIV( J ) = J END DO + + END IF * - NSUB = N - END IF -* * ================================================================== * Compute the complete column 2-norms of the submatrix * A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). @@ -1215,204 +1248,169 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, KP0 = IDAMAX( NSUB, WORK( 1 ), 1 ) MAXC2NRM = WORK( KP0 ) * -* ================================================================== * Process preselected columns * * Compute the QR factorization of NSEL preselected columns (1:NSEL) * in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update -* remaining NFEE free columns (NSEL+1:NSUB). -* MSUB = MFREE, NSUB = MSEL + NFREE +* remaining NFREE free columns (NSEL+1:NSUB). +* NSUB = NSEL + NFREE * - MNSUB = MIN( MSUB, NSUB ) - MRESID = MSUB-NSEL - NRESID = NSUB-NSEL IF( NSEL.GT.0 ) THEN -* (a) Case MSUB < NSEL. -* This is handled at the argument check stage in the begining -* of the routine. When the number of preselected columns -* is larger than MSUB, hence the factorization of all NSEL -* columns cannot be completed. Return from the routine with -* the error of COL_SEL_DESEL parameter. -* - IF( MSUB.EQ.NSEL.OR. - $ ( MSUB.GT.NSEL.AND.NSEL.EQ.NSUB )) THEN -* -* (b) Case MSUB = NSEL. -* (c-1) Case MSUB > NSEL and NSEL = NSUB. -* -* There will be no residual submatrix after factorization -* of NSEL columns at step K = NSEL: -* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). -* Therefore, ther is no need to do the factorization of NSEL -* columns. Set norms to ZERO and return from the routine. -* - K = NSEL - MAXC2NRMK = ZERO - RELMAXC2NRMK = ZERO - FNRMK = ZERO +* +* Case (a): MSUB < NSEL. * -* Zero out TAU(K+1, MSUB) -* - DO J = K + 1, MNSUB - TAU( J ) = ZERO - END DO +* This is handled at the argument check stage in the +* begining of the routine. When the number of preselected +* columns is larger than MSUB, hence the factorization of +* all NSEL columns cannot be completed. Return from the +* routine with the error of COL_SEL_DESEL parameter. * -* Go to the construction of the matrix C. -* - GO TO 10 - ELSE +* Case (b): MSUB = NSEL. +* Case (c-1): MSUB > NSEL and NSEL = NSUB. * -* (c-2) Case MSUB > NSEL and NSEL < NSUB. +* For cases (b) and (c-1), ther will be no residual +* submatrix after factorization of NSEL columns +* at step K = NSEL: +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). * -* There is a submatrix residual at step K=NSEL -* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) +* Case (c-2): MSUB > NSEL and NSEL < NSUB. * - CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) +* For Case (c-2) is a submatrix residual at step K=NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) * -* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) + CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) * - CALL DORMQR( 'Left', 'Transpose', MSUB, NSUB-NSEL, NSEL, - $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, LWORK, IINFO ) +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) * -* Compute the complete column 2-norms of the submatrix -* residual at step NSEL -* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) and -* store them in WORK(NSUB+NSEL+1:2*NSUB). + IF( NFREE.GT.0 ) THEN * - DO J = NSEL+1, NSUB - WORK( NSUB+J ) = DNRM2( MRESID, A( NSEL+1, J ), 1 ) - END DO -* -* Compute the column index and the maximum column 2-norm -* and the relative maximum column 2-norm for the submatrix -* residual. -* - KP = IDAMAX( NRESID, WORK( NSUB+NSEL+1 ), 1 ) -* - K = NSEL - MAXC2NRMK = WORK( NSUB + NSEL + KP ) - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM -* -* Test for the first, second and third tolerance stopping -* criteria after factorizarion of preselected columns. -* If any of them is met, return. Otherwise, -* proceed with factorization of the NFREE free columns. -* NOTE: There is no need to test for ABSTOL.GE.ZERO, since -* MAXC2NRMK is non-negative. Similarly, there is no need -* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is -* non-negative. -* - IF( KMAXFREE.EQ.0 - $ .OR. MAXC2NRMK.LE.ABSTOL - $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN -* -* NOTE: In this (c-2) case. There is a submatrix -* residual A_sub_resid(NSEL). We do not need to have a check -* for MIN(MRESID, NRESID) = 0 to call DLANGE. -* - FNRMK = DLANGE( 'F', MRESID, NRESID, A(NSEL+1,NSEL+1), - $ LDA, WORK ) -* -* Zero out TAU(K+1, MSUB) -* - DO J = K + 1, MNSUB - TAU( J ) = ZERO - END DO +* This is only for case (c-2). +* + CALL DORMQR( 'Left', 'Transpose', MSUB, NFREE, NSEL, + $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ LWORK, IINFO ) + END IF * -* Go to the construction of the matrix C. -* - GO TO 10 - END IF -* - END IF + K = NSEL * -* End of IF(NSEL.GT.0) +* End of IF(NSEL.GT.0) * END IF * * ================================================================== -* -* Factorize NFREE free columns of -* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), -* KFREE is the number of columns that were actually factorized among -* NFREE columns. * + KFREE = 0 +* + IF( MIN( MFREE, NFREE ).NE.0 ) THEN +* +* Factorize NFREE free columns of +* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), +* KFREE is the number of columns that were actually factorized +* among NFREE columns. +* * ================================================================== * - EPS = DLAMCH('Epsilon') + EPS = DLAMCH('Epsilon') * - USETOL = .FALSE. + USETOL = .FALSE. * -* Adjust ABSTOL only if nonnegative. Negative value means disabled. -* We need to keep negtive value for later use in criterion -* check. +* Adjust ABSTOL only if nonnegative. Negative value means disabled. +* We need to keep negtive value for later use in criterion +* check. * - IF( ABSTOL.GE.ZERO ) THEN - SAFMIN = DLAMCH('Safe minimum') - ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) - USETOL = .TRUE. - END IF + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF * -* Ajust RELTOL only if nonnegative. Negative value means disabled. -* We need to keep negtive value for later use in criterion -* check. +* Ajust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negtive value for later use in criterion +* check. * - IF( RELTOL.GE.ZERO ) THEN - RELTOL = MAX( RELTOL, EPS ) - USETOL = .TRUE. - END IF + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF * * ================================================================== * -* Disable RELTOLFREE when calling DGEQP3RK for free columns -* factorization, since it expects RELTOLFREE with respect to -* the residual matrix A_sub_resid(NSEL), not the whole original -* marix A. We can use RELTOL criterion by passing it to -* ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that -* the negative values of ABSTOL and RELTOL are propagated -* to ABSTOLFREE and RELTOLFREE, since negative vaslues means -* that the criterionis is disabled. -* - IF( USETOL ) THEN - ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) +* Disable RELTOLFREE when calling DGEQP3RK for free columns +* factorization, since DGEQP3RK expects RELTOLFREE with respect +* to the residual matrix A_sub_resid(NSEL), not the whole +* original marix A. We can use RELTOL criterion by passing it +* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that +* the negative values of ABSTOL and RELTOL are propagated +* to ABSTOLFREE and RELTOLFREE, since negative values means +* that the criterionis is disabled. +* + IF( USETOL ) THEN + ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) + ELSE + ABSTOLFREE = MINUSONE + END IF + RELTOLFREE = MINUSONE +* +* Save JPIV(NSEL+1:NSUB) into WORK(1:NFREE) +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + IWORK( NFREE-1+J ) = JPIV( NSEL+J ) + END DO + END IF +* + CALL DGEQP3RK( MFREE, NFREE, 0, KMAXFREE, + $ ABSTOLFREE, RELTOLFREE, + $ A( NSEL+1, NSEL+1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( NSEL+1 ), + $ TAU( NSEL+1 ), WORK, LWORK, IWORK, IINFO ) +* +* Ajust JPIV +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + JPIV( NSEL+J ) = IWORK( NFREE-1+JPIV( NSEL+J ) ) + END DO + END IF +* +* 1) Adjust the return value for the number of factorized +* columns K for the whole submatrix A_sub. +* 2) MAXC2NRMK is returned transparently without change +* as MAXC2NRMKFREE is returned from DGEQP3RK. +* 3) Adjust the return value RELMAXC2NRMK for the whole +* submatrix A_sub. We do not use RELMAXC2NRMKFREE +* returned from DGEQP3RK. +* + K = NSEL + KFREE + MAXC2NRMK = MAXC2NRMKFREE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* ELSE - ABSTOLFREE = MINUSONE +* +* Set norms to zero +* + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* END IF - RELTOLFREE = MINUSONE -* - CALL DGEQP3RK( MRESID, NRESID, 0, KMAXFREE, - $ ABSTOLFREE, RELTOLFREE, - $ A( K+1, K+1 ), LDA, KFREE, MAXC2NRMKFREE, - $ RELMAXC2NRMKFREE, JPIV( K+1 ), TAU( K+1 ), - $ WORK, LWORK, IWORK, IINFO ) -* -* 1) Adjust the return value for the number of factorized -* columns K for the whole submatrix A_sub. -* 2) MAXC2NRMK is returned transparently without change -* as MAXC2NRMKFREE is returned from DGEQP3RK. -* 3) Adjust the return value RELMAXC2NRMK for the whole -* submatrix A_sub. We do not use RELMAXC2NRMKFREE -* returned from DGEQP3RK. -* - K = K + KFREE - MAXC2NRMK = MAXC2NRMKFREE - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM * * Now, MRESID and NRESID is the number of rows and columns * respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). * - MRESID = MRESID-KFREE - NRESID = NRESID-KFREE + MRESID = MFREE-KFREE + NRESID = NFREE-KFREE +* IF( MIN( MRESID, NRESID ).NE.0 ) THEN FNRMK = DLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), $ LDA, WORK ) - ELSE - FNRMK = ZERO - END IF + ELSE + FNRMK = ZERO + END IF +* +* +* ================================================================== * * Construct matrix C. -* - 10 CONTINUE * IF( RETURNC .AND. K.GT.0 ) THEN * @@ -1458,11 +1456,11 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, CALL DGELS( 'N', M, K, N, QRC, LDQRC, X, LDX, $ WORK, LWORK, IINFO ) INFO = IINFO +* END IF -* WORK( 1 ) = DBLE( LWKOPT ) IWORK( 1 ) = LIWKOPT * * DGECXX * - END + END From 39c3a5083db616cc5f1a1b1b3ea2093ab9d64e9c Mon Sep 17 00:00:00 2001 From: Igor Date: Thu, 12 Feb 2026 06:40:12 -0800 Subject: [PATCH 09/63] Fix LIWORK calculations and JPIV adjustment comments --- SRC/dgecxx.f | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 7dc60173f..06bec4f7c 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -745,8 +745,8 @@ *> \verbatim *> LIWORK is INTEGER *> The dimension of the array LIWORK. -*> If FACT = 'P': the minimal LIWORK >= max(1,2N-2). -*> If FACT = 'C' or 'X': the minimal LIWORK >= max(1,3N-1). +*> If FACT = 'P': the minimal LIWORK >= max(1,2N-1). +*> If FACT = 'C' or 'X': the minimal LIWORK >= max(1,2N-1). *> The optimal LIWORK is the same as the minimal LIWORK. *> The user can still query the routine for the optimal LIWORK. *> @@ -1016,13 +1016,11 @@ SUBROUTINE DGECXX22( FACT, USESD, M, N, $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), $ WORK, -1, IWORK, IINFO ) LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) -* - LIWKMIN = MAX( 1, N-1 ) -* -* Integer workspace for JPIV ajustment. -* - LIWKMIN = LIWKMIN + N-1 * +* Integer workspace. +* N is for DGEQP3RK and N-1 for JPIV ajustment. +* + LIWKMIN = MAX( 1, N + N-1 ) LIWKOPT = LIWKMIN * IF( RETURNC ) THEN @@ -1351,11 +1349,11 @@ SUBROUTINE DGECXX22( FACT, USESD, M, N, END IF RELTOLFREE = MINUSONE * -* Save JPIV(NSEL+1:NSUB) into WORK(1:NFREE) +* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) * IF( NSEL.NE.0 ) THEN DO J = 1, NFREE, 1 - IWORK( NFREE-1+J ) = JPIV( NSEL+J ) + IWORK( NFREE + J ) = JPIV( NSEL+J ) END DO END IF * @@ -1369,9 +1367,9 @@ SUBROUTINE DGECXX22( FACT, USESD, M, N, * IF( NSEL.NE.0 ) THEN DO J = 1, NFREE, 1 - JPIV( NSEL+J ) = IWORK( NFREE-1+JPIV( NSEL+J ) ) + JPIV( NSEL+J ) = IWORK( NFREE + JPIV( NSEL+J ) ) END DO - END IF + END IF * * 1) Adjust the return value for the number of factorized * columns K for the whole submatrix A_sub. From ecac9d22f786af80e920fe722f5d089cfdf6f892 Mon Sep 17 00:00:00 2001 From: Igor Date: Wed, 4 Mar 2026 13:09:06 -0800 Subject: [PATCH 10/63] Rename subroutine DGECXX22 to DGECXX --- SRC/dgecxx.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 06bec4f7c..9f05ee0f1 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -781,7 +781,7 @@ *> \ingroup gecxx * * ===================================================================== - SUBROUTINE DGECXX22( FACT, USESD, M, N, + SUBROUTINE DGECXX( FACT, USESD, M, N, $ DESEL_ROWS, SEL_DESEL_COLS, $ KMAXFREE, ABSTOL, RELTOL, A, LDA, $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, From 8fc7d537b156c2406edcee7c32c62fb490daafbf Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Wed, 18 Mar 2026 15:21:30 -0700 Subject: [PATCH 11/63] dgecxx.f Corrected calculation of check for LDX input parameter and refined calculation for workspace LWORK and LIWORK --- SRC/dgecxx.f | 357 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 227 insertions(+), 130 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 9f05ee0f1..a3df48411 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -656,28 +656,6 @@ *> If FACT = 'C' or 'X', LDC >= max(1,M). *> \endverbatim *> -*> \param[out] X -*> \verbatim -*> X is DOUBLE PRECISION array. -*> If FACT = 'P' or 'C': The array is not used, -*> the array dimension is >= (1,1). -*> If FACT = 'X': -*> The array dimension is (LDX,N). -*> If K = 0, the array is not used. -*> If K > 0, the array X stores the K-by-N factor X. -*> \endverbatim -*> -*> \param[in] LDX -*> \verbatim -*> LDX is INTEGER -*> The leading dimension of the array X. -*> If FACT = 'P' or 'C': LDX >= 1. -*> If FACT = 'X': -*> If USESD = 'N', LDX >= max(1,min(M,N)). -*> If USESD = 'C' or 'R' or 'A', -*> LDX >= max(1,min(M_sub,N_sub)). -*> \endverbatim -*> *> \param[out] QRC *> \verbatim *> QRC is DOUBLE PRECISION array. @@ -701,8 +679,27 @@ *> \verbatim *> LDQRC is INTEGER *> The leading dimension of the array QRC. -*> If FACT = 'P', LDQRC >= 1. -*> If FACT = 'C' or 'X', LDQRC >= max(1,M). +*> If FACT = 'P' or 'C', LDQRC >= 1. +*> If FACT = 'X', LDQRC >= max(1,M). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array. +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> If FACT = 'X': +*> The array dimension is (LDX,N). +*> If K = 0, the array is not used. +*> If K > 0, the array X stores the K-by-N factor X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> If FACT = 'P' or 'C', LDQRC >= 1. +*> If FACT = 'X', LDQRC >= max(1,M). *> \endverbatim *> *> \param[out] WORK @@ -715,11 +712,16 @@ *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER -*> The dimension of the array WORK. -*> If FACT = 'P' or 'C': -*> the minimal LWORK >= max( 1, N_sub, N_sel, 3*N_free+1 ). -*> If FACT = 'X': -*> the minimal LWORK >= max( 1, N_sub, 3*N_free+1, min(M,N)+N ). +*> The dimension of the array WORK. +*> For USESD = 'N' or 'R' and for all FACT: +*> LWORK >= max( 1, 3*N - 1 ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P' or 'C': +*> LWORK >= max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +*> b) If FACT = 'X': +*> LWORK >= max( 1, min(M,N)+N, +*> min(1,MINMNFREE)*(3*N_free-1) ) +*> where MINMNFREE = min( M_free, N_free ). *> *> For good performance, LWORK should generally be larger, and *> the user should query the routine for the optimal LWORK. @@ -733,10 +735,7 @@ *> *> \param[out] IWORK *> \verbatim -*> IWORK is INTEGER array, dimension (N). -*> Is a work array. (IWORK is used by DGEQP3RK to store indices -*> of "bad" columns for norm downdating in the residual -*> matrix in the blocked step auxiliary subroutine DLAQP3RK.) +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)). *> *> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim @@ -744,9 +743,18 @@ *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER -*> The dimension of the array LIWORK. -*> If FACT = 'P': the minimal LIWORK >= max(1,2N-1). -*> If FACT = 'C' or 'X': the minimal LIWORK >= max(1,2N-1). +*> The dimension of the array LIWORK. +*> For USESD = 'N' or 'R': +*> a) If FACT = 'P': +*> min LIWORK >= max( 1, N-1 ) +*> b) If FACT = 'C' or 'X': +*> min LIWORK >= max( 1, N) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P': +*> min LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) +*> b) If FACT = 'C' or 'X': +*> min LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +*> *> The optimal LIWORK is the same as the minimal LIWORK. *> The user can still query the routine for the optimal LIWORK. *> @@ -816,9 +824,10 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, LOGICAL LIQUERY, LQUERY, RETURNC, RETURNX, $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL INTEGER I, J, NSUB, MFREE, MSUB, NSEL, JDESEL, - $ ITEMP, IINFO, KP0, KFREE, MRESID, NRESID, + $ ITEMP, IINFO, KFREE, KMAXLS, KP0, $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, JP, JJ, JPW, - $ MINMN, MDESEL, NDESEL, NFREE + $ MRESID, NRESID, MINMN, MINMNFREE, MDESEL, + $ NDESEL, NFREE DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN @@ -867,68 +876,67 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, INFO = -3 ELSE IF( N.LT.0 ) THEN INFO = -4 - END IF + ELSE * -* This is to check that the number of preselected columns NSEL -* cannot be larger than MSUB, which is the number of rows -* without MDESEL deselected rows. When the number of -* preselected columns NSEL is larger than MSUB, the factorization -* of all preselected NSEL columns cannot be completed. -* MSUB also will be used for LDX argument check later. +* This is to check that the number of preselected columns NSEL +* cannot be larger than MSUB, which is the number of rows +* without MDESEL deselected rows. When the number of +* preselected columns NSEL is larger than MSUB, +* the factorizationof all preselected NSEL columns cannot be +* completed. MSUB also will be used for LDX argument check +* later. * - IF( USE_DESEL_ROWS ) THEN + IF( USE_DESEL_ROWS ) THEN * -* Count the number of free rows MSUB. +* Count the number of free rows MSUB. * - DO I = 1, M - IF( DESEL_ROWS( I ).EQ.-1 ) MDESEL = MDESEL + 1 - END DO - MSUB = M - MDESEL - MFREE = MSUB - END IF + DO I = 1, M + IF( DESEL_ROWS( I ).EQ.-1 ) MDESEL = MDESEL + 1 + END DO + MSUB = M - MDESEL + MFREE = MSUB + END IF * - IF( USE_SEL_DESEL_COLS ) THEN + IF( USE_SEL_DESEL_COLS ) THEN * -* Count the number of preselected columns NSEL and the -* number of preselected and freecolumns NSUB = N - NDESEL. -* - DO J = 1, N - IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 - IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 - END DO - NSUB = N - NDESEL - MFREE = MSUB - NSEL - NFREE = NSUB - NSEL +* Count the number of preselected columns NSEL and the +* number of preselected and freecolumns NSUB = N - NDESEL. * + DO J = 1, N + IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 + END DO + NSUB = N - NDESEL + MFREE = MSUB - NSEL + NFREE = NSUB - NSEL +* + END IF + MINMNFREE = MIN( MFREE, NFREE ) +* IF( NSEL.GT.MSUB ) THEN INFO = -6 - END IF - END IF -* - IF( KMAXFREE.LT.0 ) THEN - INFO = -7 - ELSE IF( DISNAN( ABSTOL ) ) THEN - INFO = -8 - ELSE IF( DISNAN( RELTOL ) ) THEN - INFO = -9 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -11 - END IF -* -* + ELSE IF( KMAXFREE.LT.0 ) THEN + INFO = -7 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -8 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 * This is a check for LDC - IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN - INFO = -20 + ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN + INFO = -20 * This is a check for LDQRC - ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) .OR. - $ ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN - - INFO = -22 + ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN + INFO = -22 * This is a check for LDX - ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, MAX(MSUB, NSUB) ) ) .OR. - $ ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN - INFO = -24 + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN + INFO = -24 + END IF +* END IF * * ================================================================== @@ -953,13 +961,18 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, LIWKOPT = 1 ELSE * - IF( LSAME( USESD, 'N') ) THEN + IF( LSAME( USESD, 'N') .OR. LSAME( USESD, 'R' ) ) THEN +* +* Real minimum workspace computation. +* a) LWKMIN = NSUB = N for column 2-norm computation +* b) LWKMIN = 3*NFREE+1 = 3*N-1 for the call of DGEQP3RK. +* Therefore: * - LWKMIN = MAX( 1, 3*N + 1 ) + LWKMIN = MAX( 1, 3*N - 1 ) * * Optimal workspace for column 2-norm computation. * - LWKOPT = N + LWKOPT = MAX( 1 , N ) * * Query for optimal workspace size for DGEQP3RK. * @@ -969,78 +982,161 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), $ WORK, -1, IWORK, IINFO ) LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) -* +* +* Integer minimum workspace compuation. +* aa) LIWKMIN = NFREE-1 = N-1 for the call of DGEQP3RK. +* LIWKMIN = MAX( 1, N-1 ) - LIWKOPT = LIWKMIN * IF( RETURNC ) THEN - LIWKMIN = MAX( LIWKOPT, N ) - LIWKOPT = LIWKMIN +* +* Integer minimum workspace compuation. +* bb) LIWKMIN = N for applying the interchanges for +* the columns in the matrix C. +* + LIWKMIN = MAX( LIWKMIN, N ) +* END IF -* + LIWKOPT = LIWKMIN +* +* Call of DGELS. +* IF( RETURNX ) THEN +* +* Real minimum workspace computation. +* c) LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = +* = max( 1, MINMN + N ) for the call of DGELS. +* NOTE: MINMN + N < 3*N + 1, therfore effectively, +* LWKMIN = MAX( LWKMIN, MINMN + N ) = 3*N + 1 * LWKMIN = MAX( LWKMIN, MINMN + N ) * * Query for optimal workspace size for DGELS. * - CALL DGELS( 'N', M, N, N, QRC, LDQRC, X, LDX, + KMAXLS = MINMN +* + CALL DGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, $ WORK, -1, IINFO ) LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) * END IF * -* End IF( LSAME( USESD, 'N') ) +* End IF( LSAME( USESD, 'N') .OR. LSAME( USESD, 'R' ) ) * - ELSE + ELSE * -* Begin of ELSE( LSAME( USESD, 'N') ) -* - LWKMIN = MAX( MAX( 1, NSUB ), 3*NFREE + 1 ) +* Begin of ELSE( LSAME( USESD, 'N') .OR. LSAME( USESD, 'R' ) ) +* +* Real minimum workspace computation. +* a) LWKMIN = MAX(1, NSUB) for column 2-norm computation +* + LWKMIN = MAX( 1, NSUB ) * * Optimal workspace for column 2-norm computation. * - LWKOPT = NSUB + LWKOPT = LWKMIN * -* Query for optimal workspace size for DGEQRF. +* Call of DGEQRF. +* + IF( NSEL.GT.0 ) THEN * - CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, -1, IINFO ) - LWKMIN = MAX( LWKMIN, NSEL ) - LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* Real minimum workspace computation. +* b) LWKMIN = MAX(1, NSEL) for the call of DGEQRF. +* We can skip counting this workspace as +* LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. * -* Query for optimal workspace size for DGEQP3RK. +* Query for optimal workspace size for DGEQRF. +* + CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) * - CALL DGEQP3RK( MFREE, NFREE, 0, NFREE, - $ MINUSONE, MINUSONE, - $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, - $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), - $ WORK, -1, IWORK, IINFO ) - LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* Call of DORMQR. * -* Integer workspace. -* N is for DGEQP3RK and N-1 for JPIV ajustment. + IF( NFREE.GT.0 ) THEN +* +* Real minimum workspace computation. +* c) NOTE: minimum workspace requirement for DORMQR +* LWKMIN = MAX(1, NFREE) is smaller than +* LWKMIN = 3*NFREE-1 for DGEQP3RK and it is +* smaller than NSUB. We can skip counting this +* workspace as LWKMIN = MAX( LWKMIN, NFREE ). +* +* Query for optimal workspace size for DORMQR. +* + CALL DORMQR( 'L', 'T', MSUB, NFREE, + $ NSEL, A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) + END IF +* + END IF +* +* Call of DGEQP3RK. +* + LIWKMIN = 1 + IF ( MINMNFREE.NE.0 ) THEN * - LIWKMIN = MAX( 1, N + N-1 ) - LIWKOPT = LIWKMIN +* Real minimum workspace computation. +* d) LWKMIN = MAX(1, 3*NFREE-1) for the call of DGEQP3RK. +* + LWKMIN = MAX( LWKMIN, 3*NFREE - 1 ) +* +* Query for optimal workspace size for DGEQP3RK. +* + CALL DGEQP3RK( MFREE, NFREE, 0, NFREE, + $ MINUSONE, MINUSONE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), + $ WORK, -1, IWORK, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* Integer minimum workspace compuation. +* aa) LIWKMIN = NFREE-1 for the call of DGEQP3RK. +* + LIWKMIN = MAX( LIWKMIN, NFREE-1 ) +* + IF( NSEL.NE.0 ) THEN +* +* Integer minimum workspace compuation. +* bb) NFREE is for DGEQP3RK and NFREE-1 for JPIV ajustment. +* + LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) + END IF +* + END IF * IF( RETURNC ) THEN - LIWKMIN = MAX( LIWKOPT, N ) - LIWKOPT = LIWKMIN +* +* Integer minimum workspace compuation. +* cc) LIWKMIN = N for applying the interchanges for +* the columns in the matrix C. +* + LIWKMIN = MAX( LIWKMIN, N ) END IF -* + LIWKOPT = LIWKMIN +* +* Call of DGELS. +* IF( RETURNX ) THEN -* - LWKMIN = MAX( LWKMIN, MIN(M,N) + N ) +* +* Real minimum workspace computation. +* e) LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = +* = max( 1, MINMN + N ) for the call of DGELS. +* + LWKMIN = MAX( LWKMIN, MINMN + N ) * * Query for optimal workspace size for DGELS. * - CALL DGELS( 'N', M, N, N, QRC, LDQRC, X, LDX, + KMAXLS = MINMN +* + CALL DGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, $ WORK, -1, IINFO ) LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) * - END IF + END IF * -* End of ELSE( LSAME( USESD, 'N') ) +* End of ELSE( LSAME( USESD, 'N') .OR. LSAME( USESD, 'R' ) ) * END IF * @@ -1282,9 +1378,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( NFREE.GT.0 ) THEN * -* This is only for case (c-2). +* This is only for case (c-2) ('L' = Left, 'T' = Transpose) * - CALL DORMQR( 'Left', 'Transpose', MSUB, NFREE, NSEL, + CALL DORMQR( 'L', 'T', MSUB, NFREE, NSEL, $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, $ LWORK, IINFO ) END IF @@ -1299,7 +1395,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * KFREE = 0 * - IF( MIN( MFREE, NFREE ).NE.0 ) THEN + IF( MINMNFREE.NE.0 ) THEN * * Factorize NFREE free columns of * A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), @@ -1456,9 +1552,10 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, INFO = IINFO * END IF +* WORK( 1 ) = DBLE( LWKOPT ) IWORK( 1 ) = LIWKOPT * -* DGECXX +* End of DGECXX * END From 15b48d2e5bc990983c850b738aed81228410ef25 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Wed, 18 Mar 2026 17:25:10 -0700 Subject: [PATCH 12/63] dgecxx.f : simplified workspace calculation --- SRC/dgecxx.f | 216 ++++++++++++++++++--------------------------------- 1 file changed, 75 insertions(+), 141 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index a3df48411..1926b1409 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -961,184 +961,118 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, LIWKOPT = 1 ELSE * - IF( LSAME( USESD, 'N') .OR. LSAME( USESD, 'R' ) ) THEN -* -* Real minimum workspace computation. -* a) LWKMIN = NSUB = N for column 2-norm computation -* b) LWKMIN = 3*NFREE+1 = 3*N-1 for the call of DGEQP3RK. -* Therefore: -* - LWKMIN = MAX( 1, 3*N - 1 ) -* -* Optimal workspace for column 2-norm computation. +* Real minimum workspace computation. +* a) LWKMIN = MAX(1, NSUB) for column 2-norm computation +* + LWKMIN = MAX( 1, NSUB ) * - LWKOPT = MAX( 1 , N ) -* -* Query for optimal workspace size for DGEQP3RK. -* - CALL DGEQP3RK( M, N, 0, N, - $ MINUSONE, MINUSONE, - $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, - $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), - $ WORK, -1, IWORK, IINFO ) - LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) -* -* Integer minimum workspace compuation. -* aa) LIWKMIN = NFREE-1 = N-1 for the call of DGEQP3RK. -* - LIWKMIN = MAX( 1, N-1 ) -* - IF( RETURNC ) THEN -* -* Integer minimum workspace compuation. -* bb) LIWKMIN = N for applying the interchanges for -* the columns in the matrix C. -* - LIWKMIN = MAX( LIWKMIN, N ) -* - END IF - LIWKOPT = LIWKMIN -* -* Call of DGELS. -* - IF( RETURNX ) THEN -* -* Real minimum workspace computation. -* c) LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = -* = max( 1, MINMN + N ) for the call of DGELS. -* NOTE: MINMN + N < 3*N + 1, therfore effectively, -* LWKMIN = MAX( LWKMIN, MINMN + N ) = 3*N + 1 -* - LWKMIN = MAX( LWKMIN, MINMN + N ) -* -* Query for optimal workspace size for DGELS. -* - KMAXLS = MINMN -* - CALL DGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, - $ WORK, -1, IINFO ) - LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) -* - END IF -* -* End IF( LSAME( USESD, 'N') .OR. LSAME( USESD, 'R' ) ) +* aa) Initial integer minimum workspace * - ELSE -* -* Begin of ELSE( LSAME( USESD, 'N') .OR. LSAME( USESD, 'R' ) ) -* -* Real minimum workspace computation. -* a) LWKMIN = MAX(1, NSUB) for column 2-norm computation -* - LWKMIN = MAX( 1, NSUB ) + LIWKMIN = 1 * -* Optimal workspace for column 2-norm computation. +* Optimal workspace for column 2-norm computation. * - LWKOPT = LWKMIN + LWKOPT = LWKMIN * -* Call of DGEQRF. +* Call of DGEQRF. * - IF( NSEL.GT.0 ) THEN + IF( NSEL.GT.0 ) THEN * -* Real minimum workspace computation. -* b) LWKMIN = MAX(1, NSEL) for the call of DGEQRF. -* We can skip counting this workspace as -* LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. +* Real minimum workspace computation. +* b) LWKMIN = MAX(1, NSEL) for the call of DGEQRF. +* We can skip counting this workspace as +* LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. * -* Query for optimal workspace size for DGEQRF. +* Query for optimal workspace size for DGEQRF. * - CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, + CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, $ -1, IINFO ) - LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) -* -* Call of DORMQR. -* - IF( NFREE.GT.0 ) THEN -* -* Real minimum workspace computation. -* c) NOTE: minimum workspace requirement for DORMQR -* LWKMIN = MAX(1, NFREE) is smaller than -* LWKMIN = 3*NFREE-1 for DGEQP3RK and it is -* smaller than NSUB. We can skip counting this -* workspace as LWKMIN = MAX( LWKMIN, NFREE ). + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) * -* Query for optimal workspace size for DORMQR. +* Call of DORMQR. * - CALL DORMQR( 'L', 'T', MSUB, NFREE, - $ NSEL, A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, - $ -1, IINFO ) - LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) - END IF + IF( NFREE.GT.0 ) THEN * +* Real minimum workspace computation. +* c) NOTE: minimum workspace requirement for DORMQR +* LWKMIN = MAX(1, NFREE) is smaller than +* LWKMIN = 3*NFREE-1 for DGEQP3RK and it is +* smaller than NSUB. We can skip counting this +* workspace as LWKMIN = MAX( LWKMIN, NFREE ). +* +* Query for optimal workspace size for DORMQR. +* + CALL DORMQR( 'L', 'T', MSUB, NFREE, + $ NSEL, A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) END IF * -* Call of DGEQP3RK. + END IF +* +* Call of DGEQP3RK. * - LIWKMIN = 1 - IF ( MINMNFREE.NE.0 ) THEN + + IF ( MINMNFREE.NE.0 ) THEN * -* Real minimum workspace computation. -* d) LWKMIN = MAX(1, 3*NFREE-1) for the call of DGEQP3RK. +* Real minimum workspace computation. +* d) LWKMIN = MAX(1, 3*NFREE-1) for the call of DGEQP3RK. * - LWKMIN = MAX( LWKMIN, 3*NFREE - 1 ) + LWKMIN = MAX( LWKMIN, 3*NFREE - 1 ) * -* Query for optimal workspace size for DGEQP3RK. +* Query for optimal workspace size for DGEQP3RK. * - CALL DGEQP3RK( MFREE, NFREE, 0, NFREE, - $ MINUSONE, MINUSONE, - $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, - $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), - $ WORK, -1, IWORK, IINFO ) - LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) + CALL DGEQP3RK( MFREE, NFREE, 0, NFREE, + $ MINUSONE, MINUSONE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), + $ WORK, -1, IWORK, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) * -* Integer minimum workspace compuation. -* aa) LIWKMIN = NFREE-1 for the call of DGEQP3RK. +* Integer minimum workspace compuation. +* bb) LIWKMIN = NFREE-1 for the call of DGEQP3RK. * - LIWKMIN = MAX( LIWKMIN, NFREE-1 ) + LIWKMIN = MAX( LIWKMIN, NFREE-1 ) * - IF( NSEL.NE.0 ) THEN + IF( NSEL.NE.0 ) THEN * -* Integer minimum workspace compuation. -* bb) NFREE is for DGEQP3RK and NFREE-1 for JPIV ajustment. +* Integer minimum workspace compuation. +* cc) NFREE is for DGEQP3RK and NFREE-1 for JPIV ajustment. * - LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) - END IF -* + LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) END IF * - IF( RETURNC ) THEN + END IF +* + IF( RETURNC ) THEN * -* Integer minimum workspace compuation. -* cc) LIWKMIN = N for applying the interchanges for -* the columns in the matrix C. +* Integer minimum workspace compuation. +* dd) LIWKMIN = N for applying the interchanges for +* the columns in the matrix C. * - LIWKMIN = MAX( LIWKMIN, N ) - END IF - LIWKOPT = LIWKMIN + LIWKMIN = MAX( LIWKMIN, N ) + END IF + LIWKOPT = LIWKMIN * -* Call of DGELS. +* Call of DGELS. * - IF( RETURNX ) THEN + IF( RETURNX ) THEN * -* Real minimum workspace computation. -* e) LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = -* = max( 1, MINMN + N ) for the call of DGELS. +* Real minimum workspace computation. +* e) LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = +* = max( 1, MINMN + N ) for the call of DGELS. * - LWKMIN = MAX( LWKMIN, MINMN + N ) + LWKMIN = MAX( LWKMIN, MINMN + N ) * -* Query for optimal workspace size for DGELS. +* Query for optimal workspace size for DGELS. * - KMAXLS = MINMN + KMAXLS = MINMN * - CALL DGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, - $ WORK, -1, IINFO ) - LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) + CALL DGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, + $ WORK, -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) * - END IF -* -* End of ELSE( LSAME( USESD, 'N') .OR. LSAME( USESD, 'R' ) ) -* - END IF + END IF * * End of ELSE for IF( MINMN.EQ.0 ) * From caea6400802f2f1ef75843fa27e987b484973ed5 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Fri, 20 Mar 2026 15:39:35 -0700 Subject: [PATCH 13/63] dgecxx.f modified the description of LWORK and LIWORK --- SRC/dgecxx.f | 52 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 33 insertions(+), 19 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 1926b1409..1cbd0f25a 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -713,6 +713,21 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. +*> +*> Minimal LWORK workspace requirement. +*> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> For good performance, LWORK should generally be larger, and +*> the user should query the routine for the optimal LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK and IWORK arrays, +*> returns these values as the first entry of the WORK and IWORK +*> arrays respectively, and no error message related to LWORK +*> is issued by XERBLA. +*> +*> Exact minimal workspcae requirements. *> For USESD = 'N' or 'R' and for all FACT: *> LWORK >= max( 1, 3*N - 1 ) *> For USESD = 'C' or 'A': @@ -722,15 +737,6 @@ *> LWORK >= max( 1, min(M,N)+N, *> min(1,MINMNFREE)*(3*N_free-1) ) *> where MINMNFREE = min( M_free, N_free ). -*> -*> For good performance, LWORK should generally be larger, and -*> the user should query the routine for the optimal LWORK. -*> -*> If LWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK and IWORK arrays, -*> returns these values as the first entry of the WORK and IWORK -*> arrays respectively, and no error message related to LWORK -*> is issued by XERBLA. *> \endverbatim *> *> \param[out] IWORK @@ -744,16 +750,12 @@ *> \verbatim *> LIWORK is INTEGER *> The dimension of the array LIWORK. -*> For USESD = 'N' or 'R': -*> a) If FACT = 'P': -*> min LIWORK >= max( 1, N-1 ) -*> b) If FACT = 'C' or 'X': -*> min LIWORK >= max( 1, N) -*> For USESD = 'C' or 'A': -*> a) If FACT = 'P': -*> min LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) -*> b) If FACT = 'C' or 'X': -*> min LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +*> +*> Minimal LIWORK workspace requirement. +*> For USESD = 'N' or 'R': LIWORK >= max( 1, N ) +*> for all FACT flags. +*> For USESD = 'C' or 'A': LIWORK >= max( 1, 2N - 1 ) +*> for all FACT flags. *> *> The optimal LIWORK is the same as the minimal LIWORK. *> The user can still query the routine for the optimal LIWORK. @@ -763,6 +765,18 @@ *> returns these values as the first entry of the WORK and IWORK *> arrays respectively, and no error message related to LIWORK *> is issued by XERBLA. +*> +*> Exact minimal workspcae requirements. +*> For USESD = 'N' or 'R': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, N-1 ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, N ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) *> \endverbatim *> *> \param[out] INFO From 9168094c89286f6718fca30b5ec2f773fdbbecc1 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 26 Mar 2026 15:47:58 -0700 Subject: [PATCH 14/63] dgecxx.f: updated description of FACT parameter, and LWORK parameter to include NX crosspver point --- SRC/dgecxx.f | 49 +++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 41 insertions(+), 8 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 1cbd0f25a..068c605ae 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -209,18 +209,22 @@ *> *> = 'C': the routine returns: *> (1) the column permutation matrix P -*> in the array JPIV. -*> (2) the factor C explicitly in the array C. +*> in the array JPIV. (The first K elements are +*> indicies of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. *> (slower option, more memory space) *> *> = 'X': the routine returns: *> (1) the column permutation matrix P in -*> the array JPIV. -*> (2) the factor C explicitly in the array C. -*> (3) the factor X explicitly in the array X. -*> (4) the factor R and the Householder vectors -*> of the QR factorization of the factor C -*> in the array QRC. +*> the array JPIV. (The first K elements are +*> indicies of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (3) the K-by-N factor X explicitly in the array X. +*> (4) the K-by-K upper triangular factor R and +*> the Householder vectors of the QR factorization +*> of the factor C in the array QRC. *> ( The factor R may be useful for checking *> the factor C for singularity, in which case *> R will have a zero on the diagonal, and @@ -737,6 +741,35 @@ *> LWORK >= max( 1, min(M,N)+N, *> min(1,MINMNFREE)*(3*N_free-1) ) *> where MINMNFREE = min( M_free, N_free ). +*> +*> NOTE: The decision, whether the routine uses unblocked +*> BLAS 2 or blocked BLAS 3 code is based not only on the +*> dimension LWORK of the availbale workspace WORK, but +*> also on: +*> 1) the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine DGEQRF +*> in comparison to min(M,N_sel). (For +*> min(M_sub, N_sel) <= NX or min(M_sub, N_sel) <= NB, +*> unblocked code is used in DGEQRF.) +*> 2) the optimal block size NB returned by ILAENV for +*> the routine DORMQR in comparison to N_sel. (For +*> N_sel <= NB, unblocked code should is used in +*> DORMQR.) +*> 3) the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine DGEQRP3RK +*> in comparison to min(M,N_sel). (For +*> min(M_sub, N_free, KMAXFREE) <= NX +*> or min(M_sub, N_free, KMAXFREE) <= NB, unblocked code +*> is used in DGEQRP3RK.) +*> 4a) the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine DGEQRF +*> in comparison to min(M,K). (For min(M,K) <= NX +*> or min(M,K) <= NB, unblocked code is used in +*> DGEQRF inside DGELS.) +*> 4b) the optimal block size NB returned by ILAENV for +*> the routine DORMQR in comparison to N. (For +*> N <= NB, unblocked code should is used in +*> DORMQR inside DGELS.) *> \endverbatim *> *> \param[out] IWORK From 6ce7d80602dc2e43ebfcc38b4aa3b365a9cb2360 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 26 Mar 2026 20:18:44 -0700 Subject: [PATCH 15/63] dgecxx.f: corrected the descriptions of QRC, X and LDX parameters --- SRC/dgecxx.f | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 068c605ae..6835995b6 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -646,7 +646,7 @@ *> If FACT = 'C' or 'X': *> If USESD = 'N', the array dimension is (LDC,min(M,N)). *> If USESD = 'C' or 'R' or 'A', -*> the array dimension is (LDC,min(M_sub,N_sub)). +*> the array dimension is (LDC,min(M_sub,N_sub)). *> *> If K = 0, the array is not used. *> If K > 0, the array C stores the M-by-K factor C. @@ -667,9 +667,9 @@ *> the array dimension is >= (1,1). *> If FACT = 'X': *> If USESD = 'N', -*> the array dimension is (LDQRC,min(M,N)). +*> the array dimension is (LDQRC,min(M,N)). *> If USESD = 'C' or 'R' or 'A', -*> the array dimension is (LDC,min(M_sub,N_sub)). +*> the array dimension is (LDQRC,min(M_sub,N_sub)). *> *> If K = 0, the array is not used. *> If K > 0, QRC(1:M_sub,1:K) stores two components from @@ -702,8 +702,8 @@ *> \verbatim *> LDX is INTEGER *> The leading dimension of the array X. -*> If FACT = 'P' or 'C', LDQRC >= 1. -*> If FACT = 'X', LDQRC >= max(1,M). +*> If FACT = 'P' or 'C', LDX >= 1. +*> If FACT = 'X', LDX >= max(1,M). *> \endverbatim *> *> \param[out] WORK From 7689fc123b19f084b78669238d29987fda89f526 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 26 Mar 2026 22:38:25 -0700 Subject: [PATCH 16/63] dgecxx.f: corrected the description of LWORK parameter regarding NX crossover point. --- SRC/dgecxx.f | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 6835995b6..c453727c7 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -746,30 +746,32 @@ *> BLAS 2 or blocked BLAS 3 code is based not only on the *> dimension LWORK of the availbale workspace WORK, but *> also on: -*> 1) the optimal block size NB, the crossover point NX +*> 1a) colum preselection stage using DGEQRF: +*> the optimal block size NB, the crossover point NX *> returned by ILAENV for the routine DGEQRF -*> in comparison to min(M,N_sel). (For -*> min(M_sub, N_sel) <= NX or min(M_sub, N_sel) <= NB, -*> unblocked code is used in DGEQRF.) -*> 2) the optimal block size NB returned by ILAENV for +*> in comparison to N_sel. (For N_sel <= NX +*> or N_sel <= NB, unblocked code is used in DGEQRF.) +*> 1b) column preselection stage using DORMQR: +*> the optimal block size NB returned by ILAENV for *> the routine DORMQR in comparison to N_sel. (For -*> N_sel <= NB, unblocked code should is used in -*> DORMQR.) -*> 3) the optimal block size NB, the crossover point NX +*> N_sel <= NB, unblocked code is used in DORMQR.) +*> 2) column selection stage via criteria using DGEQRP3RK: +*> the optimal block size NB, the crossover point NX *> returned by ILAENV for the routine DGEQRP3RK *> in comparison to min(M,N_sel). (For *> min(M_sub, N_free, KMAXFREE) <= NX *> or min(M_sub, N_free, KMAXFREE) <= NB, unblocked code -*> is used in DGEQRP3RK.) -*> 4a) the optimal block size NB, the crossover point NX +*> is used in DGEQRP3RK.) +*> 3a) computation of the factor X using DGEQRF in DGELS: +*> the optimal block size NB, the crossover point NX *> returned by ILAENV for the routine DGEQRF -*> in comparison to min(M,K). (For min(M,K) <= NX -*> or min(M,K) <= NB, unblocked code is used in -*> DGEQRF inside DGELS.) -*> 4b) the optimal block size NB returned by ILAENV for +*> in comparison to K. (For K <= NX or K <= NB, +*> unblocked code is used in DGEQRF inside DGELS.) +*> 3b) computation of the factor X using DORMQR in DGELS: +*> the optimal block size NB returned by ILAENV for *> the routine DORMQR in comparison to N. (For -*> N <= NB, unblocked code should is used in -*> DORMQR inside DGELS.) +*> N <= NB, unblocked code is used in DORMQR +*> inside DGELS.) *> \endverbatim *> *> \param[out] IWORK From 68d8fba5c112de973b69445a8faa9d6cd3c4ce3e Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 31 Mar 2026 13:06:44 -0700 Subject: [PATCH 17/63] dgecxx.f: corrected the LDX minimum value and description from: If FACT = 'X', LDX >= max(1,M) to LDX >= max(1,min(M,N)) --- SRC/dgecxx.f | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index c453727c7..d1a27f409 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -695,7 +695,8 @@ *> If FACT = 'X': *> The array dimension is (LDX,N). *> If K = 0, the array is not used. -*> If K > 0, the array X stores the K-by-N factor X. +*> If K > 0, the array X stores the K-by-N factor X, +*> where K<=N. *> \endverbatim *> *> \param[in] LDX @@ -703,7 +704,7 @@ *> LDX is INTEGER *> The leading dimension of the array X. *> If FACT = 'P' or 'C', LDX >= 1. -*> If FACT = 'X', LDX >= max(1,M). +*> If FACT = 'X', LDX >= max(1,min(M,N)). *> \endverbatim *> *> \param[out] WORK @@ -906,6 +907,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, NSUB = N MFREE = MSUB NFREE = NSUB + MINMN = MIN( M, N ) * LQUERY = ( LWORK.EQ.-1 ) LIQUERY = ( LIWORK.EQ.-1 ) @@ -981,7 +983,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN INFO = -22 * This is a check for LDX - ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, MINMN ) ) $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN INFO = -24 END IF @@ -1002,7 +1004,6 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * unblocked code. * IF( INFO.EQ.0 ) THEN - MINMN = MIN( M, N ) IF( MINMN.EQ.0 ) THEN LWKMIN = 1 LWKOPT = 1 From d35cd9a2965bb2ba47b5d1dfec532f7fbefdc3fd Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Wed, 1 Apr 2026 13:26:51 -0700 Subject: [PATCH 18/63] dgecxx.f: corrected speclling the comments inside the code --- SRC/dgecxx.f | 82 ++++++++++++++++++++++++++-------------------------- 1 file changed, 41 insertions(+), 41 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index d1a27f409..e98a7c596 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -210,7 +210,7 @@ *> = 'C': the routine returns: *> (1) the column permutation matrix P *> in the array JPIV. (The first K elements are -*> indicies of the selected columns from +*> indices of the selected columns from *> the matrix A.) *> (2) the M-by-K factor C explicitly in the array C. *> (slower option, more memory space) @@ -218,7 +218,7 @@ *> = 'X': the routine returns: *> (1) the column permutation matrix P in *> the array JPIV. (The first K elements are -*> indicies of the selected columns from +*> indices of the selected columns from *> the matrix A.) *> (2) the M-by-K factor C explicitly in the array C. *> (3) the K-by-N factor X explicitly in the array X. @@ -726,13 +726,13 @@ *> For good performance, LWORK should generally be larger, and *> the user should query the routine for the optimal LWORK. *> -*> If LWORK = -1, then a workspace query is assumed; the routine +*> If LWORK = -1, then a workspace query is assumed. The routine *> only calculates the optimal size of the WORK and IWORK arrays, *> returns these values as the first entry of the WORK and IWORK *> arrays respectively, and no error message related to LWORK *> is issued by XERBLA. *> -*> Exact minimal workspcae requirements. +*> Exact minimal workspace requirements. *> For USESD = 'N' or 'R' and for all FACT: *> LWORK >= max( 1, 3*N - 1 ) *> For USESD = 'C' or 'A': @@ -802,7 +802,7 @@ *> arrays respectively, and no error message related to LIWORK *> is issued by XERBLA. *> -*> Exact minimal workspcae requirements. +*> Exact minimal workspace requirements. *> For USESD = 'N' or 'R': *> a) If FACT = 'P': *> LIWORK >= max( 1, N-1 ) @@ -933,7 +933,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * cannot be larger than MSUB, which is the number of rows * without MDESEL deselected rows. When the number of * preselected columns NSEL is larger than MSUB, -* the factorizationof all preselected NSEL columns cannot be +* the factorization of all preselected NSEL columns cannot be * completed. MSUB also will be used for LDX argument check * later. * @@ -951,7 +951,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, IF( USE_SEL_DESEL_COLS ) THEN * * Count the number of preselected columns NSEL and the -* number of preselected and freecolumns NSUB = N - NDESEL. +* number of preselected and free columns NSUB = N - NDESEL. * DO J = 1, N IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 @@ -1000,7 +1000,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * (1) LQUERY = .TRUE., * (2) LIQUERY = .TRUE., * (3) when the routine exits. -* Here, LWKMIN and LIWKMIN are the miminum workspaces required for +* Here, LWKMIN and LIWKMIN are the minimum workspaces required for * unblocked code. * IF( INFO.EQ.0 ) THEN @@ -1011,12 +1011,12 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, LIWKOPT = 1 ELSE * -* Real minimum workspace computation. -* a) LWKMIN = MAX(1, NSUB) for column 2-norm computation +* (Real_wk_part_a) Real minimum workspace computation. +* LWKMIN = MAX(1, NSUB) for column 2-norm computation * LWKMIN = MAX( 1, NSUB ) * -* aa) Initial integer minimum workspace +* (Int_wk_part_1) Integer minimum workspace computation. * LIWKMIN = 1 * @@ -1028,8 +1028,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( NSEL.GT.0 ) THEN * -* Real minimum workspace computation. -* b) LWKMIN = MAX(1, NSEL) for the call of DGEQRF. +* (Real_wk_part_b) Real minimum workspace computation. +* LWKMIN = MAX(1, NSEL) for the call of DGEQRF. * We can skip counting this workspace as * LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. * @@ -1043,8 +1043,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( NFREE.GT.0 ) THEN * -* Real minimum workspace computation. -* c) NOTE: minimum workspace requirement for DORMQR +* (Real_wk_part_c) Real minimum workspace computation. +* NOTE: minimum workspace requirement for DORMQR * LWKMIN = MAX(1, NFREE) is smaller than * LWKMIN = 3*NFREE-1 for DGEQP3RK and it is * smaller than NSUB. We can skip counting this @@ -1065,8 +1065,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, IF ( MINMNFREE.NE.0 ) THEN * -* Real minimum workspace computation. -* d) LWKMIN = MAX(1, 3*NFREE-1) for the call of DGEQP3RK. +* (Real_wk_part_d) Real minimum workspace computation. +* LWKMIN = MAX(1, 3*NFREE-1) for the call of DGEQP3RK. * LWKMIN = MAX( LWKMIN, 3*NFREE - 1 ) * @@ -1079,15 +1079,15 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ WORK, -1, IWORK, IINFO ) LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) * -* Integer minimum workspace compuation. -* bb) LIWKMIN = NFREE-1 for the call of DGEQP3RK. +* (Int_wk_part_2) Integer minimum workspace computation. +* LIWKMIN = NFREE-1 for the call of DGEQP3RK. * LIWKMIN = MAX( LIWKMIN, NFREE-1 ) * IF( NSEL.NE.0 ) THEN * -* Integer minimum workspace compuation. -* cc) NFREE is for DGEQP3RK and NFREE-1 for JPIV ajustment. +* (Int_wk_part_3) Integer minimum workspace computation. +* NFREE is for DGEQP3RK and NFREE-1 for JPIV adjustment. * LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) END IF @@ -1096,9 +1096,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( RETURNC ) THEN * -* Integer minimum workspace compuation. -* dd) LIWKMIN = N for applying the interchanges for -* the columns in the matrix C. +* Integer minimum workspace computation. +* (Int_wk_part_3) LIWKMIN = N for applying the interchanges +* for the columns in the matrix C. * LIWKMIN = MAX( LIWKMIN, N ) END IF @@ -1108,9 +1108,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( RETURNX ) THEN * -* Real minimum workspace computation. -* e) LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = -* = max( 1, MINMN + N ) for the call of DGELS. +* (Real_wk_part_d) Real minimum workspace computation. +* LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = +* = max( 1, MINMN + N ) for the call of DGELS. * LWKMIN = MAX( LWKMIN, MINMN + N ) * @@ -1158,7 +1158,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, CALL DLACPY( 'F', M, N, A, LDA, C, LDC ) END IF * -* If we need to return factor X, copy the original unctouched matrix +* If we need to return factor X, copy the original untouched matrix * A into the array X. * IF( RETURNX ) THEN @@ -1172,13 +1172,13 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * ================================================================== * * I is the index of DESEL_ROWS array and row I of the matrix A. -* MSUB is the number of included rows, i.e rows of the matrix A without +* MSUB is the number of included rows, i.e. rows of the matrix A without * deselected rows. * (For each position I, we check if this position is an included row. * If it is an included row, we increment MSUB, which is also a pointer * to the last included row, otherwise we do not change MSUB pointer. * Also, if it is an included row, we move this row from the larger -* (or same) I index into samaller (or same) MSUB index. This way +* (or same) I index into smaller (or same) MSUB index. This way * we move all the included rows to the larger index block preserving * included row order. The deselected rows will be at the bottom of the * matrix A.) @@ -1338,7 +1338,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * Case (a): MSUB < NSEL. * * This is handled at the argument check stage in the -* begining of the routine. When the number of preselected +* beginning of the routine. When the number of preselected * columns is larger than MSUB, hence the factorization of * all NSEL columns cannot be completed. Return from the * routine with the error of COL_SEL_DESEL parameter. @@ -1346,7 +1346,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * Case (b): MSUB = NSEL. * Case (c-1): MSUB > NSEL and NSEL = NSUB. * -* For cases (b) and (c-1), ther will be no residual +* For cases (b) and (c-1), there will be no residual * submatrix after factorization of NSEL columns * at step K = NSEL: * A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). @@ -1393,7 +1393,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, USETOL = .FALSE. * * Adjust ABSTOL only if nonnegative. Negative value means disabled. -* We need to keep negtive value for later use in criterion +* We need to keep negative value for later use in criterion * check. * IF( ABSTOL.GE.ZERO ) THEN @@ -1402,8 +1402,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, USETOL = .TRUE. END IF * -* Ajust RELTOL only if nonnegative. Negative value means disabled. -* We need to keep negtive value for later use in criterion +* Adjust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion * check. * IF( RELTOL.GE.ZERO ) THEN @@ -1416,11 +1416,11 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * Disable RELTOLFREE when calling DGEQP3RK for free columns * factorization, since DGEQP3RK expects RELTOLFREE with respect * to the residual matrix A_sub_resid(NSEL), not the whole -* original marix A. We can use RELTOL criterion by passing it +* original matrix A. We can use RELTOL criterion by passing it * to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that * the negative values of ABSTOL and RELTOL are propagated * to ABSTOLFREE and RELTOLFREE, since negative values means -* that the criterionis is disabled. +* that the criterion is disabled. * IF( USETOL ) THEN ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) @@ -1443,7 +1443,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ RELMAXC2NRMKFREE, JPIV( NSEL+1 ), $ TAU( NSEL+1 ), WORK, LWORK, IWORK, IINFO ) * -* Ajust JPIV +* Adjust JPIV * IF( NSEL.NE.0 ) THEN DO J = 1, NFREE, 1 @@ -1495,7 +1495,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * Apply interchanges to columns 1:K in the matrix C in place, * which stores the original matrix A. * IWORK(1:N) is used to keep track of original column indices, -* when swaping columns. +* when swapping columns. * DO J = 1, N, 1 IWORK( J ) = J @@ -1526,8 +1526,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * We need to use C and A to compute X = pseudoinv(C) * A, as * the Linear Least Squares problem C*X = A. We use LLS routine * that uses QR factorization. For that purpose, we store -* the matrix C into the arrray QRC, and the matrix A was copied -* into the array X at the begining of the routine. +* the matrix C into the array QRC, and the matrix A was copied +* into the array X at the beginning of the routine. * CALL DLACPY( 'F', M, K, C, LDC, QRC, LDQRC ) * From 5478f985ad091190f0424023b37de37946651707 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 2 Apr 2026 00:04:45 -0700 Subject: [PATCH 19/63] dgecxx.f: version 2 of the factor C generation algorithm --- SRC/dgecxx.f | 79 +++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 59 insertions(+), 20 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index e98a7c596..f08470a48 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -30,7 +30,7 @@ * CHARACTER FACT, USESD * INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, * $ LDX, LIWORK, LWORK, M, N -* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, * $ RELMAXC2NRMK, FNRMK * .. * .. Array Arguments .. @@ -875,9 +875,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL INTEGER I, J, NSUB, MFREE, MSUB, NSEL, JDESEL, $ ITEMP, IINFO, KFREE, KMAXLS, KP0, - $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, JP, JJ, JPW, - $ MRESID, NRESID, MINMN, MINMNFREE, MDESEL, - $ NDESEL, NFREE + $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, JP, JJ, + $ JP_DRAIN, JP_SOURCE, MRESID, NRESID, MINMN, + $ MINMNFREE, MDESEL, NDESEL, NFREE DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN @@ -1484,42 +1484,81 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, ELSE FNRMK = ZERO END IF -* * * ================================================================== * -* Construct matrix C. +* Return the matrix C. * IF( RETURNC .AND. K.GT.0 ) THEN * -* Apply interchanges to columns 1:K in the matrix C in place, -* which stores the original matrix A. -* IWORK(1:N) is used to keep track of original column indices, -* when swapping columns. +* Apply interchanges to columns 1:K in the M-by-N array C in place, +* which already stores the original M-by-N matrix A. The matrix A +* was copied into the array C at the beginning of the routine, +* if RETURNC = .TRUE.. +* +* The first K columns of C should be the same as the first +* K columns of A*P, i.e. (A*P)(1:M,1:K) = C(1:M,1:K) * +* JPIV(1:N) contains final desired interchanges of the colums +* in the array C. This means, the column J in C afther all column +* interchanges was the column JPIV(J) in C before the column +* interchanges. +* +* We use IWORK(1:N) to store the original column indices, +* when interchanging columns in C at each step. IWORK(1:K) should +* be the same as JPIV(1:K) after all column interchanges. + +* Initialize IWORK(1:N) to 1:N, which are the original column +* indices. +* DO J = 1, N, 1 IWORK( J ) = J END DO +* +* Loop over the columns J = (1:K) in C. +* At each step, we want to swap the desired original column JPIV(J) +* into position J. +* DO J = 1, K, 1 - JP = JPIV( J ) - IF( J.NE.JP ) THEN - DO JJ = J, N, 1 - IF( JP.EQ.IWORK( JJ ) ) THEN - JPW = JJ +* +* JP_SOURCE is the index of the original column that +* should be placed in the index J. +* +* JP_DRAIN is the index of the original column that is +* currently in the index J in C after previous column +* interchanges. +* + JP_SOURCE = JPIV( J ) + JP_DRAIN = IWORK( J ) + IF( JP_DRAIN.NE.JP_SOURCE ) THEN +* +* Find the index JP of IWORK(J+1:N) at which IWORK(JP) has +* the same value as JP_SOURCE. +* + DO JJ = J+1, N, 1 + IF( IWORK( JJ ).EQ.JP_SOURCE ) THEN + JP = JJ END IF END DO - IF( J.NE.JPW ) THEN - CALL DSWAP( M, C( 1, J ), 1, C( 1, JPW ), 1 ) +* +* Swap current column J with the column JP in C, and swap +* the same columns in IWORK to keep track of the original +* column indices. +* + IF( J.NE.JP ) THEN + CALL DSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) ITEMP = IWORK( J ) - IWORK( J ) = IWORK( JPW ) - IWORK( JPW ) = ITEMP + IWORK( J ) = IWORK( JP ) + IWORK( JP ) = ITEMP END IF END IF END DO * END IF * -* Return matrix X. +* ================================================================== +* +* Return the matrix X. * IF( RETURNX .AND. K.GT.0 ) THEN * From b7445a3f93e9d1cadd6b2e3cdb2a5dd1a4087ab1 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 2 Apr 2026 14:06:02 -0700 Subject: [PATCH 20/63] dgecxx.f: commit 68d8fba5c112de973b69445a8faa9d6cd3c4ce3e was incorrect, so I reverted the description of LDX to now say again If FACT = 'X', LDX >= max(1,M), plus expanded the description of the parameter X. --- SRC/dgecxx.f | 62 ++++++++++++++++++++++++---------------------------- 1 file changed, 29 insertions(+), 33 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index f08470a48..576bf6cd3 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -692,11 +692,19 @@ *> X is DOUBLE PRECISION array. *> If FACT = 'P' or 'C': The array is not used, *> the array dimension is >= (1,1). -*> If FACT = 'X': -*> The array dimension is (LDX,N). -*> If K = 0, the array is not used. -*> If K > 0, the array X stores the K-by-N factor X, -*> where K<=N. +*> +*> If FACT = 'X': The array dimension is (LDX,N). +*> 1) If K = 0: +*> the array X contains a copy of +*> the original M-by-N matrix A. +*> 2) If K > 0: +*> a) rows (1:K) of B contain +*> the K-by-N factor X, where K <= N. +*> b) rows (K+1:M) of B. Each column of these +*> rows comtains the elements whose sum of +*> squres isthe residual sum of squares for +*> the solution in each column of the least +*> squares problem C*X = A for the unknown X). *> \endverbatim *> *> \param[in] LDX @@ -704,7 +712,7 @@ *> LDX is INTEGER *> The leading dimension of the array X. *> If FACT = 'P' or 'C', LDX >= 1. -*> If FACT = 'X', LDX >= max(1,min(M,N)). +*> If FACT = 'X', LDX >= max(1,M). *> \endverbatim *> *> \param[out] WORK @@ -875,8 +883,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL INTEGER I, J, NSUB, MFREE, MSUB, NSEL, JDESEL, $ ITEMP, IINFO, KFREE, KMAXLS, KP0, - $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, JP, JJ, - $ JP_DRAIN, JP_SOURCE, MRESID, NRESID, MINMN, + $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, JP, + $ MRESID, NRESID, MINMN, $ MINMNFREE, MDESEL, NDESEL, NFREE DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN @@ -983,7 +991,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN INFO = -22 * This is a check for LDX - ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, MINMN ) ) + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN INFO = -24 END IF @@ -1521,36 +1529,24 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * DO J = 1, K, 1 * -* JP_SOURCE is the index of the original column that +* JPIV( J ) is the index of the original column that * should be placed in the index J. * -* JP_DRAIN is the index of the original column that is +* IWORK( J )is the index of the original column that is * currently in the index J in C after previous column * interchanges. * - JP_SOURCE = JPIV( J ) - JP_DRAIN = IWORK( J ) - IF( JP_DRAIN.NE.JP_SOURCE ) THEN + IF( IWORK( J ).NE.JPIV( J ) ) THEN * -* Find the index JP of IWORK(J+1:N) at which IWORK(JP) has -* the same value as JP_SOURCE. -* - DO JJ = J+1, N, 1 - IF( IWORK( JJ ).EQ.JP_SOURCE ) THEN - JP = JJ - END IF - END DO -* -* Swap current column J with the column JP in C, and swap -* the same columns in IWORK to keep track of the original -* column indices. -* - IF( J.NE.JP ) THEN - CALL DSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) - ITEMP = IWORK( J ) - IWORK( J ) = IWORK( JP ) - IWORK( JP ) = ITEMP - END IF +* Swap the current column J with the column JP in C, and +* swap the same columns in IWORK to keep track of +* the original column indices. +* + JP = IWORK( JPIV( J ) ) + CALL DSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) + ITEMP = IWORK( J ) + IWORK( J ) = IWORK( JP ) + IWORK( JP ) = ITEMP END IF END DO * From 926e28e16c346a23607c0a08e554749d02d498b8 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 2 Apr 2026 14:44:25 -0700 Subject: [PATCH 21/63] dgecxx.f: cahanged the description of X, added notation for lls problem as min|| A - C*X||_F for the unknown X --- SRC/dgecxx.f | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 576bf6cd3..ba8523827 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -704,7 +704,8 @@ *> rows comtains the elements whose sum of *> squres isthe residual sum of squares for *> the solution in each column of the least -*> squares problem C*X = A for the unknown X). +*> squares problem +*> min|| A - C*X||_F for the unknown X. *> \endverbatim *> *> \param[in] LDX @@ -832,7 +833,7 @@ *> triangular R factor of the QR factorization of *> the matrix C is zero. Consequently, C does not have *> full rank, and X cannot be computed as the least -*> squares solution to C*X = A. +*> squares solution to the overdetermined system C*X = A. *> (R is stored in the array QRC.) *> \endverbatim * @@ -1559,10 +1560,11 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, IF( RETURNX .AND. K.GT.0 ) THEN * * We need to use C and A to compute X = pseudoinv(C) * A, as -* the Linear Least Squares problem C*X = A. We use LLS routine -* that uses QR factorization. For that purpose, we store -* the matrix C into the array QRC, and the matrix A was copied -* into the array X at the beginning of the routine. +* the linear least squares solution to the overdetermined system +* C*X = A. We use LLS routin that uses the QR factorization. For +* that purpose, we store the matrix C into the array QRC. +* The matrix A was copied into the array X at the beginning +* of the routine. * CALL DLACPY( 'F', M, K, C, LDC, QRC, LDQRC ) * From caf85813675ee6e0c864ba626f61ca79d490dcb1 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Fri, 3 Apr 2026 15:00:28 -0700 Subject: [PATCH 22/63] dgecxx.f: corrected and updated the description of the parameter X. --- SRC/dgecxx.f | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index ba8523827..e8b49b939 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -695,17 +695,17 @@ *> *> If FACT = 'X': The array dimension is (LDX,N). *> 1) If K = 0: -*> the array X contains a copy of +*> the M-by-N array X contains a copy of *> the original M-by-N matrix A. *> 2) If K > 0: -*> a) rows (1:K) of B contain +*> a) rows (1:K) of the M-by-N array X contain *> the K-by-N factor X, where K <= N. -*> b) rows (K+1:M) of B. Each column of these -*> rows comtains the elements whose sum of -*> squres isthe residual sum of squares for -*> the solution in each column of the least -*> squares problem -*> min|| A - C*X||_F for the unknown X. +*> b) rows (K+1:M) of the M-by-N array X. +*> Each column of these rows comtains the elements +*> whose sum of squares is the residual sum of +*> squares for the solution in each column of +*> the least squares problem. +*> min|| A - C*X ||_F for the unknown X. *> \endverbatim *> *> \param[in] LDX @@ -1531,10 +1531,10 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, DO J = 1, K, 1 * * JPIV( J ) is the index of the original column that -* should be placed in the index J. +* should be placed in the column index J in C * * IWORK( J )is the index of the original column that is -* currently in the index J in C after previous column +* currently in the column index J in C after previous column * interchanges. * IF( IWORK( J ).NE.JPIV( J ) ) THEN From 4c99ae7661c4c39d087dc82a01003b0e8f67b4c9 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Sun, 5 Apr 2026 20:46:40 -0700 Subject: [PATCH 23/63] dgecxx.f: changed the algorithm to generated matrix C, now it is verision 3. --- SRC/dgecxx.f | 124 +++++++++++++++++++++++++++++++-------------------- 1 file changed, 75 insertions(+), 49 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index e8b49b939..b3e1bf2e4 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -794,13 +794,10 @@ *> \param[in] LIWORK *> \verbatim *> LIWORK is INTEGER -*> The dimension of the array LIWORK. +*> The dimension of the array IWORK. *> -*> Minimal LIWORK workspace requirement. -*> For USESD = 'N' or 'R': LIWORK >= max( 1, N ) -*> for all FACT flags. -*> For USESD = 'C' or 'A': LIWORK >= max( 1, 2N - 1 ) -*> for all FACT flags. +*> Minimal LIWORK workspace general requirement. +*> For all FACT and USESD flags, LIWORK >= max( 1, 2*N ) *> *> The optimal LIWORK is the same as the minimal LIWORK. *> The user can still query the routine for the optimal LIWORK. @@ -816,12 +813,12 @@ *> a) If FACT = 'P': *> LIWORK >= max( 1, N-1 ) *> b) If FACT = 'C' or 'X': -*> LIWORK >= max( 1, N ) +*> LIWORK >= max( 1, 2N ) *> For USESD = 'C' or 'A': *> a) If FACT = 'P': *> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) *> b) If FACT = 'C' or 'X': -*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free, 2*N ) *> \endverbatim *> *> \param[out] INFO @@ -882,9 +879,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * .. Local Scalars .. LOGICAL LIQUERY, LQUERY, RETURNC, RETURNX, $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL - INTEGER I, J, NSUB, MFREE, MSUB, NSEL, JDESEL, + INTEGER I, IP, J, JP, NSUB, MFREE, MSUB, NSEL, JDESEL, $ ITEMP, IINFO, KFREE, KMAXLS, KP0, - $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, JP, + $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, $ MRESID, NRESID, MINMN, $ MINMNFREE, MDESEL, NDESEL, NFREE DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, @@ -1106,10 +1103,10 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, IF( RETURNC ) THEN * * Integer minimum workspace computation. -* (Int_wk_part_3) LIWKMIN = N for applying the interchanges +* (Int_wk_part_3) LIWKMIN = 2*N for applying the interchanges * for the columns in the matrix C. * - LIWKMIN = MAX( LIWKMIN, N ) + LIWKMIN = MAX( LIWKMIN, 2*N ) END IF LIWKOPT = LIWKMIN * @@ -1500,55 +1497,84 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( RETURNC .AND. K.GT.0 ) THEN * -* Apply interchanges to columns 1:K in the M-by-N array C in place, -* which already stores the original M-by-N matrix A. The matrix A -* was copied into the array C at the beginning of the routine, -* if RETURNC = .TRUE.. -* -* The first K columns of C should be the same as the first -* K columns of A*P, i.e. (A*P)(1:M,1:K) = C(1:M,1:K) -* -* JPIV(1:N) contains final desired interchanges of the colums -* in the array C. This means, the column J in C afther all column -* interchanges was the column JPIV(J) in C before the column -* interchanges. -* -* We use IWORK(1:N) to store the original column indices, -* when interchanging columns in C at each step. IWORK(1:K) should -* be the same as JPIV(1:K) after all column interchanges. +* The M-by-N matrix A was copied into the array C at the +* beginning of the routine, if RETURNC = .TRUE.. -* Initialize IWORK(1:N) to 1:N, which are the original column -* indices. +* Apply the column permutaition matrix P stored in JPIV(1:K) +* to the columns 1:K in the M-by-N array C in place. +* After column interchanges, the first K columns of C should +* be the same as the first K columns of A*P, i.e. +* (A*P)(1:M,1:K) = C(1:M,1:K). +* +* Index I is the original column index in the +* array C before interchanges. +* J is the current column index of the original column I at +* each step of interchanges. +* +* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) +* of the current column permutation matrix P(J) at each +* column interchange step J. +* C_prev = P_inv(J) * C_next. +* Each IWORK(I) contains J corresponding to I +* Initialize IWORK(1:N) as (1:N). +* + DO I = 1, N, 1 + IWORK( I ) = I + END DO +* +* Auxiliary array IWORK(N+1:2N) stores the current column +* permutation matrix P_(J) at each column interchange step J. +* P(J): C_prev * P_(J) = C_next. +* Each IWORK(N+J) contains I corresponding to J. +* Initialize IWORK(N+1:2*N) as (1:N). * DO J = 1, N, 1 - IWORK( J ) = J + IWORK( N + J ) = J END DO * -* Loop over the columns J = (1:K) in C. -* At each step, we want to swap the desired original column JPIV(J) -* into position J. +* Loop over the columns J = ( 1:min( K, N-1 ) ) in C. * - DO J = 1, K, 1 + DO J = 1, min( K, N-1 ), 1 +* +* IP is the original pivot column, i.e. is the original +* column that should be placed in the current column index +* J in the array C. * -* JPIV( J ) is the index of the original column that -* should be placed in the column index J in C + IP = JPIV( J ) +* +* I is the original column that is +* currently in the column index J in the array C after +* previous column interchanges. * -* IWORK( J )is the index of the original column that is -* currently in the column index J in C after previous column -* interchanges. + I = IWORK( N+J ) * - IF( IWORK( J ).NE.JPIV( J ) ) THEN + IF( I.NE.IP ) THEN +* +* JP is the current index of the original pivot +* column IP in the array C after previous column +* interchanges. * -* Swap the current column J with the column JP in C, and -* swap the same columns in IWORK to keep track of -* the original column indices. + JP = IWORK( IP ) + +* Swap the original pivot column IP = JPIV( J ), +* at the current pivot index JP = IWORK( IP ) into +* index J. * - JP = IWORK( JPIV( J ) ) CALL DSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) - ITEMP = IWORK( J ) - IWORK( J ) = IWORK( JP ) - IWORK( JP ) = ITEMP - END IF +* +* Update the array IWORK(1:N) for the original column +* I that was swaped with IP. +* + IWORK( I ) = IWORK( IP ) +* +* Update the array IWORK(N+1:2*N) for the current column +* index JP that was swaped with the current column +* index J. +* + IWORK( N + JP ) = IWORK( N + J ) +* + END IF +* END DO * END IF From 8db5d4774b6948a637b7037f2d20bd21c0068e3c Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Sun, 5 Apr 2026 23:01:24 -0700 Subject: [PATCH 24/63] dgecxx.f: corrected comments in the version 3 algorithm to generate the matrix C --- SRC/dgecxx.f | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index b3e1bf2e4..b4e2827b5 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -1500,7 +1500,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * The M-by-N matrix A was copied into the array C at the * beginning of the routine, if RETURNC = .TRUE.. -* Apply the column permutaition matrix P stored in JPIV(1:K) +* Apply the column permutation matrix P stored in JPIV(1:K) * to the columns 1:K in the M-by-N array C in place. * After column interchanges, the first K columns of C should * be the same as the first K columns of A*P, i.e. @@ -1513,9 +1513,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * Auxiliary array IWORK(1:N) stores the inverse P_inv(J) * of the current column permutation matrix P(J) at each -* column interchange step J. +* column interchange step J only for index JJ >= J:N. * C_prev = P_inv(J) * C_next. -* Each IWORK(I) contains J corresponding to I +* Each IWORK(I) contains JJ corresponding to I * Initialize IWORK(1:N) as (1:N). * DO I = 1, N, 1 @@ -1523,9 +1523,10 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, END DO * * Auxiliary array IWORK(N+1:2N) stores the current column -* permutation matrix P_(J) at each column interchange step J. -* P(J): C_prev * P_(J) = C_next. -* Each IWORK(N+J) contains I corresponding to J. +* permutation matrix P_(J) at each column interchange step J +* only for index JJ >= J:N +* C_prev * P_(J) = C_next. +* Each IWORK(N+JJ) contains I corresponding to JJ. * Initialize IWORK(N+1:2*N) as (1:N). * DO J = 1, N, 1 From 550681586389a6e506496a00e7962a8012ffe78e Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Sun, 5 Apr 2026 23:32:27 -0700 Subject: [PATCH 25/63] dgecxx.f: updated the workspace dimension parameter LIWORK description --- SRC/dgecxx.f | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index b4e2827b5..4ae15ddc6 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -728,7 +728,7 @@ *> LWORK is INTEGER *> The dimension of the array WORK. *> -*> Minimal LWORK workspace requirement. +*> Minimal LWORK workspace general requirement. *> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all values *> of FACT and USESD flags. *> @@ -797,7 +797,8 @@ *> The dimension of the array IWORK. *> *> Minimal LIWORK workspace general requirement. -*> For all FACT and USESD flags, LIWORK >= max( 1, 2*N ) +*> LIWORK >= max( 1, 2*N ) would be sufficient for all values +*> of FACT and USESD flags. *> *> The optimal LIWORK is the same as the minimal LIWORK. *> The user can still query the routine for the optimal LIWORK. @@ -810,15 +811,15 @@ *> *> Exact minimal workspace requirements. *> For USESD = 'N' or 'R': -*> a) If FACT = 'P': -*> LIWORK >= max( 1, N-1 ) -*> b) If FACT = 'C' or 'X': -*> LIWORK >= max( 1, 2N ) +*> a) If FACT = 'P': +*> LIWORK >= max( 1, N-1 ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2N ) *> For USESD = 'C' or 'A': -*> a) If FACT = 'P': -*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) -*> b) If FACT = 'C' or 'X': -*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free, 2*N ) +*> a) If FACT = 'P': +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free, 2*N ) *> \endverbatim *> *> \param[out] INFO From 7de15adde6a49aada25248c8ec79b03c9682d9aa Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 6 Apr 2026 13:43:56 -0700 Subject: [PATCH 26/63] dgecxx.f: corrected the description of the parameter LIWORL --- SRC/dgecxx.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 4ae15ddc6..2ca4ac96a 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -814,12 +814,12 @@ *> a) If FACT = 'P': *> LIWORK >= max( 1, N-1 ) *> b) If FACT = 'C' or 'X': -*> LIWORK >= max( 1, 2N ) +*> LIWORK >= max( 1, 2*N ) *> For USESD = 'C' or 'A': *> a) If FACT = 'P': *> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) *> b) If FACT = 'C' or 'X': -*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free, 2*N ) +*> LIWORK >= max( 1, 2*N ) *> \endverbatim *> *> \param[out] INFO From b21e888fb328e9a4b959800c897a0536474a8315 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 7 Apr 2026 20:36:58 -0700 Subject: [PATCH 27/63] dgecxx.f: upadated the description of the parameters C and QRC --- SRC/dgecxx.f | 43 +++++++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 2ca4ac96a..f8d6f8a0e 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -543,7 +543,7 @@ *> (K is the factorization rank). *> 0 <= K <= min( M_sub, N_sel+KMAXFREE, N_sub ). *> -*> If K = 0, the arrays A, TAU were not modified. +*> If K = 0, the arrays A and TAU were not modified. *> \endverbatim *> *> \param[out] MAXC2NRMK @@ -641,15 +641,22 @@ *> \param[out] C *> \verbatim *> C is DOUBLE PRECISION array. +*> *> If FACT = 'P': *> the array is not used, the array dimension >= (1,1). -*> If FACT = 'C' or 'X': -*> If USESD = 'N', the array dimension is (LDC,min(M,N)). -*> If USESD = 'C' or 'R' or 'A', -*> the array dimension is (LDC,min(M_sub,N_sub)). *> -*> If K = 0, the array is not used. -*> If K > 0, the array C stores the M-by-K factor C. +*> If FACT = 'C' or 'X': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array X contains a copy of +*> the original M-by-N matrix A. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C contain +*> the deselected columns from the original +*> matrix A. *> \endverbatim *> *> \param[in] LDC @@ -663,16 +670,14 @@ *> \param[out] QRC *> \verbatim *> QRC is DOUBLE PRECISION array. +*> *> If FACT = 'P' or 'C': The array is not used, -*> the array dimension is >= (1,1). -*> If FACT = 'X': -*> If USESD = 'N', -*> the array dimension is (LDQRC,min(M,N)). -*> If USESD = 'C' or 'R' or 'A', -*> the array dimension is (LDQRC,min(M_sub,N_sub)). +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': the array dimension is (LDQRC,min(M,N)). *> *> If K = 0, the array is not used. -*> If K > 0, QRC(1:M_sub,1:K) stores two components from +*> If K > 0, QRC(1:M,1:K) stores two components from *> the QR factorization of the factor C. The K-by-K *> factor R is stored in the upper triangle. *> The Householder vectors are stored in the lower @@ -1505,7 +1510,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * to the columns 1:K in the M-by-N array C in place. * After column interchanges, the first K columns of C should * be the same as the first K columns of A*P, i.e. -* (A*P)(1:M,1:K) = C(1:M,1:K). +* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm +* is min(K,N-1). * * Index I is the original column index in the * array C before interchanges. @@ -1514,7 +1520,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * Auxiliary array IWORK(1:N) stores the inverse P_inv(J) * of the current column permutation matrix P(J) at each -* column interchange step J only for index JJ >= J:N. +* column interchange step J only for the array +* values >= J:N. * C_prev = P_inv(J) * C_next. * Each IWORK(I) contains JJ corresponding to I * Initialize IWORK(1:N) as (1:N). @@ -1525,7 +1532,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * Auxiliary array IWORK(N+1:2N) stores the current column * permutation matrix P_(J) at each column interchange step J -* only for index JJ >= J:N +* only for the array index >= J:N. * C_prev * P_(J) = C_next. * Each IWORK(N+JJ) contains I corresponding to JJ. * Initialize IWORK(N+1:2*N) as (1:N). @@ -1536,7 +1543,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * Loop over the columns J = ( 1:min( K, N-1 ) ) in C. * - DO J = 1, min( K, N-1 ), 1 + DO J = 1, MIN( K, N-1 ), 1 * * IP is the original pivot column, i.e. is the original * column that should be placed in the current column index From 3af8533300f298dc26ed683d10206196b12a96e2 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 9 Apr 2026 10:15:35 -0700 Subject: [PATCH 28/63] dgecxx.f: added top comments --- SRC/dgecxx.f | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index f8d6f8a0e..ab5f61295 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -840,6 +840,16 @@ *> (R is stored in the array QRC.) *> \endverbatim * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2026, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> \endverbatim +* * Authors: * ======== * From f3f65e386b95f4a58b538fb64488c492e9cde73d Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 9 Apr 2026 13:16:36 -0700 Subject: [PATCH 29/63] dgecxx.f: changed 2 LQUERY and LIQEURY variables into 1 LQUERY --- SRC/dgecxx.f | 562 +++++++++++++++++++++++++-------------------------- 1 file changed, 280 insertions(+), 282 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index ab5f61295..99a476bfa 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -21,7 +21,7 @@ * SUBROUTINE DGECXX( FACT, USESD, M, N, * $ DESEL_ROWS, SEL_DESEL_COLS, * $ KMAXFREE, ABSTOL, RELTOL, A, LDA, -* $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, +* $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, * $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, * $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) * IMPLICIT NONE @@ -30,12 +30,12 @@ * CHARACTER FACT, USESD * INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, * $ LDX, LIWORK, LWORK, M, N -* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, * $ RELMAXC2NRMK, FNRMK * .. -* .. Array Arguments .. +* .. Array Arguments .. * INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), -* $ JPIV( * ), SEL_DESEL_COLS( * ) +* $ JPIV( * ), SEL_DESEL_COLS( * ) * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), * $ TAU( * ), WORK( * ), X( LDX, *) * @@ -50,7 +50,7 @@ *> pivoting algorithm, which is implemented in the DGEQP3RK routine. *> *> A * P = C*X + A_resid, where -*> +*> *> C is an M-by-K matrix consisting of K columns selected *> from the original matrix A, *> @@ -59,22 +59,22 @@ *> *> P is an N-by-N permutation matrix chosen so that the first *> K columns of A*P equal C, -*> +*> *> A_resid is an M-by-N residual matrix. *> *> The column selection for the matrix C has two stages. -*> +*> *> Column preselection stage 1 (optional). *> ======================================= -*> +*> *> The user can select N_sel columns and deselect N_desel columns *> of the matrix A that MUST be included and excluded respectively *> from the matrix C a priori, before running the column selection -*> algorithm. This is controlled by flags in the array -*> SEL_DESEL_COLS. The deselected columns are permuted to the right +*> algorithm. This is controlled by flags in the array +*> SEL_DESEL_COLS. The deselected columns are permuted to the right *> side of the matrix A and selected columns are permuted to the left -*> side of the matrix A. The details of the column permutation -*> (i.e. the column permutation matrix P) are stored in the +*> side of the matrix A. The details of the column permutation +*> (i.e. the column permutation matrix P) are stored in the *> array JPIV. This feature can be used when the goal is to approximate *> the deselected columns by linear combinations of K selected columns, *> where the K columns MUST include the N_sel preselected columns. @@ -84,29 +84,29 @@ *> *> The routine runs a column selection algorithm that can *> be controlled by three stopping criteria described below. -*> For column selection, the routine uses a truncated (rank-K) +*> For column selection, the routine uses a truncated (rank-K) *> Householder QR factorization with column pivoting algorithm using *> the routine DGEQP3RK. *> *> Optionally, before running the column selection *> algorithm, the user can deselect M_desel rows of the matrix A that *> should NOT be considered by the column selection algorithm (i.e. -*> during the factorization). This is controlled by flags in +*> during the factorization). This is controlled by flags in *> the array DESEL_ROWS. The deselected rows are permuted to the *> bottom of the matrix A. The details of the row permutation (i.e. the *> row permutation matrix) are stored in the array IPIV. This feature *> can be used when the goal is to use the deselected rows as test data, *> and the selected rows as training data. *> -*> This means that the column selection factorization algorithm is +*> This means that the column selection factorization algorithm is *> effectively running on the submatrix A_sub = A(1:M_sub,1:N_sub) of -*> the matrix A after the permutations described above. Here M_sub is -*> the number of rows of the matrix A minus the number of deselected -*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number -*> of columns of the matrix A minus the number of deselected columns +*> the matrix A after the permutations described above. Here M_sub is +*> the number of rows of the matrix A minus the number of deselected +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> of columns of the matrix A minus the number of deselected columns *> N_desel, i.e. N_sub = N - N_desel. *> -*> The reported column selection error metrics MAXC2NRMK, RELMAXC2NRMK +*> The reported column selection error metrics MAXC2NRMK, RELMAXC2NRMK *> and FNRMK described below are computed using only A_sub. *> *> Column selection criteria. @@ -118,7 +118,7 @@ *> 1) KMAXFREE: This input parameter specifies the maximum number of *> columns to factorize in addition to the N_sel preselected *> columns. The factorization rank is limited to N_sel + KMAXFREE. -*> If N_sel + KMAXFREE >= min(M_sub, N_sub), this criterion +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), this criterion *> is not used. *> *> 2) ABSTOL: This input parameter specifies the absolute tolerance @@ -131,9 +131,9 @@ *> not used. *> *> 3) RELTOL: This input parameter specifies the tolerance for -*> the maximum column 2-norm of the submatrix residual +*> the maximum column 2-norm of the submatrix residual *> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) divided -*> by the maximum column 2-norm of the submatrix +*> by the maximum column 2-norm of the submatrix *> A_sub = A(1:M_sub, 1:N_sub), where A_sub(K) denotes the contents *> of the array A_sub after K columns were factorized. *> This means that the factorization stops when the ratio of the @@ -144,31 +144,31 @@ *> The algorithm stops when any of these conditions is first *> satisfied, otherwise the entire submatrix A_sub is factorized. *> -*> To perform a full-rank factorization of the matrix A_sub, use +*> To perform a full-rank factorization of the matrix A_sub, use *> selection criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) *> and ABSTOL < 0.0 and RELTOL < 0.0. *> *> If the user wishes to verify that the columns of the matrix C are -*> sufficiently linearly independent for their intended use, the user -*> can compute the condition number of its R factor by calling DTRCON +*> sufficiently linearly independent for their intended use, the user +*> can compute the condition number of its R factor by calling DTRCON *> on the upper-triangular part of QRC(1:K,1:K) in the output *> array QRC. -*> +*> *> How N_sel affects the column selection algorithm. *> ================================================= *> -*> As mentioned above, the N_sel preselected columns are permuted to the -*> left side of the matrix A, and will be included in the column +*> As mentioned above, the N_sel preselected columns are permuted to the +*> left side of the matrix A, and will be included in the column *> selection. Then the routine factorizes that block A(1:M_sub,1:N_sel), *> and if any of the three stopping criteria is met immediately after *> factoring the first N_sel columns the routine exits *> (i.e. if the user does not want to select KMAXFREE > 0 extra columns, *> or if the absolute or relative tolerance of the maximum column 2-norm -*> of the residual is satisfied). In this case, the number +*> of the residual is satisfied). In this case, the number *> of selected columns would be K = N_sel. Otherwise, the factorization -*> routine finds a new column to select with the maximum column 2-norm +*> routine finds a new column to select with the maximum column 2-norm *> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and swaps that -*> column with the first column of A(1:M,N_sel+1:N_sub). Then the routine +*> column with the first column of A(1:M,N_sel+1:N_sub). Then the routine *> checks if the stopping criteria are met in the next residual *> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. *> @@ -176,17 +176,17 @@ *> ================================== *> *> When the columns are selected for the factor C, and: -*> (a) If the flag FACT = 'P', the routine returns only the indices of +*> (a) If the flag FACT = 'P', the routine returns only the indices of *> the selected columns from the original matrix A, which are *> stored in the first K elements of the JPIV array. *> (b) If the flag FACT = 'C', then in addition to (a), the routine *> explicitly returns the matrix C in the array C. *> (c) If the flag FACT = 'X', then in addition to (a) and (b), -*> the routine explicitly computes and returns the factor -*> X = pseudoinv(C) * A in the array X, and it also returns -*> the factor R alongside the Householder vectors +*> the routine explicitly computes and returns the factor +*> X = pseudoinv(C) * A in the array X, and it also returns +*> the factor R alongside the Householder vectors *> of the QR factorization of the matrix C in the array QRC. -*> +*> *> \endverbatim * * Arguments: @@ -198,22 +198,22 @@ *> The flag specifies how the factors of a CX factorization *> are returned. *> -*> = 'P': the routine returns: +*> = 'P': the routine returns: *> (1) only the column permutation matrix P in *> the array JPIV. *> (The first K elements of the array JPIV *> contain indices of the columns that were *> selected from the matrix A to form the *> factor C.) -*> (fastest option, smallest memory space) -*> +*> (fastest option, smallest memory space) +*> *> = 'C': the routine returns: *> (1) the column permutation matrix P *> in the array JPIV. (The first K elements are *> indices of the selected columns from *> the matrix A.) *> (2) the M-by-K factor C explicitly in the array C. -*> (slower option, more memory space) +*> (slower option, more memory space) *> *> = 'X': the routine returns: *> (1) the column permutation matrix P in @@ -225,7 +225,7 @@ *> (4) the K-by-K upper triangular factor R and *> the Householder vectors of the QR factorization *> of the factor C in the array QRC. -*> ( The factor R may be useful for checking +*> ( The factor R may be useful for checking *> the factor C for singularity, in which case *> R will have a zero on the diagonal, and *> the factor X cannot be computed. ) @@ -235,24 +235,24 @@ *> \param[in] USESD *> \verbatim *> USESD is CHARACTER*1 -*> The flag specifies whether the row deselection and column +*> The flag specifies whether the row deselection and column *> preselection-deselection functionality is turned ON or OFF. *> *> = 'N': Both row deselection and column -*> preselection-deselection are OFF. +*> preselection-deselection are OFF. *> Both arrays DESEL_ROWS and SEL_DESEL_COLS *> are not used. *> -*> = 'R': Only row deselection is ON. +*> = 'R': Only row deselection is ON. *> Column preselection-deselection is OFF. *> The array SEL_DESEL_COLS is not used. *> *> = 'C': Only column preselection-deselection is ON. -*> Row deselection is OFF. +*> Row deselection is OFF. *> The array DESEL_ROWS is not used. *> *> = 'A': Means "All". Both row deselection and column -*> preselection-deselection are ON. +*> preselection-deselection are ON. *> \endverbatim *> *> \param[in] M @@ -272,15 +272,15 @@ *> DESEL_ROWS is INTEGER array, dimension (M) *> DESEL_ROWS is only accessed if USESD = 'R' or 'A'. *> This is a row deselection mask array that separates -*> the rows of matrix A into 2 sets. +*> the rows of matrix A into 2 sets. *> *> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is -*> deselected by the user, i.e. chosen to be excluded from +*> deselected by the user, i.e. chosen to be excluded from *> the column selection algorithm (in both preselection and *> selection stages) and will be permuted to the bottom *> of the matrix A. -*> The number of deselected rows is denoted by M_desel. -*> +*> The number of deselected rows is denoted by M_desel. +*> *> b) If DESEL_ROWS(i) is not equal -1, *> the i-th row of A will be used in the column selection *> algorithm (in both preselection and selection stages). @@ -297,8 +297,8 @@ *> This is a column preselection-deselection mask array that *> separates the columns of matrix A into 3 sets. *> -*> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix -*> A is preselected by the user to be included +*> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix +*> A is preselected by the user to be included *> in the factor C and will be permuted to the left side *> of the array A. The number of selected columns is *> denoted by N_sel. @@ -307,18 +307,18 @@ *> A is deselected by the user, i.e. chosen to be excluded *> from the factor C and will be permuted to the right side *> of the array A. The number of deselected columns is -*> denoted by N_desel. -*> +*> denoted by N_desel. +*> *> c) If SEL_DESEL_COLS(j) is not equal to 1 and not equal *> to -1, the j-th column of A is a free column and will be *> used by the column selection algorithm to determine if this -*> column will be selected. This defines a set of +*> column will be selected. This defines a set of *> columns of size N_free = N - N_sel - N_desel. -*> +*> *> NOTE: An error returned as INFO = -6 means that the number -*> of preselected N_sel columns is larger than M_sub. +*> of preselected N_sel columns is larger than M_sub. *> Therefore, the QR factorization of all N_sel preselected -*> columns cannot be completed. +*> columns cannot be completed. *> \endverbatim *> *> \param[in] KMAXFREE @@ -326,24 +326,24 @@ *> KMAXFREE is INTEGER, KMAXFREE >= 0. *> *> The first column selection stopping criterion from -*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> the N_free columns (N_sel+1:N_sub) of the submatrix *> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. *> *> KMAXFREE is the maximum number of columns of the matrix *> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) to select *> during the column selection stage 2. -*> +*> *> KMAXFREE does not include the preselected N_sel columns. *> N_sel + KMAXFREE is the maximum factorization rank of *> the matrix A_sub. *> -*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this +*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this *> stopping criterion is not used, i.e. columns are -*> selected in the factorization stage 2 depending +*> selected in the factorization stage 2 depending *> on ABSTOL and RELTOL. *> *> b) If KMAXFREE = 0, then this stopping criterion is -*> satisfied on input and the routine exits without +*> satisfied on input and the routine exits without *> performing column selection stage 2 *> on the submatrix A_sub. This means that the matrix *> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified @@ -356,14 +356,14 @@ *> ABSTOL is DOUBLE PRECISION, cannot be NaN. *> *> The second column selection stopping criterion from -*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> the N_free columns (N_sel+1:N_sub) of the submatrix *> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. *> *> ABSTOL is the absolute tolerance (stopping threshold) *> for maxcol2norm(A_sub_resid(K)), where K >= N_sel. -*> +*> *> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm -*> of the residual matrix +*> of the residual matrix *> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) *> when K columns have been factorized. *> The column selection algorithm converges @@ -381,11 +381,11 @@ *> by XERBLA. *> *> b) If ABSTOL < 0.0, then this stopping criterion is not -*> used, and the column selection algorithm stops -*> the factorization of A_free depending +*> used, and the column selection algorithm stops +*> the factorization of A_free depending *> on KMAXFREE and RELTOL. *> This includes the case where ABSTOL = -Inf. -*> +*> *> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN *> is used. This includes the case where ABSTOL = -0.0. *> @@ -393,7 +393,7 @@ *> of ABSTOL is used. *> *> If ABSTOL chosen above is >= maxcol2norm(A_free), then -*> this stopping criterion is satisfied on input, and +*> this stopping criterion is satisfied on input, and *> the routine only preselects K = N_sel columns. The leftmost *> preselected N_sel columns in the submatrix *> A_sub = A(1:M_sub, 1:N_sub) are factorized. The routine @@ -401,9 +401,9 @@ *> in MAXC2NORMK, computes and returns RELMAXC2NORMK of A_free, *> and exits immediately. *> This means that the factorization residual -*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) -*> is not modified in the column selection stage 2. -*> This includes the case where ABSTOL = +Inf. +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified in the column selection stage 2. +*> This includes the case where ABSTOL = +Inf. *> \endverbatim *> *> \param[in] RELTOL @@ -411,7 +411,7 @@ *> RELTOL is DOUBLE PRECISION, cannot be NaN. *> *> The third column selection stopping criterion from -*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> the N_free columns (N_sel+1:N_sub) of the submatrix *> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. *> *> RELTOL is the tolerance (stopping threshold) for the ratio @@ -420,26 +420,26 @@ *> where K >= N_sel. *> *> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm -*> of the residual matrix +*> of the residual matrix *> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) *> when K columns have been factorized. -*> maxcol2norm(A_sub) is the maximum column 2-norm +*> maxcol2norm(A_sub) is the maximum column 2-norm *> of the original submatrix A_sub = A(1:M_sub, 1:N_sub). *> The column selection algorithm converges -*> (stops the factorization) when the ratio +*> (stops the factorization) when the ratio *> relmaxcol2norm(A_sub_resid(K)) <= RELTOL, where K >= N_sel. *> *> In the following, *> EPS = DLAMCH('E'), -*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). *> *> a) If RELTOL is NaN, then no computation is performed *> and an error message ( INFO = -9 ) is issued *> by XERBLA. *> *> b) If RELTOL < 0.0, then this stopping criterion is not -*> used and the column selection algorithm stops -*> the factorization of A_free depending +*> used and the column selection algorithm stops +*> the factorization of A_free depending *> on KMAXFREE and ABSTOL. *> This includes the case RELTOL = -Inf. *> @@ -453,7 +453,7 @@ *> criterion is satisfied on input, and the routine *> only preselects K = N_sel columns. The leftmost *> preselected N_sel columns in the submatrix -*> A_sub = A(1:M_sub, 1:N_sub) are factorized. +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. *> The routine then computes maxcol2norm(A_free) and returns *> it in MAXC2NORMK, returns RELMAXC2NORMK as 1.0, and exits *> immediately. @@ -475,19 +475,19 @@ *> *> On exit: *> -*> NOTE: +*> NOTE: *> The output parameter K, the number of selected *> columns, is described later. -*> A_sub = A(1:M_sub, 1:N_sub). +*> A_sub = A(1:M_sub, 1:N_sub). *> *> 1) If K = 0, A(1:M,1:N) contains the original matrix A. *> *> 2) If K > 0, A(1:M,1:N) contains the following parts: -*> +*> *> (a) If M_sub < M (which is the same as M_desel > 0), *> the subarray A(M_sub+1:M,1:N) contains the deselected *> rows. -*> +*> *> (b) If N_sub < N ( which is the same as N_desel > 0 ), *> the subarray A(1:M,N_sub+1:N) contains the *> deselected columns. @@ -495,16 +495,16 @@ *> (c) If N_sel > 0, *> the union of the subarray A(1:M_sub, 1:N_sel) *> and the subarray A(1:N_sel, 1:N_sub) contains parts -*> of the factors obtained by computing Householder QR +*> of the factors obtained by computing Householder QR *> factorization WITHOUT column pivoting of N_sel *> preselected columns using the routine DGEQRF. -*> +*> *> (d) The subarray A(N_sel+1:M_sub, N_sel+1:N_sub) -*> contains parts of the factors obtained by computing +*> contains parts of the factors obtained by computing *> a truncated (rank K) Householder QR factorization with *> column pivoting using the routine DGEQP3RK on *> the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), -*> which is the result of applying selection and +*> which is the result of applying selection and *> deselection of columns, applying deselection of rows *> to the original matrix A, and applying orthogonal *> transformation from the factorization of the first @@ -516,10 +516,10 @@ *> product of K Householder elementary reflectors. *> *> 2. The elements on and above the diagonal of -*> the subarray A_sub(1:K,1:N_sub) contain the +*> the subarray A_sub(1:K,1:N_sub) contain the *> K-by-N_sub upper-trapezoidal matrix *> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). -*> NOTE: If K = min(M_sub,N_sub), i.e. full rank +*> NOTE: If K = min(M_sub,N_sub), i.e. full rank *> factorization, then R_sub_approx(K) is the *> full factor R which is upper-trapezoidal. *> If, in addition, M_sub >= N_sub, then R is @@ -572,10 +572,10 @@ *> \param[out] RELMAXC2NRMK *> \verbatim *> RELMAXC2NRMK is DOUBLE PRECISION -*> The ratio MAXC2NRMK / MAXC2NRM +*> The ratio MAXC2NRMK / MAXC2NRM *> of the maximum column 2-norm MAXC2NRMK of the residual *> matrix A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when -*> factorization stopped at rank K) and maximum column 2-norm +*> factorization stopped at rank K) and maximum column 2-norm *> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). *> RELMAXC2NRMK >= 0. *> @@ -593,7 +593,7 @@ *> *> NOTE: RELMAXC2NRMK at the factorization step K would equal *> abs(R_sub(K+1,K+1))/MAXC2NRM in the next -*> factorization step K+1, where R_sub(K+1,K+1) is the +*> factorization step K+1, where R_sub(K+1,K+1) is the *> diagonal element of the factor R_sub in the next *> factorization step K+1. *> \endverbatim @@ -601,7 +601,7 @@ *> \param[out] FNRMK *> \verbatim *> FNRMK is DOUBLE PRECISION -*> Frobenius norm of the residual matrix +*> Frobenius norm of the residual matrix *> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). *> FNRMK >= 0.0 *> \endverbatim @@ -621,7 +621,7 @@ *> Column permutation indices, for 1 <= j <= N. *> If JPIV(j)= k, then the column j of A*P (and of A_sub) was *> the column k of A. -*> +*> *> The first K elements of the array JPIV contain *> indices of the columns of the factor C that were selected *> from the matrix A. @@ -645,13 +645,13 @@ *> If FACT = 'P': *> the array is not used, the array dimension >= (1,1). *> -*> If FACT = 'C' or 'X': +*> If FACT = 'C' or 'X': *> the array dimension is (LDC,N). *> If K = 0: *> the M-by-N array X contains a copy of -*> the original M-by-N matrix A. -*> If K > 0: -*> a) columns (1:K) of the array C contain +*> the original M-by-N matrix A. +*> If K > 0: +*> a) columns (1:K) of the array C contain *> the M-by-K factor C (the selected columns *> from the original matrix A). *> b) columns (K+1:N) of the array C contain @@ -671,7 +671,7 @@ *> \verbatim *> QRC is DOUBLE PRECISION array. *> -*> If FACT = 'P' or 'C': The array is not used, +*> If FACT = 'P' or 'C': The array is not used, *> the array dimension is >= (1,1). *> *> If FACT = 'X': the array dimension is (LDQRC,min(M,N)). @@ -679,7 +679,7 @@ *> If K = 0, the array is not used. *> If K > 0, QRC(1:M,1:K) stores two components from *> the QR factorization of the factor C. The K-by-K -*> factor R is stored in the upper triangle. +*> factor R is stored in the upper triangle. *> The Householder vectors are stored in the lower *> trapezoid below the diagonal. *> \endverbatim @@ -703,7 +703,7 @@ *> the M-by-N array X contains a copy of *> the original M-by-N matrix A. *> 2) If K > 0: -*> a) rows (1:K) of the M-by-N array X contain +*> a) rows (1:K) of the M-by-N array X contain *> the K-by-N factor X, where K <= N. *> b) rows (K+1:M) of the M-by-N array X. *> Each column of these rows comtains the elements @@ -740,50 +740,50 @@ *> For good performance, LWORK should generally be larger, and *> the user should query the routine for the optimal LWORK. *> -*> If LWORK = -1, then a workspace query is assumed. The routine -*> only calculates the optimal size of the WORK and IWORK arrays, -*> returns these values as the first entry of the WORK and IWORK -*> arrays respectively, and no error message related to LWORK -*> is issued by XERBLA. +*> If LWORK = -1 or LIWORK =-1 then a workspace query is assumed. +*> The routine only calculates the optimal size of the WORK and +*> IWORK arrays, returns these values as the first entry of +*> the WORK and IWORK arrays respectively, and no error message +*> related to LWORK is issued by XERBLA. *> *> Exact minimal workspace requirements. -*> For USESD = 'N' or 'R' and for all FACT: +*> For USESD = 'N' or 'R' and for all FACT: *> LWORK >= max( 1, 3*N - 1 ) *> For USESD = 'C' or 'A': -*> a) If FACT = 'P' or 'C': +*> a) If FACT = 'P' or 'C': *> LWORK >= max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) *> b) If FACT = 'X': *> LWORK >= max( 1, min(M,N)+N, *> min(1,MINMNFREE)*(3*N_free-1) ) *> where MINMNFREE = min( M_free, N_free ). -*> +*> *> NOTE: The decision, whether the routine uses unblocked *> BLAS 2 or blocked BLAS 3 code is based not only on the *> dimension LWORK of the availbale workspace WORK, but *> also on: *> 1a) colum preselection stage using DGEQRF: -*> the optimal block size NB, the crossover point NX +*> the optimal block size NB, the crossover point NX *> returned by ILAENV for the routine DGEQRF -*> in comparison to N_sel. (For N_sel <= NX +*> in comparison to N_sel. (For N_sel <= NX *> or N_sel <= NB, unblocked code is used in DGEQRF.) *> 1b) column preselection stage using DORMQR: -*> the optimal block size NB returned by ILAENV for +*> the optimal block size NB returned by ILAENV for *> the routine DORMQR in comparison to N_sel. (For *> N_sel <= NB, unblocked code is used in DORMQR.) *> 2) column selection stage via criteria using DGEQRP3RK: -*> the optimal block size NB, the crossover point NX +*> the optimal block size NB, the crossover point NX *> returned by ILAENV for the routine DGEQRP3RK *> in comparison to min(M,N_sel). (For *> min(M_sub, N_free, KMAXFREE) <= NX *> or min(M_sub, N_free, KMAXFREE) <= NB, unblocked code -*> is used in DGEQRP3RK.) +*> is used in DGEQRP3RK.) *> 3a) computation of the factor X using DGEQRF in DGELS: -*> the optimal block size NB, the crossover point NX +*> the optimal block size NB, the crossover point NX *> returned by ILAENV for the routine DGEQRF *> in comparison to K. (For K <= NX or K <= NB, *> unblocked code is used in DGEQRF inside DGELS.) *> 3b) computation of the factor X using DORMQR in DGELS: -*> the optimal block size NB returned by ILAENV for +*> the optimal block size NB returned by ILAENV for *> the routine DORMQR in comparison to N. (For *> N <= NB, unblocked code is used in DORMQR *> inside DGELS.) @@ -791,7 +791,7 @@ *> *> \param[out] IWORK *> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)). +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)). *> *> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim @@ -808,15 +808,15 @@ *> The optimal LIWORK is the same as the minimal LIWORK. *> The user can still query the routine for the optimal LIWORK. *> -*> If LIWORK = -1, then a workspace query is assumed; the routine -*> only calculates the optimal size of the WORK and IWORK arrays, -*> returns these values as the first entry of the WORK and IWORK -*> arrays respectively, and no error message related to LIWORK -*> is issued by XERBLA. +*> If LIWORK = -1 or LWORK =-1 then a workspace query is assumed. +*> The routine only calculates the optimal size of the WORK and +*> IWORK arrays, returns these values as the first entry of +*> the WORK and IWORK arrays respectively, and no error message +*> related to LIWORK is issued by XERBLA. *> *> Exact minimal workspace requirements. -*> For USESD = 'N' or 'R': -*> a) If FACT = 'P': +*> For USESD = 'N' or 'R': +*> a) If FACT = 'P': *> LIWORK >= max( 1, N-1 ) *> b) If FACT = 'C' or 'X': *> LIWORK >= max( 1, 2*N ) @@ -833,7 +833,7 @@ *> = 0: successful exit. *> < 0: if INFO = -i, the i-th argument had an illegal value. *> > 0: if INFO = i, the i-th diagonal element of the -*> triangular R factor of the QR factorization of +*> triangular R factor of the QR factorization of *> the matrix C is zero. Consequently, C does not have *> full rank, and X cannot be computed as the least *> squares solution to the overdetermined system C*X = A. @@ -860,29 +860,29 @@ * *> \ingroup gecxx * -* ===================================================================== +* ===================================================================== SUBROUTINE DGECXX( FACT, USESD, M, N, $ DESEL_ROWS, SEL_DESEL_COLS, $ KMAXFREE, ABSTOL, RELTOL, A, LDA, - $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. CHARACTER FACT, USESD INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, $ LDX, LIWORK, LWORK, M, N - DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, + DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, $ RELMAXC2NRMK, FNRMK * .. -* .. Array Arguments .. +* .. Array Arguments .. INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), - $ JPIV( * ), SEL_DESEL_COLS( * ) + $ JPIV( * ), SEL_DESEL_COLS( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), $ TAU( * ), WORK( * ), X( LDX, *) * ===================================================================== @@ -890,13 +890,13 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * .. Parameters .. DOUBLE PRECISION ZERO, TWO, MINUSONE PARAMETER ( ZERO = 0.0D+0, TWO = 2.0D+0, - $ MINUSONE = -1.0D+0 ) + $ MINUSONE = -1.0D+0 ) * .. * .. Local Scalars .. - LOGICAL LIQUERY, LQUERY, RETURNC, RETURNX, + LOGICAL LQUERY, RETURNC, RETURNX, $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL INTEGER I, IP, J, JP, NSUB, MFREE, MSUB, NSEL, JDESEL, - $ ITEMP, IINFO, KFREE, KMAXLS, KP0, + $ ITEMP, IINFO, KFREE, KMAXLS, KP0, $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, $ MRESID, NRESID, MINMN, $ MINMNFREE, MDESEL, NDESEL, NFREE @@ -912,37 +912,36 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, INTEGER IDAMAX, ILAENV DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 EXTERNAL DISNAN, DLAMCH, DLANGE, DNRM2, IDAMAX, - $ ILAENV, LSAME + $ ILAENV, LSAME * .. * .. Intrinsic Functions .. - INTRINSIC DBLE, MAX, MIN + INTRINSIC DBLE, MAX, MIN * .. -* .. Executable Statements .. +* .. Executable Statements .. * * Test the input arguments * INFO = 0 MDESEL = 0 NSEL = 0 - NDESEL = 0 - MSUB = M + NDESEL = 0 + MSUB = M NSUB = N MFREE = MSUB NFREE = NSUB MINMN = MIN( M, N ) -* - LQUERY = ( LWORK.EQ.-1 ) - LIQUERY = ( LIWORK.EQ.-1 ) -* +* + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1) +* RETURNX = LSAME( FACT, 'X' ) RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX * - USE_DESEL_ROWS = LSAME( USESD, 'R' ) .OR. LSAME( USESD, 'A' ) + USE_DESEL_ROWS = LSAME( USESD, 'R' ) .OR. LSAME( USESD, 'A' ) USE_SEL_DESEL_COLS = LSAME( USESD, 'C') .OR. LSAME( USESD, 'A' ) -* +* IF ( .NOT.(RETURNC .OR. LSAME( FACT, 'P') ) ) THEN INFO = -1 - ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS + ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS $ .OR. LSAME( USESD, 'N' ) ) ) THEN INFO = -2 ELSE IF( M.LT.0 ) THEN @@ -952,24 +951,24 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, ELSE * * This is to check that the number of preselected columns NSEL -* cannot be larger than MSUB, which is the number of rows +* cannot be larger than MSUB, which is the number of rows * without MDESEL deselected rows. When the number of * preselected columns NSEL is larger than MSUB, -* the factorization of all preselected NSEL columns cannot be +* the factorization of all preselected NSEL columns cannot be * completed. MSUB also will be used for LDX argument check * later. * IF( USE_DESEL_ROWS ) THEN * * Count the number of free rows MSUB. -* +* DO I = 1, M IF( DESEL_ROWS( I ).EQ.-1 ) MDESEL = MDESEL + 1 END DO MSUB = M - MDESEL MFREE = MSUB END IF -* +* IF( USE_SEL_DESEL_COLS ) THEN * * Count the number of preselected columns NSEL and the @@ -977,15 +976,15 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * DO J = 1, N IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 - IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 END DO NSUB = N - NDESEL - MFREE = MSUB - NSEL + MFREE = MSUB - NSEL NFREE = NSUB - NSEL -* +* END IF MINMNFREE = MIN( MFREE, NFREE ) -* +* IF( NSEL.GT.MSUB ) THEN INFO = -6 ELSE IF( KMAXFREE.LT.0 ) THEN @@ -996,32 +995,31 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, INFO = -9 ELSE IF( LDA.LT.MAX( 1, M ) ) THEN INFO = -11 -* This is a check for LDC +* This is a check for LDC ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) $ .OR. ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN INFO = -20 -* This is a check for LDQRC +* This is a check for LDQRC ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) - $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN + $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN INFO = -22 -* This is a check for LDX +* This is a check for LDX ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) - $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN + $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN INFO = -24 END IF -* +* END IF * -* ================================================================== -* +* ================================================================== +* * a) Test the input workspace size LWORK and LIWORK for the -* minimum size requirement LWKMIN and LIWKMIN respectively. +* minimum size requirement LWKMIN and LIWKMIN respectively. * b) Determine the optimal workspace sizes LWKOPT and LIWKOPT to be * returned in WORK( 1 ) and IWORK( 1 ) respectively, * if INFO >= 0 in cases: * (1) LQUERY = .TRUE., -* (2) LIQUERY = .TRUE., -* (3) when the routine exits. +* (2) when the routine exits. * Here, LWKMIN and LIWKMIN are the minimum workspaces required for * unblocked code. * @@ -1034,42 +1032,42 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, ELSE * * (Real_wk_part_a) Real minimum workspace computation. -* LWKMIN = MAX(1, NSUB) for column 2-norm computation -* +* LWKMIN = MAX(1, NSUB) for column 2-norm computation +* LWKMIN = MAX( 1, NSUB ) -* +* * (Int_wk_part_1) Integer minimum workspace computation. -* +* LIWKMIN = 1 * * Optimal workspace for column 2-norm computation. -* +* LWKOPT = LWKMIN * * Call of DGEQRF. * IF( NSEL.GT.0 ) THEN -* +* * (Real_wk_part_b) Real minimum workspace computation. * LWKMIN = MAX(1, NSEL) for the call of DGEQRF. -* We can skip counting this workspace as -* LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. +* We can skip counting this workspace as +* LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. * * Query for optimal workspace size for DGEQRF. -* +* CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, $ -1, IINFO ) LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) * * Call of DORMQR. * - IF( NFREE.GT.0 ) THEN + IF( NFREE.GT.0 ) THEN * * (Real_wk_part_c) Real minimum workspace computation. -* NOTE: minimum workspace requirement for DORMQR +* NOTE: minimum workspace requirement for DORMQR * LWKMIN = MAX(1, NFREE) is smaller than * LWKMIN = 3*NFREE-1 for DGEQP3RK and it is -* smaller than NSUB. We can skip counting this +* smaller than NSUB. We can skip counting this * workspace as LWKMIN = MAX( LWKMIN, NFREE ). * * Query for optimal workspace size for DORMQR. @@ -1077,7 +1075,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, CALL DORMQR( 'L', 'T', MSUB, NFREE, $ NSEL, A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, $ -1, IINFO ) - LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) END IF * END IF @@ -1086,31 +1084,31 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF ( MINMNFREE.NE.0 ) THEN -* +* * (Real_wk_part_d) Real minimum workspace computation. -* LWKMIN = MAX(1, 3*NFREE-1) for the call of DGEQP3RK. -* +* LWKMIN = MAX(1, 3*NFREE-1) for the call of DGEQP3RK. +* LWKMIN = MAX( LWKMIN, 3*NFREE - 1 ) * * Query for optimal workspace size for DGEQP3RK. * CALL DGEQP3RK( MFREE, NFREE, 0, NFREE, $ MINUSONE, MINUSONE, - $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), $ WORK, -1, IWORK, IINFO ) LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) * -* (Int_wk_part_2) Integer minimum workspace computation. +* (Int_wk_part_2) Integer minimum workspace computation. * LIWKMIN = NFREE-1 for the call of DGEQP3RK. * LIWKMIN = MAX( LIWKMIN, NFREE-1 ) * - IF( NSEL.NE.0 ) THEN -* + IF( NSEL.NE.0 ) THEN +* * (Int_wk_part_3) Integer minimum workspace computation. * NFREE is for DGEQP3RK and NFREE-1 for JPIV adjustment. -* +* LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) END IF * @@ -1118,41 +1116,41 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( RETURNC ) THEN * -* Integer minimum workspace computation. +* Integer minimum workspace computation. * (Int_wk_part_3) LIWKMIN = 2*N for applying the interchanges * for the columns in the matrix C. -* - LIWKMIN = MAX( LIWKMIN, 2*N ) +* + LIWKMIN = MAX( LIWKMIN, 2*N ) END IF - LIWKOPT = LIWKMIN + LIWKOPT = LIWKMIN * * Call of DGELS. -* +* IF( RETURNX ) THEN * * (Real_wk_part_d) Real minimum workspace computation. * LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = * = max( 1, MINMN + N ) for the call of DGELS. -* - LWKMIN = MAX( LWKMIN, MINMN + N ) +* + LWKMIN = MAX( LWKMIN, MINMN + N ) * * Query for optimal workspace size for DGELS. * KMAXLS = MINMN -* +* CALL DGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, $ WORK, -1, IINFO ) LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) -* - END IF +* + END IF * * End of ELSE for IF( MINMN.EQ.0 ) -* +* END IF * IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN INFO = -26 - ELSE IF( ( LIWORK.LT.LIWKMIN ) .AND. .NOT.LIQUERY ) THEN + ELSE IF( ( LIWORK.LT.LIWKMIN ) .AND. .NOT.LQUERY ) THEN INFO = -28 END IF END IF @@ -1160,17 +1158,17 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, IF( INFO.EQ.0 ) THEN WORK( 1 ) = DBLE( LWKOPT ) IWORK( 1 ) = LIWKOPT - END IF -* + END IF +* IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGECXX', -INFO ) RETURN - ELSE IF( LQUERY.OR.LIQUERY) THEN + ELSE IF( LQUERY ) THEN RETURN END IF -* +* * ================================================================== -* +* K = 0 * * If we need to return factor C, copy the original untouched matrix @@ -1186,7 +1184,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, IF( RETURNX ) THEN CALL DLACPY( 'F', M, N, A, LDA, X, LDX ) END IF -* +* * ================================================================== * Permute the deselected rows to the bottom of the matrix A. * 1) The order of free rows is preserved. @@ -1199,44 +1197,44 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * (For each position I, we check if this position is an included row. * If it is an included row, we increment MSUB, which is also a pointer * to the last included row, otherwise we do not change MSUB pointer. -* Also, if it is an included row, we move this row from the larger +* Also, if it is an included row, we move this row from the larger * (or same) I index into smaller (or same) MSUB index. This way * we move all the included rows to the larger index block preserving * included row order. The deselected rows will be at the bottom of the * matrix A.) -* +* IF( USE_DESEL_ROWS ) THEN -* - MSUB = 0 +* + MSUB = 0 DO I = 1, M, 1 * -* Initialize the row pivot array IPIV. +* Initialize the row pivot array IPIV. IPIV( I ) = I * * The row at the index I is an included row and should be -* moved to the top of the matrix A. +* moved to the top of the matrix A. * IF( DESEL_ROWS( I ).NE.-1 ) THEN MSUB = MSUB + 1 * * This is a check whether the included row is * on the included place already. -* +* IF( I.NE.MSUB ) THEN * * Here, we swap A(I,1:N) into A(MSUB,1:N) * - CALL DSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) + CALL DSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) IPIV( I ) = IPIV( MSUB ) IPIV( MSUB ) = I ITEMP = DESEL_ROWS( I ) DESEL_ROWS( I ) = DESEL_ROWS( MSUB ) DESEL_ROWS( MSUB ) = ITEMP - END IF + END IF END IF -* - END DO -* +* + END DO +* ELSE * * We do not use the row deselection DESEL_ROWS array. @@ -1248,9 +1246,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, IPIV( I ) = I END DO END IF -* +* * ================================================================== -* Permute the pseselected columns to the left and deselected +* Permute the pseselected columns to the left and deselected * columns to the right of the matrix A. * 1) The order of preselected columns is preserved. * 2) The order of free columns is not preserved. @@ -1266,23 +1264,23 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * NSEL is the number of selected columns, also the pointer to the last * selected column. * - NSEL = 0 + NSEL = 0 DO J = 1, N, 1 -* -* Initialize column pivot array JPIV. +* +* Initialize column pivot array JPIV. JPIV( J ) = J -* +* IF( SEL_DESEL_COLS(J).EQ.1 ) THEN NSEL = NSEL + 1 * * This is the check whether the selected column is * on the selected place already. -* +* IF( J.NE.NSEL ) THEN * * Here, we swap the column A(1:M,J) into A(1:M,NSEL) * - CALL DSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) + CALL DSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) JPIV( J ) = JPIV( NSEL ) JPIV( NSEL ) = J SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) @@ -1302,21 +1300,21 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * This is the check whether the deselected column is * on the deselected place already. -* +* IF( J.NE.JDESEL ) THEN * * Here, we swap the column A(1:M,J) into A(1:M,JDESEL) * CALL DSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) - ITEMP = JPIV( J ) + ITEMP = JPIV( J ) JPIV( J ) = JPIV( JDESEL ) JPIV( JDESEL ) = ITEMP SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) SEL_DESEL_COLS( JDESEL ) = -1 - END IF + END IF END IF END DO -* +* NSUB = JDESEL - 1 * ELSE @@ -1330,17 +1328,17 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, DO J = 1, N, 1 JPIV( J ) = J END DO - - END IF + + END IF * * ================================================================== -* Compute the complete column 2-norms of the submatrix +* Compute the complete column 2-norms of the submatrix * A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). * DO J = 1, NSUB WORK( J ) = DNRM2( MSUB, A( 1, J ), 1 ) END DO -* +* * Compute the column index of the maximum column 2-norm and * the maximum column 2-norm itself for the submatrix * A_sub = A(1:MSUB, 1:NSUB). @@ -1353,24 +1351,24 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * Compute the QR factorization of NSEL preselected columns (1:NSEL) * in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update * remaining NFREE free columns (NSEL+1:NSUB). -* NSUB = NSEL + NFREE +* NSUB = NSEL + NFREE * IF( NSEL.GT.0 ) THEN -* +* * Case (a): MSUB < NSEL. -* +* * This is handled at the argument check stage in the * beginning of the routine. When the number of preselected * columns is larger than MSUB, hence the factorization of -* all NSEL columns cannot be completed. Return from the +* all NSEL columns cannot be completed. Return from the * routine with the error of COL_SEL_DESEL parameter. * * Case (b): MSUB = NSEL. * Case (c-1): MSUB > NSEL and NSEL = NSUB. * * For cases (b) and (c-1), there will be no residual -* submatrix after factorization of NSEL columns -* at step K = NSEL: +* submatrix after factorization of NSEL columns +* at step K = NSEL: * A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). * * Case (c-2): MSUB > NSEL and NSEL < NSUB. @@ -1380,26 +1378,26 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) * -* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) * IF( NFREE.GT.0 ) THEN * * This is only for case (c-2) ('L' = Left, 'T' = Transpose) -* +* CALL DORMQR( 'L', 'T', MSUB, NFREE, NSEL, $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, $ LWORK, IINFO ) - END IF + END IF * K = NSEL * * End of IF(NSEL.GT.0) -* +* END IF -* +* * ================================================================== -* - KFREE = 0 +* + KFREE = 0 * IF( MINMNFREE.NE.0 ) THEN * @@ -1407,7 +1405,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), * KFREE is the number of columns that were actually factorized * among NFREE columns. -* +* * ================================================================== * EPS = DLAMCH('Epsilon') @@ -1435,7 +1433,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * ================================================================== * -* Disable RELTOLFREE when calling DGEQP3RK for free columns +* Disable RELTOLFREE when calling DGEQP3RK for free columns * factorization, since DGEQP3RK expects RELTOLFREE with respect * to the residual matrix A_sub_resid(NSEL), not the whole * original matrix A. We can use RELTOL criterion by passing it @@ -1461,9 +1459,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * CALL DGEQP3RK( MFREE, NFREE, 0, KMAXFREE, $ ABSTOLFREE, RELTOLFREE, - $ A( NSEL+1, NSEL+1 ), LDA, KFREE, MAXC2NRMKFREE, + $ A( NSEL+1, NSEL+1 ), LDA, KFREE, MAXC2NRMKFREE, $ RELMAXC2NRMKFREE, JPIV( NSEL+1 ), - $ TAU( NSEL+1 ), WORK, LWORK, IWORK, IINFO ) + $ TAU( NSEL+1 ), WORK, LWORK, IWORK, IINFO ) * * Adjust JPIV * @@ -1471,11 +1469,11 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, DO J = 1, NFREE, 1 JPIV( NSEL+J ) = IWORK( NFREE + JPIV( NSEL+J ) ) END DO - END IF + END IF * -* 1) Adjust the return value for the number of factorized +* 1) Adjust the return value for the number of factorized * columns K for the whole submatrix A_sub. -* 2) MAXC2NRMK is returned transparently without change +* 2) MAXC2NRMK is returned transparently without change * as MAXC2NRMKFREE is returned from DGEQP3RK. * 3) Adjust the return value RELMAXC2NRMK for the whole * submatrix A_sub. We do not use RELMAXC2NRMKFREE @@ -1483,34 +1481,34 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * K = NSEL + KFREE MAXC2NRMK = MAXC2NRMKFREE - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM -* + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* ELSE * * Set norms to zero * MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO -* +* END IF * * Now, MRESID and NRESID is the number of rows and columns * respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). -* +* MRESID = MFREE-KFREE NRESID = NFREE-KFREE * IF( MIN( MRESID, NRESID ).NE.0 ) THEN FNRMK = DLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), $ LDA, WORK ) - ELSE - FNRMK = ZERO + ELSE + FNRMK = ZERO END IF -* +* * ================================================================== * * Return the matrix C. -* +* IF( RETURNC .AND. K.GT.0 ) THEN * * The M-by-N matrix A was copied into the array C at the @@ -1521,7 +1519,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * After column interchanges, the first K columns of C should * be the same as the first K columns of A*P, i.e. * (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm -* is min(K,N-1). +* is min(K,N-1). * * Index I is the original column index in the * array C before interchanges. @@ -1538,21 +1536,21 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * DO I = 1, N, 1 IWORK( I ) = I - END DO + END DO * -* Auxiliary array IWORK(N+1:2N) stores the current column +* Auxiliary array IWORK(N+1:2N) stores the current column * permutation matrix P_(J) at each column interchange step J * only for the array index >= J:N. * C_prev * P_(J) = C_next. * Each IWORK(N+JJ) contains I corresponding to JJ. * Initialize IWORK(N+1:2*N) as (1:N). -* +* DO J = 1, N, 1 IWORK( N + J ) = J END DO * * Loop over the columns J = ( 1:min( K, N-1 ) ) in C. -* +* DO J = 1, MIN( K, N-1 ), 1 * * IP is the original pivot column, i.e. is the original @@ -1560,13 +1558,13 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * J in the array C. * IP = JPIV( J ) -* -* I is the original column that is +* +* I is the original column that is * currently in the column index J in the array C after * previous column interchanges. * I = IWORK( N+J ) -* +* IF( I.NE.IP ) THEN * * JP is the current index of the original pivot @@ -1576,29 +1574,29 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, JP = IWORK( IP ) * Swap the original pivot column IP = JPIV( J ), -* at the current pivot index JP = IWORK( IP ) into +* at the current pivot index JP = IWORK( IP ) into * index J. * CALL DSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) * -* Update the array IWORK(1:N) for the original column +* Update the array IWORK(1:N) for the original column * I that was swaped with IP. * IWORK( I ) = IWORK( IP ) * -* Update the array IWORK(N+1:2*N) for the current column +* Update the array IWORK(N+1:2*N) for the current column * index JP that was swaped with the current column * index J. * - IWORK( N + JP ) = IWORK( N + J ) + IWORK( N + JP ) = IWORK( N + J ) * END IF -* - END DO +* + END DO * END IF * -* ================================================================== +* ================================================================== * * Return the matrix X. * @@ -1606,10 +1604,10 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * We need to use C and A to compute X = pseudoinv(C) * A, as * the linear least squares solution to the overdetermined system -* C*X = A. We use LLS routin that uses the QR factorization. For +* C*X = A. We use LLS routin that uses the QR factorization. For * that purpose, we store the matrix C into the array QRC. * The matrix A was copied into the array X at the beginning -* of the routine. +* of the routine. * CALL DLACPY( 'F', M, K, C, LDC, QRC, LDQRC ) * @@ -1618,9 +1616,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, INFO = IINFO * END IF -* +* WORK( 1 ) = DBLE( LWKOPT ) - IWORK( 1 ) = LIWKOPT + IWORK( 1 ) = LIWKOPT * * End of DGECXX * From 059442bcf7fbb6930189a9d52922c4cddb4f1c8d Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 9 Apr 2026 13:20:03 -0700 Subject: [PATCH 30/63] added dgecxx.f to Makefile --- SRC/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/Makefile b/SRC/Makefile index 13e47020d..0de238db3 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -321,7 +321,7 @@ DLASRC = \ dgebrd.o dgecon.o dgeequ.o dgees.o dgeesx.o dgeev.o dgeevx.o \ dgehd2.o dgehrd.o dgelq2.o dgelqf.o \ dgels.o dgelst.o dgelsd.o dgelss.o dgelsy.o dgeql2.o dgeqlf.o \ - dgeqp3.o dgeqp3rk.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \ + dgeqp3.o dgeqp3rk.o dgecxx.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \ dgerq2.o dgerqf.o dgesc2.o dgesdd.o dgesv.o dgesvd.o dgesvdx.o dgesvx.o \ dgetc2.o dgetf2.o dgetrf.o dgetri.o \ dgetrs.o dggbak.o dggbal.o dgges.o dgges3.o dggesx.o \ From e73e1b071555d21f7f98a646e8250a3f19b3019b Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 9 Apr 2026 15:07:57 -0700 Subject: [PATCH 31/63] extended the expressions for USE_DESEL_ROWS and USE_SEL_DESEL_COLS to the second line --- SRC/dgecxx.f | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 99a476bfa..e85361e6f 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -931,15 +931,17 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, NFREE = NSUB MINMN = MIN( M, N ) * - LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1) + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) * RETURNX = LSAME( FACT, 'X' ) RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX * - USE_DESEL_ROWS = LSAME( USESD, 'R' ) .OR. LSAME( USESD, 'A' ) - USE_SEL_DESEL_COLS = LSAME( USESD, 'C') .OR. LSAME( USESD, 'A' ) + USE_DESEL_ROWS = LSAME( USESD, 'R' ) + $ .OR. LSAME( USESD, 'A' ) + USE_SEL_DESEL_COLS = LSAME( USESD, 'C' ) + $ .OR. LSAME( USESD, 'A' ) * - IF ( .NOT.(RETURNC .OR. LSAME( FACT, 'P') ) ) THEN + IF( .NOT.( RETURNC .OR. LSAME( FACT, 'P') ) ) THEN INFO = -1 ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS $ .OR. LSAME( USESD, 'N' ) ) ) THEN From ce5b69cbf0a7ac9bc8de281d0b3c7d9a5903fb22 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 20 Apr 2026 23:07:03 -0700 Subject: [PATCH 32/63] dgecxx.f: added to SRC/CMakeLists.txt and SRC/lapack_64.h --- SRC/CMakeLists.txt | 4 +++- SRC/lapack_64.h | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index 33f2764d4..2959b7d9f 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -291,7 +291,7 @@ set(DLASRC dgebrd.f dgecon.f dgeequ.f dgees.f dgeesx.f dgeev.f dgeevx.f dgehd2.f dgehrd.f dgelq2.f dgelqf.f dgels.f dgelst.f dgelsd.f dgelss.f dgelsy.f dgeql2.f dgeqlf.f - dgeqp3.f dgeqp3rk.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f + dgeqp3.f dgeqp3rk.f dgecxx.f dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f dgesc2.f dgesdd.f dgesv.f dgesvd.f dgesvdx.f dgesvx.f dgetc2.f dgetf2.f dgetrf.f dgetrf2.f dgetri.f dgetrs.f dggbak.f dggbal.f @@ -546,11 +546,13 @@ set_target_properties( if(BUILD_INDEX64_EXT_API) if(NOT CMAKE_Fortran_COMPILER_ID MATCHES ${INDEX64_EXT_API_COMPILERS}) message(STATUS "Build Index-64 API as extended API with _64 suffix: skipped (unsupported Fortran compiler)") + message(STATUS " (The value of INDEX64_EXT_API_COMPILERS is: ${INDEX64_EXT_API_COMPILERS})") # Disable extended API for LAPACK and LAPACKE as it depends on LAPACK build. set(BUILD_INDEX64_EXT_API OFF) set(BUILD_INDEX64_EXT_API OFF PARENT_SCOPE) else() cmake_minimum_required(VERSION 3.18) + message(STATUS "Build Index-64 API as extended API with _64 suffix.") set(SOURCES_64) file(MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/${LAPACKLIB}_64_obj) file(COPY ${SOURCES} DESTINATION ${CMAKE_CURRENT_BINARY_DIR}/${LAPACKLIB}_64_obj) diff --git a/SRC/lapack_64.h b/SRC/lapack_64.h index 3b9d4275a..9980399df 100644 --- a/SRC/lapack_64.h +++ b/SRC/lapack_64.h @@ -26,7 +26,7 @@ #define CGBCON CGBCON_64 #define CGBEQU CGBEQU_64 #define CGBEQUB CGBEQUB_64 -#define CGBMV CGBMV_64 + #define CGBRFS CGBRFS_64 #define CGBRFSX CGBRFSX_64 #define CGBSV CGBSV_64 @@ -636,6 +636,7 @@ #define DGEQLF DGEQLF_64 #define DGEQP3 DGEQP3_64 #define DGEQP3RK DGEQP3RK_64 +#define DGECXX DGECXX_64 #define DGEQPF DGEQPF_64 #define DGEQR DGEQR_64 #define DGEQR2 DGEQR2_64 From adcce9c91c16a6396c17ee9eb987144a957ad22e Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 27 Apr 2026 20:51:44 -0700 Subject: [PATCH 33/63] dgecxx.f: added quick return for (M=0 or N=0) and (M_sub=0 or N_sub=0) If (M=0 or N=0), there is no matrix A(1:M,1:N). If (M_sub=0 or N_sub=0), there is no matrix A_sub(1:M_sub,1:N_sub). modified: SRC/dgecxx.f --- SRC/dgecxx.f | 46 ++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 44 insertions(+), 2 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index e85361e6f..235b3f1f2 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -1170,6 +1170,21 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, END IF * * ================================================================== +* +* Quick return if possible for M=0 or N=0. +* There is no matrix A(1:M,1:N). +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO + WORK( 1 ) = DBLE( LWKOPT ) + IWORK( 1 ) = LIWKOPT + RETURN + END IF +* +* ================================================================== * K = 0 * @@ -1249,6 +1264,19 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, END DO END IF * +* Quick return if possible for MSUB = 0. +* There is no matrix A_sub(1:MSUB,1:NSUB). +* + IF( MSUB.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO + WORK( 1 ) = DBLE( LWKOPT ) + IWORK( 1 ) = LIWKOPT + RETURN + END IF +* * ================================================================== * Permute the pseselected columns to the left and deselected * columns to the right of the matrix A. @@ -1292,7 +1320,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, END DO * * Column deselection. -* JDEEL the pointer to the last +* JDESEL the pointer to the last * deselected column counting right-to-left. * JDESEL = N+1 @@ -1330,7 +1358,20 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, DO J = 1, N, 1 JPIV( J ) = J END DO - +* + END IF +* +* Quick return if possible for NSUB = 0. +* There is no matrix A_sub(1:MSUB,1:NSUB). +* + IF( NSUB.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO + WORK( 1 ) = DBLE( LWKOPT ) + IWORK( 1 ) = LIWKOPT + RETURN END IF * * ================================================================== @@ -1348,6 +1389,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, KP0 = IDAMAX( NSUB, WORK( 1 ), 1 ) MAXC2NRM = WORK( KP0 ) * +* ================================================================== * Process preselected columns * * Compute the QR factorization of NSEL preselected columns (1:NSEL) From 45e761e1a8a5262d53468539c53cc811ec185d40 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 27 Apr 2026 21:03:16 -0700 Subject: [PATCH 34/63] dgecxx.f: added testing code for DOUBLE PRECISION. modified: TESTING/LIN/CMakeLists.txt modified: TESTING/LIN/Makefile modified: TESTING/LIN/alaerh.f modified: TESTING/LIN/alahd.f modified: TESTING/LIN/dchkaa.F new file: TESTING/LIN/dchkcxx.f new file: TESTING/LIN/derrcxx.f modified: TESTING/LIN/dlatb4.f modified: TESTING/dtest.in --- TESTING/LIN/CMakeLists.txt | 7 +- TESTING/LIN/Makefile | 7 +- TESTING/LIN/alaerh.f | 14 +- TESTING/LIN/alahd.f | 68 +- TESTING/LIN/dchkaa.F | 33 +- TESTING/LIN/dchkcxx.f | 939 ++++++++++++++++++++ TESTING/LIN/derrcxx.f | 1691 ++++++++++++++++++++++++++++++++++++ TESTING/LIN/dlatb4.f | 108 ++- TESTING/dtest.in | 1 + 9 files changed, 2838 insertions(+), 30 deletions(-) create mode 100644 TESTING/LIN/dchkcxx.f create mode 100644 TESTING/LIN/derrcxx.f diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index e28818c76..c3d657f99 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -110,8 +110,8 @@ endif() set(DLINTST dchkaa.F dchkeq.f dchkgb.f dchkge.f dchkgt.f dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f - dchkpt.f dchkq3.f dchkqp3rk.f dchkql.f dchkqr.f dchkrq.f - dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f + dchkpt.f dchkq3.f dchkqp3rk.f dchkcxx.f dchkql.f dchkqr.f + dchkrq.f dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f dchksy_aa.f dchksy_aa_2stage.f dchktb.f dchktp.f dchktr.f dchktz.f @@ -142,7 +142,8 @@ set(DLINTST dchkaa.F dqrt04.f dqrt05.f dchkqrt.f derrqrt.f dchkqrtp.f derrqrtp.f dchklq.f dchklqt.f dchklqtp.f dchktsqr.f derrlqt.f derrlqtp.f derrtsqr.f dtsqr01.f dlqt04.f dlqt05.f - dchkorhr_col.f derrorhr_col.f dorhr_col01.f dorhr_col02.f) + dchkorhr_col.f derrorhr_col.f dorhr_col01.f dorhr_col02.f + derrcxx.f) if(USE_XBLAS) list(APPEND DLINTST ddrvgbx.f ddrvgex.f ddrvsyx.f ddrvpox.f diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 46e096c2f..6072d0d42 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -137,8 +137,8 @@ endif DLINTST = dchkaa.o \ dchkeq.o dchkgb.o dchkge.o dchkgt.o \ dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \ - dchkpt.o dchkq3.o dchkqp3rk.o dchkql.o dchkqr.o dchkrq.o \ - dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o \ + dchkpt.o dchkq3.o dchkqp3rk.o dchkcxx.o dchkql.o dchkqr.o \ + dchkrq.o dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o \ dchksy_aa.o dchksy_aa_2stage.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ ddrvgt.o ddrvls.o ddrvpb.o \ @@ -167,7 +167,8 @@ DLINTST = dchkaa.o \ dqrt04.o dqrt05.o dchkqrt.o derrqrt.o dchkqrtp.o derrqrtp.o \ dchklq.o dchklqt.o dchklqtp.o dchktsqr.o \ derrlqt.o derrlqtp.o derrtsqr.o dtsqr01.o dlqt04.o dlqt05.o \ - dchkorhr_col.o derrorhr_col.o dorhr_col01.o dorhr_col02.o + dchkorhr_col.o derrorhr_col.o dorhr_col01.o dorhr_col02.o \ + derrcxx.o ifdef USEXBLAS DLINTST += ddrvgbx.o ddrvgex.o ddrvsyx.o ddrvpox.o \ diff --git a/TESTING/LIN/alaerh.f b/TESTING/LIN/alaerh.f index 9ce2580ee..7c4f7a431 100644 --- a/TESTING/LIN/alaerh.f +++ b/TESTING/LIN/alaerh.f @@ -810,6 +810,18 @@ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, WRITE( NOUT, FMT = 9978 ) $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT END IF +* + ELSE IF( LSAMEN( 2, P2, 'CX' ) ) THEN +* +* xCX: CX decomposition +* + IF( LSAMEN( 7, SUBNAM( 2: 8 ), 'GECXX' ) ) THEN + WRITE( NOUT, FMT = 9930 ) + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT + ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN + WRITE( NOUT, FMT = 9978 ) + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT + END IF * ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN * @@ -1161,7 +1173,7 @@ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, * 9949 FORMAT( ' ==> Doing only the condition estimate for this case' ) * -* SUBNAM, INFO, M, N, NB, IMAT +* SUBNAM, INFO, M, N, NX, NB, IMAT * 9930 FORMAT( ' *** Error code from ', A, '=', I5, / ' ==> M =', I5, $ ', N =', I5, ', NX =', I5, ', NB =', I4, ', type ', I2 ) diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f index 87e84aee8..b04a3f796 100644 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -75,6 +75,8 @@ *> _TP: Triangular packed *> _TB: Triangular band *> _QR: QR (general matrices) +*> _QK: truncated QR decomposition with column pivoting +*> _CX: CX decomposition *> _LQ: LQ (general matrices) *> _QL: QL (general matrices) *> _RQ: RQ (general matrices) @@ -606,6 +608,19 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) WRITE( IOUNIT, FMT = 8063 )4 WRITE( IOUNIT, FMT = 8064 )5 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) + + ELSE IF( LSAMEN( 2, P2, 'CX' ) ) THEN +* +* CX decomposition +* + WRITE( IOUNIT, FMT = 8007 )PATH + WRITE( IOUNIT, FMT = 9871 ) + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 8060 )1 + WRITE( IOUNIT, FMT = 8061 )2 + WRITE( IOUNIT, FMT = 8062 )3 + WRITE( IOUNIT, FMT = 8063 )4 + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'TZ' ) ) THEN * @@ -796,6 +811,7 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) $ ' factorization output ', /,' for tall-skinny matrices.' ) 8006 FORMAT( / 1X, A3, ': truncated QR factorization', $ ' with column pivoting' ) + 8007 FORMAT( / 1X, A3, ': CX decomposition' ) * * GE matrix types * @@ -942,28 +958,42 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) * QK matrix types * 9871 FORMAT( 4X, ' 1. Zero matrix', / - $ 4X, ' 2. Random, Diagonal, CNDNUM = 2', / - $ 4X, ' 3. Random, Upper triangular, CNDNUM = 2', / - $ 4X, ' 4. Random, Lower triangular, CNDNUM = 2', / - $ 4X, ' 5. Random, First column is zero, CNDNUM = 2', / - $ 4X, ' 6. Random, Last MINMN column is zero, CNDNUM = 2', / - $ 4X, ' 7. Random, Last N column is zero, CNDNUM = 2', / + $ 4X, ' 2. Random, Diagonal, CNDNUM = 2, NORM = 1', / + $ 4X, ' 3. Random, Upper triangular, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, ' 4. Random, Lower triangular, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, ' 5. Random, First column is zero, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, ' 6. Random, Last MINMN column is zero, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, ' 7. Random, Last N column is zero, CNDNUM = 2,', + $ ' NORM = 1', / $ 4X, ' 8. Random, Middle column in MINMN is zero,', - $ ' CNDNUM = 2', / - $ 4X, ' 9. Random, First half of MINMN columns are zero,', - $ ' CNDNUM = 2', / + $ ' CNDNUM = 2, NORM = 1', / + $ 4X, ' 9. Random, First half of MINMN columns are zero,', / + $ 4x, ' zero block size MINMN/2, CNDNUM = 2,', + $ ' NORM = 1', / $ 4X, '10. Random, Last columns are zero starting from', - $ ' MINMN/2+1, CNDNUM = 2', / - $ 4X, '11. Random, Half MINMN columns in the middle are', - $ ' zero starting from MINMN/2-(MINMN/2)/2+1,', - $ ' CNDNUM = 2', / - $ 4X, '12. Random, Odd columns are ZERO, CNDNUM = 2', / - $ 4X, '13. Random, Even columns are ZERO, CNDNUM = 2', / - $ 4X, '14. Random, CNDNUM = 2', / - $ 4X, '15. Random, CNDNUM = sqrt(0.1/EPS)', / - $ 4X, '16. Random, CNDNUM = 0.1/EPS', / + $ ' MINMN/2+1 column,', / + $ 4x, ' zero block size N - MINMN/2', + $ ' CNDNUM = 2, NORM = 1', / + $ 4X, '11. Random, Half of MINMN columns in the middle are', + $ ' zero,', / + $ 4X, ' starting from MINMN/2-(MINMN/2)/2+1', + $ ' column,', / + $ 4x, ' zero block size', + $ ' MINMN/2, CNDNUM = 2, NORM = 1', / + $ 4X, '12. Random, Odd columns are ZERO, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, '13. Random, Even columns are ZERO, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, '14. Random, CNDNUM = 2, NORM = 1', / + $ 4X, '15. Random, CNDNUM = sqrt(0.1/EPS), NORM = 1', / + $ 4X, '16. Random, CNDNUM = 0.1/EPS, NORM = 1', / $ 4X, '17. Random, CNDNUM = 0.1/EPS,', - $ ' one small singular value S(N)=1/CNDNUM', / + $ ' one small singular value S(N)=1/CNDNUM,', + $ ' NORM = 1', / $ 4X, '18. Random, CNDNUM = 2, scaled near underflow,', $ ' NORM = SMALL = SAFMIN', / $ 4X, '19. Random, CNDNUM = 2, scaled near overflow,', diff --git a/TESTING/LIN/dchkaa.F b/TESTING/LIN/dchkaa.F index 91ed65966..27729352c 100644 --- a/TESTING/LIN/dchkaa.F +++ b/TESTING/LIN/dchkaa.F @@ -64,6 +64,7 @@ *> DQL 8 List types on next line if 0 < NTYPES < 8 *> DQP 6 List types on next line if 0 < NTYPES < 6 *> DQK 19 List types on next line if 0 < NTYPES < 19 +*> DCX 19 List types on next line if 0 < NTYPES < 19 *> DTZ 3 List types on next line if 0 < NTYPES < 3 *> DLS 6 List types on next line if 0 < NTYPES < 6 *> DEQ @@ -146,13 +147,14 @@ PROGRAM DCHKAA * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) - INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ), + INTEGER MVAL( MAXIN ), $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus + INTEGER, DIMENSION(:), ALLOCATABLE :: IWORK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RWORK, S DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: E DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK @@ -192,7 +194,9 @@ PROGRAM DCHKAA * .. * .. Allocate memory dynamically .. * - ALLOCATE ( A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus ) + ALLOCATE ( IWORK( 34*NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( A( ( KDMAX+1 )*NMAX, 8 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" @@ -441,6 +445,7 @@ PROGRAM DCHKAA * IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN WRITE( NOUT, FMT = 9990 )PATH + * ELSE IF( NMATS.LE.0 ) THEN * @@ -947,6 +952,30 @@ PROGRAM DCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* CX: CX decomposition +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), A( 1, 4 ), + $ A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), A( 1, 8 ), + $ B( 1, 1 ), B( 1, 2 ), + $ IWORK( 1 ), IWORK( 1+2*NMAX ), + $ IWORK(1+4*NMAX), IWORK(1+6*NMAX), + $ IWORK(1+8*NMAX), IWORK(1+10*NMAX), + $ IWORK(1+12*NMAX), IWORK(1+14*NMAX), + $ WORK, IWORK(1+16*NMAX), NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN * diff --git a/TESTING/LIN/dchkcxx.f b/TESTING/LIN/dchkcxx.f new file mode 100644 index 000000000..579354e7e --- /dev/null +++ b/TESTING/LIN/dchkcxx.f @@ -0,0 +1,939 @@ +*> \brief \b DCHKCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, +* $ NNB, NBVAL, NXVAL, THRESH, TSTERR, +* $ A, COPYA, +* $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, +* $ DESEL_ROWS, COPY_DESEL_ROWS, +* $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, +* $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, +* $ WORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), +* $ NXVAL( * ), +* $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), +* $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), +* $ IPIV( * ), COPY_IPIV( * ), +* $ JPIV( * ), COPY_JPIV( * ) +* DOUBLE PRECISION A( * ), COPYA( * ), C( * ), COPYC( * ), +* $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), +* $ S( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKCXX tests DGECXX. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYC +*> \verbatim +*> COPYC is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYQRC +*> \verbatim +*> COPYQRC is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYX +*> \verbatim +*> COPYX is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_DESEL_ROWS +*> \verbatim +*> COPY_DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_SEL_DESEL_COLS +*> \verbatim +*> COPY_SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_IPIV +*> \verbatim +*> COPY_IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_JPIV +*> \verbatim +*> COPY_JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, +*> dimension is maximum of the following: +*> (1) ((MMAX + 6) * max(MMAX,NMAX)) +*> for matrix generation and test routines +*> (2) max( 2*NMAX + NBMAX*( NMAX + 1 ), +*> NMAX*min(NBMAX_ORMQR,NBMAX) + (NBMAX_ORMQR+1)*NBMAX_ORMQR ) ) +*> where NBMAX_ORMQR=64 is harwiredi in DORMQR. +*> for DGECXX optimal WORK size. +*> +*> Assuming NBMAX = NMAX, the expressions become: +*> (1) 3*NMAX + NMAX*NMAX +*> (2) NMAX * min(64,NMAX) + 4160 +*> +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> for DGECXX optimal IWORK size. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A, COPYA, + $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, + $ DESEL_ROWS, COPY_DESEL_ROWS, + $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, + $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, + $ WORK, IWORK, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NXVAL( * ), + $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), + $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), + $ IPIV( * ), COPY_IPIV( * ), + $ JPIV( * ), COPY_JPIV( * ) + DOUBLE PRECISION A( * ), COPYA( * ), C( * ), COPYC( * ), + $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), + $ S( * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + DOUBLE PRECISION ONE, ZERO, BIGNUM + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, + $ BIGNUM = 1.0D+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE, FACT, USESD + CHARACTER*3 PATH + INTEGER I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO, + $ INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INS, INFO, + $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO, + $ K, KL, KMAXFREE, KU, LDA, LDC, LDQRC, LDX, + $ LIWORK,LWORK, LWKTST, + $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NBMAX_ORMQR, NB_ZERO, NERRS, NFAIL, + $ NB_GEN, NRUN, NX, T + DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK, FNRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ), RDUMMY( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE, + $ DLAPY2 + EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DAXPY, DERRCXX, + $ DGEQP3RK, DLACPY, DLAORD, DLASET, DLATB4, + $ DLATMS, DORMQR, DSWAP, ICOPY, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'CX' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = DLAMCH( 'Epsilon' ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRCXX( PATH, NOUT ) +* + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) + LDC = MAX( 1, M ) + LDQRC = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LDX = MAX( 1, N ) +* +* Set work for testing routines. +* + LWKTST = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* + DO IMAT = 1, NTYPES +* +* Do for each value of IMAT in NTYPES. +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE +* +* The type of distribution used to generate the random +* eigen-/singular values: +* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 ) +* +* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE +* 1. Zero matrix CNDNUM = Inf 0 N/A +* 2. Random, Diagonal CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1 column, +* zero block size N - MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 11. Random, Half of MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1 column, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) 1 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS 1 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, one small singular value S(N)=1/CNDNUM CNDNUM = BADC2 = 0.1/EPS 1 2 ( one small singular value, S(N)=1/CNDNUM ) +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN 3 ( geometric distribution of singular values ) +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* +* Generate matrices. +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1 (Zero matrix). +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in the test. +* We set the array S explicitly here, since we are not using +* DLATMS (which sets the array S) to generate zero matrix. +* + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( ( IMAT.EQ.2 .OR. IMAT.EQ.3 .OR. IMAT.EQ.4 ) + $ .OR. ( IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrix 2 (Diagonal), +* Matrix 3 (Upper triangular), +* Matrix 4 (Lower triangular), +* Matrices 14-19 (Various rectangular random matrices +* without zero columns). +* +* Set up parameters with DLATB4 and generate a test +* matrix with DLATMS. +* + CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' + CALL DLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in +* the test. Unordered singular values are returned by +* DLATMS in S. We need to order singular values in S. +* + CALL DLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Matrices 5-13 (Rectangular random matrices that +* contain zero columns). Only for matrices MINMN >= 2. +* +* JB_ZERO is the column index of ZERO block. +* NB_ZERO is the column block size of ZERO block. +* NB_GEN is the column blcok size of the +* generated block. +* J_INC in the non_zero column index increment +* to generate matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column to generate matrix 12 and 13. +* + IF( IMAT.EQ.5 ) THEN +* +* Matrix 5. First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Matrix 6. Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Matrix 7. Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* MAtrix 8. Middle column in MINMN is zero. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.9 ) THEN +* +* Matrix 9. First half of MINMN columns is zero, zero block size MINMN/2. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Matrix 10. Last columns are zero columns, +* starting from (MINMN / 2 + 1) column,zero block size N - MINMN/2 +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Matrix 11. Half of the columns in the middle of first MINMN +* columns is zero, starting from MINMN/2 - (MINMN/2)/2 + 1 column, +* zero block size MINMN/2. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* Matrix 12. Odd-numbered columns are zero, +* + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 +* + ELSE IF( IMAT.EQ.13 ) THEN +* +* Matrix 13. Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL DLASET( 'Full', M, NB_ZERO, ZERO, ZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL DLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL DLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL DSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL DSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN ), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing absolute value order and +* add trailing zeros that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) + CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) +* + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF( MINMN.LT.2 .AND. ( IMAT.GE.5 .AND. IMAT.LE.13 ) ) +* skip this size for this matrix type. +* + CYCLE + END IF +* +* End generate COPYA matrix. +* +* Initialize COPYC matrix with zeros. +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYC, LDC ) +* +* Initialize COPYQRC matrix with zeros. +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYQRC, LDQRC ) +* +* Initialize COPYX matrix with zeros. +* + CALL DLASET( 'Full', MINMN, N, ZERO, ZERO, COPYX, LDX ) +* +* Initialize a copy array for pivot IPIV for DGECXX. +* + DO I = 1, M + COPY_IPIV( I ) = 0 + END DO +* +* Initialize a copy array for pivot JPIV for DGECXX. +* + DO J = 1, N + COPY_JPIV( J ) = 0 + END DO +* +* Initialize a copy array COPY_DESEL_ROWS for DGECXX. +* + DO I = 1, M + COPY_DESEL_ROWS( I ) = 0 + END DO +* +* Initialize a copy array COPY_SEL_DESEL_COLS for DGECXX. +* + DO J = 1, N + COPY_SEL_DESEL_COLS( J ) = 0 + END DO +* + DO INB = 1, NNB +* +* Do for each pair of values (NB,NX) in NBVAL and NXVAL. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + NX = NXVAL( INB ) + CALL XLAENV( 3, NX ) +* +* We do MIN(M,N)+1 because we need a test for KMAX > N, +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) +* + DO KMAXFREE = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYC into C( 1:M,1:N ). +* Get a working copy of COPYQRC into QRC( 1:M,1:N ). +* Get a working copy of COPYX into X( 1:N,1:N ). +* Get a working copy of COPY_IPIV(1:M) into IPIV(1:M). +* Get a working copy of COPY_JPIV(1:N) into JPIV(1:N). +* Get a working copy of COPY_DESEL_ROWS(1:M) into DESEL_ROWS(1:M). +* Get a working copy of COPY_SEL_DESEL_COLS(1:N) into SEL_DESEL_COLS(1:N). +* + CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL DLACPY( 'All', M, N, COPYC, LDC, C, LDC ) + CALL DLACPY( 'All', M, N, COPYQRC, LDQRC, QRC, LDQRC ) + CALL DLACPY( 'All', MINMN, N, COPYX, LDX, X, LDX ) + CALL ICOPY( M, COPY_IPIV, 1, IPIV, 1 ) + CALL ICOPY( N, COPY_JPIV, 1, JPIV, 1 ) + CALL ICOPY( M, COPY_DESEL_ROWS, 1, DESEL_ROWS, 1 ) + CALL ICOPY( N, COPY_SEL_DESEL_COLS, 1, + $ SEL_DESEL_COLS, 1 ) +* +* Set test ratios for all tests to zero. +* + DO I = 1, NTESTS + RESULT( I ) = ZERO + END DO +* +* We are not testing with ABSTOL and RELTOL stopping criteria. +* Disable them. +* + FACT = 'C' + USESD = 'N' + ABSTOL = -ONE + RELTOL = -ONE +* +* Compute the QR factorization with pivoting of A +* +* NBMAX_ORMQR is hardwired in DORMQR as NBMAX = 64. +* + NBMAX_ORMQR = 64 + LWORK = MAX( 1, + $ 2*N + NB*( N + 1 ), + $ N*min(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) +* + LIWORK = MAX( 1, 2*N ) +* +* Compute DGECXX factorization of A. +* + SRNAMT = 'DGECXX' + CALL DGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, IWORK, LIWORK, + $ INFO ) +* +* Check an error code from DGECXX. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'DGECXX', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute test 1: +* +* This test in only for the full rank factorization of +* the matrix A. +* +* Array S(1:min(M,N)) contains svd(A) the sigular values +* of the original matrix A in decreasing absolute value +* order. The test computes svd(R), the vector sigular +* values of the upper trapezoid of A(1:M,1:N) that +* contains the factor R, in decreasing order. The test +* returns the ratio: +* +* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) +* + IF( K.EQ.MINMN ) THEN +* + RESULT( 1 ) = DQRT12( M, N, A, LDA, S, WORK, + $ LWKTST ) +* + NRUN = NRUN + 1 +* +* End test 1 +* + END IF +* +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = DQPT01( M, N, K, COPYA, A, LDA, TAU, + $ JPIV, WORK, LWKTST ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = DQRT11( M, K, A, LDA, TAU, WORK, + $ LWKTST ) +* + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater then 1. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+100 if abs(R(j+1,j+1)) > abs(R(j,j)), +* j=1:K-1 +* + IF( MIN(K, MINMN).GT.1 ) THEN +* + DO J = 1, K-1, 1 + + DTEMP = (( ABS( A( (J-1)*LDA+J ) ) - + $ ABS( A( (J)*LDA+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* =============== +* Compute test 5: +* =============== +* This test is only for the factorizations with the +* rank greater than 0. +* For J=1:K, the J-th column of C should be element-wize +* equal (including NaN and Inf) +* to the JPIV(J)-th column of A. +* + RESULT( 5 ) = 0.0D+0 + IF(.FALsE.) THEN + DO J = 1, K, 1 + DO I = 1, M, 1 + IF( .NOT. (C( (J-1)*LDC+I ) + $ .EQ. A( (JPIV( J )-1)*LDA+I ) ) ) THEN + RESULT( 5 ) = BIGNUM + END IF + END DO + END DO + END IF +* +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'DGECXX', M, N, + $ FACT, USESD, KMAXFREE, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO +* +* END DO KMAX = 1, MIN(M,N)+1 +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for IN = 1, NN +* + END DO +* +* END DO for IM = 1, NM +* + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, + $ ', FACT = ''', A1, ''', USESD = ''', A1, + $ ''', KMAXFREE =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of DCHKCXX +* + END diff --git a/TESTING/LIN/derrcxx.f b/TESTING/LIN/derrcxx.f new file mode 100644 index 000000000..4c4d670dd --- /dev/null +++ b/TESTING/LIN/derrcxx.f @@ -0,0 +1,1691 @@ +*> \brief \b DERRCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DERRCXX( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRCXX tests the error exits for DERRCXX that does +*> CX decomposition. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DERRCXX( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER(LEN=3) PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 5 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, K + DOUBLE PRECISION MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ NAN, ONE, ZERO +* .. +* .. Local Arrays .. + INTEGER DESEL_ROWS( NMAX ), SEL_DESEL_COLS( NMAX ), + $ IPIV( NMAX ), JPIV( NMAX ), IW( NMAX ) + DOUBLE PRECISION A( NMAX, NMAX ), C( NMAX, NMAX ), + $ QRC( NMAX, NMAX ), X( NMAX, NMAX ), + $ TAU( NMAX ), W( NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DGECXX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER(LEN=32) SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, SQRT +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DESEL_ROWS( J ) = 0 + SEL_DESEL_COLS( J ) = 0 + IPIV( J ) = 0 + JPIV( J ) = 0 + TAU( J ) = 1.D+0 / DBLE( J ) + W( J ) = 1.D+0 / DBLE( J ) + IW( J ) = -J + DO I = 1, NMAX + A( I, J ) = 1.D+0 / DBLE( I+J ) + C( I, J ) = 1.D+0 / DBLE( I+J ) + QRC( I, J ) = 1.D+0 / DBLE( I+J ) + X( I, J ) = 1.D+0 / DBLE( I+J ) + END DO + END DO +* +* Create a NaN +* + ONE = 1.0D+0 + ZERO = 0.0D+0 + NAN = SQRT( -ONE ) +* + OK = .TRUE. +* +* Error exits for CX decomposition +* +* DGECXX +* + SRNAMT = 'DGECXX' +* +* ====================== +* Test parameter FACT +* ====================== + INFOT = 1 + CALL DGECXX( '/', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter USESD +* ====================== +* + INFOT = 2 +* + CALL DGECXX( 'P', '/', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter M +* ====================== +* + INFOT = 3 +* + CALL DGECXX( 'P', 'A', -1, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter N +* ======================= +* + INFOT = 4 +* + CALL DGECXX( 'P', 'A', 0, -1, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter SEL_DESEL_COLS +* ======================= +* +* NSEL (the number of preselected columns in SEL_DESEL_COLS +* (element value = 1)) cannot be greater then MSUB. +* + INFOT = 6 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + CALL DGECXX( 'P', 'A', 1, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter KMAXFREE +* ======================= +* + INFOT = 7 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ -1, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter ABSTOL +* ======================= +* + INFOT = 8 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, NAN, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) + +* +* ======================= +* Test parameter RELTOL +* ======================= +* + INFOT = 9 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, NAN, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDA +* ======================= +* + INFOT = 11 +* +* min(M,N) = 0 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 0, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + CALL DGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDC +* ======================= +* + INFOT = 20 +* +* min(M,N) = 0 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 1, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL DGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL DGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL DGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDQRC +* ======================= +* +* QRC is used only when the matrix X is returned. +* + INFOT = 22 +* +* min(M,N) = 0 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 0, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL DGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL DGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL DGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 1, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDX +* ======================= +* + INFOT = 24 +* +* min(M,N) = 0 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL DGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL DGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL DGECXX( 'X', 'A', 4, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 3, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LWORK +* ======================= +* + INFOT = 26 +* +* Test group 1. LWORK test for MIN(M,N) = 0, then LWKMIN => 1 +* ========================================== +* + CALL DGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 0, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LWORK tests for USESD = 'N'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'C', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'X', LWKMIN = MAX(1, 3*N - 1, MINMN + N) = MAX(1, 3*N - 1) +* + CALL DGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + CALL DGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + CALL DGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) + + + +* +* Test group 3. LWORK tests for USESD = 'R'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'C', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'X', LWKMIN = MAX(1, 3*N - 1, MINMN + N) = MAX(1, 3*N - 1) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1), min(M,N)+N ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a1). Set min(1,MINMNFREE == 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'C', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b1). min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'C', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (min(M,N)+N) = 8 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 7, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 5, +* M_sub = M = 2, N_sub = N = 5, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 0, 3 ) = 0, +* (3*N_free - 1) = 8 +* (min(M,N)+N) = 2 + 5 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'C', 2, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 2, W, 6, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 3+4 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 6, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1), min(M,N)+N ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 + + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b1). min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (min(M,N)+N) = 8 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 7, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 5, +* M_sub = 2, N_sub = N = 5, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 0, 3 ) = 0, +* (3*N_free - 1) = 8 +* (min(M,N)+N) = 2 + 5 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 6, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 5, N = 4, +* M_sub = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 3+4 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 6, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LIWORK +* ======================= +* + INFOT = 28 +* +* Test group 1. LIWORK test for MIN(M,N) = 0, then LWKMIN => 1 +* ========================================== +* + CALL DGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 0, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LIWORK tests for USESD = 'N' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + CALL DGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 2, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) + CALL DGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 7, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) + CALL DGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 7, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 3. LIWORK tests for USESD = 'R' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 7, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 7, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LIWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, 2*N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, 2*N ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b1). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c2). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5` +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LIWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRCXX +* + END diff --git a/TESTING/LIN/dlatb4.f b/TESTING/LIN/dlatb4.f index 65745dc4b..da9cd0c82 100644 --- a/TESTING/LIN/dlatb4.f +++ b/TESTING/LIN/dlatb4.f @@ -237,11 +237,115 @@ SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, TYPE = 'N' * * Set DIST, the type of distribution for the random -* number generator. 'S' is +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * DIST = 'S' * -* Set the lower and upper bandwidths. +* Set the lower bandwidth KL and the upper bandwidth KU. +* + IF( IMAT.EQ.2 ) THEN +* +* 2. Random, Diagonal, CNDNUM = 2 +* + KL = 0 + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.3 ) THEN +* +* 3. Random, Upper triangular, CNDNUM = 2 +* + KL = 0 + KU = MAX( N-1, 0 ) + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.4 ) THEN +* +* 4. Random, Lower triangular, CNDNUM = 2 +* + KL = MAX( M-1, 0 ) + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE +* +* 5.-19. Rectangular matrix +* + KL = MAX( M-1, 0 ) + KU = MAX( N-1, 0 ) +* + IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN +* +* 5.-14. Random, CNDNUM = 2. +* + CNDNUM = TWO + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.15 ) THEN +* +* 15. Random, CNDNUM = sqrt(0.1/EPS) +* + CNDNUM = BADC1 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.16 ) THEN +* +* 16. Random, CNDNUM = 0.1/EPS +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.17 ) THEN +* +* 17. Random, CNDNUM = 0.1/EPS, +* one small singular value S(N)=1/CNDNUM +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 2 +* + ELSE IF( IMAT.EQ.18 ) THEN +* +* 18. Random, scaled near underflow +* + CNDNUM = TWO + ANORM = SMALL + MODE = 3 +* + ELSE IF( IMAT.EQ.19 ) THEN +* +* 19. Random, scaled near overflow +* + CNDNUM = TWO + ANORM = LARGE + MODE = 3 +* + END IF +* + END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* xCX: CX factorization +* Set parameters to generate a general +* M x N matrix. +* +* Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. +* + TYPE = 'N' +* +* Set DIST, the type of distribution for the random +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) +* + DIST = 'S' +* +* Set the lower bandwidth KL and the upper bandwidth KU. * IF( IMAT.EQ.2 ) THEN * diff --git a/TESTING/dtest.in b/TESTING/dtest.in index 1b6c7bd4a..cde62db50 100644 --- a/TESTING/dtest.in +++ b/TESTING/dtest.in @@ -37,6 +37,7 @@ DLQ 8 List types on next line if 0 < NTYPES < 8 DQL 8 List types on next line if 0 < NTYPES < 8 DQP 6 List types on next line if 0 < NTYPES < 6 DQK 19 LIst types on next line if 0 < NTYPES < 19 +DCX 19 LIst types on next line if 0 < NTYPES < 19 DTZ 3 List types on next line if 0 < NTYPES < 3 DLS 6 List types on next line if 0 < NTYPES < 6 DEQ From 1cbb16845ebd0161d3d89d4d4e9a2c956df9afc2 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 27 Apr 2026 22:45:36 -0700 Subject: [PATCH 35/63] DOCS/groups-usr.dox: added new groups for CX factorization @defgroup low_rank_top Low-rank factorizations (CX, CUR, etc.) @{ @defgroup cx_grp CX factorization @{ @defgroup gecxx gecxx: CX factorization, expert interface @} @} modified: DOCS/groups-usr.dox --- DOCS/groups-usr.dox | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/DOCS/groups-usr.dox b/DOCS/groups-usr.dox index e5270e34f..c3d78580c 100644 --- a/DOCS/groups-usr.dox +++ b/DOCS/groups-usr.dox @@ -454,6 +454,14 @@ @} @} + @defgroup low_rank_top Low-rank factorizations (CX, CUR, etc.) + @{ + @defgroup cx_grp CX factorization + @{ + @defgroup gecxx gecxx: CX factorization, expert interface + @} + @} + @defgroup geev_top Non-symmetric eigenvalues @{ @defgroup geev_driver_grp Standard eig driver, AV = VΛ @@ -938,7 +946,7 @@ https://www.netlib.org/xblas/ @defgroup hemv {he,sy}mv: Hermitian/symmetric matrix-vector multiply ([cz]symv in LAPACK) @defgroup her {he,sy}r: Hermitian/symmetric rank-1 update @defgroup her2 {he,sy}r2: Hermitian/symmetric rank-2 update - + @defgroup skewhemv skew{he,sy}mv: skew-Hermitian/symmetric matrix-vector multiply @defgroup skewher2 skew{he,sy}r2: skew-Hermitian/symmetric rank-2 update @@ -970,7 +978,7 @@ https://www.netlib.org/xblas/ @defgroup hemm {he,sy}mm: Hermitian/symmetric matrix-matrix multiply @defgroup herk {he,sy}rk: Hermitian/symmetric rank-k update @defgroup her2k {he,sy}r2k: Hermitian/symmetric rank-2k update - + @defgroup skewhemm skew{he,sy}mm: skew-Hermitian/symmetric matrix-matrix multiply @defgroup skewher2k skew{he,sy}r2k: skew-Hermitian/symmetric rank-2k update From b05e6148ad9ac840188ed7aaa2f188160f6b96b9 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 28 Apr 2026 12:45:23 -0700 Subject: [PATCH 36/63] dgecxx.f: rearranged the leading comments modified: SRC/dgecxx.f --- SRC/dgecxx.f | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 235b3f1f2..a099c726d 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -23,21 +23,22 @@ * $ KMAXFREE, ABSTOL, RELTOL, A, LDA, * $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, * $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, -* $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) +* $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) * IMPLICIT NONE * -* .. Scalar Arguments .. +* .. Scalar Arguments .. * CHARACTER FACT, USESD * INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, * $ LDX, LIWORK, LWORK, M, N * DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, * $ RELMAXC2NRMK, FNRMK -* .. -* .. Array Arguments .. +* .. +* .. Array Arguments .. * INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), * $ JPIV( * ), SEL_DESEL_COLS( * ) * DOUBLE PRECISION A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), * $ TAU( * ), WORK( * ), X( LDX, *) +* .. * * *> \par Purpose: @@ -219,7 +220,7 @@ *> (1) the column permutation matrix P in *> the array JPIV. (The first K elements are *> indices of the selected columns from -*> the matrix A.) +*> the matrix A.) *> (2) the M-by-K factor C explicitly in the array C. *> (3) the K-by-N factor X explicitly in the array X. *> (4) the K-by-K upper triangular factor R and @@ -840,6 +841,14 @@ *> (R is stored in the array QRC.) *> \endverbatim * +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* *> \par Contributors: * ================== *> @@ -850,14 +859,6 @@ *> University of California, Berkeley, USA. *> \endverbatim * -* Authors: -* ======== -* -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* *> \ingroup gecxx * * ===================================================================== @@ -877,7 +878,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, CHARACTER FACT, USESD INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, $ LDX, LIWORK, LWORK, M, N - DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, + DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, $ RELMAXC2NRMK, FNRMK * .. * .. Array Arguments .. @@ -885,6 +886,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ JPIV( * ), SEL_DESEL_COLS( * ) DOUBLE PRECISION A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* * ===================================================================== * * .. Parameters .. From 1612cd6768e5377630fad2e4bf2d936cbe3e191d Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 28 Apr 2026 14:33:49 -0700 Subject: [PATCH 37/63] Optimized quick return when (M=0 or N=0), and (MSUB=0 or NSUB=0). Quick rfturn if possible for a) M = 0 or N = 0. There is no matrix A(1:M,1:N). b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). modified: SRC/dgecxx.f --- SRC/dgecxx.f | 37 ++++++------------------------------- 1 file changed, 6 insertions(+), 31 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index a099c726d..c55112aed 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -1174,16 +1174,17 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * ================================================================== * -* Quick return if possible for M=0 or N=0. -* There is no matrix A(1:M,1:N). +* Quick return if possible for +* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). +* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). +* We need to return correct values for all scalar output parameters, +* including WORK(1) and IWORK(1), which is set above. * - IF( MINMN.EQ.0 ) THEN + IF( MIN( MINMN , MIN( MSUB, NSUB ) ).EQ.0 ) THEN K = 0 MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO FNRMK = ZERO - WORK( 1 ) = DBLE( LWKOPT ) - IWORK( 1 ) = LIWKOPT RETURN END IF * @@ -1267,19 +1268,6 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, END DO END IF * -* Quick return if possible for MSUB = 0. -* There is no matrix A_sub(1:MSUB,1:NSUB). -* - IF( MSUB.EQ.0 ) THEN - K = 0 - MAXC2NRMK = ZERO - RELMAXC2NRMK = ZERO - FNRMK = ZERO - WORK( 1 ) = DBLE( LWKOPT ) - IWORK( 1 ) = LIWKOPT - RETURN - END IF -* * ================================================================== * Permute the pseselected columns to the left and deselected * columns to the right of the matrix A. @@ -1364,19 +1352,6 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * END IF * -* Quick return if possible for NSUB = 0. -* There is no matrix A_sub(1:MSUB,1:NSUB). -* - IF( NSUB.EQ.0 ) THEN - K = 0 - MAXC2NRMK = ZERO - RELMAXC2NRMK = ZERO - FNRMK = ZERO - WORK( 1 ) = DBLE( LWKOPT ) - IWORK( 1 ) = LIWKOPT - RETURN - END IF -* * ================================================================== * Compute the complete column 2-norms of the submatrix * A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). From 7940afb9f929155097e100003a3817f020b69a22 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 28 Apr 2026 16:57:59 -0700 Subject: [PATCH 38/63] dgecxx.f: Updated comments before row deselection code. modified: SRC/dgecxx.f --- SRC/dgecxx.f | 39 +++++++++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index c55112aed..63428c6f0 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -1208,21 +1208,29 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * ================================================================== * Permute the deselected rows to the bottom of the matrix A. -* 1) The order of free rows is preserved. -* 2) The order of deselected rows is not preserved. +* 1) The initial order of included rows in their block is preserved. +* 2) The initial order of deselected rows in their block is not +* preserved. * ================================================================== * -* I is the index of DESEL_ROWS array and row I of the matrix A. -* MSUB is the number of included rows, i.e. rows of the matrix A without -* deselected rows. -* (For each position I, we check if this position is an included row. -* If it is an included row, we increment MSUB, which is also a pointer -* to the last included row, otherwise we do not change MSUB pointer. -* Also, if it is an included row, we move this row from the larger -* (or same) I index into smaller (or same) MSUB index. This way -* we move all the included rows to the larger index block preserving -* included row order. The deselected rows will be at the bottom of the -* matrix A.) +* I is an index of DESEL_ROWS array and a row index of +* the matrix A. MSUB is the number of processed included rows, which +* is also an index pointer to the last included row in the matrix A. +* We can think of I as a row source index, and MSUB as a destination +* index for moving an included row in the matrix A. +* +* ( We start with MSUB = 0. We loop over index I in (1:M), and +* for each position I in DESEL_ROWS array, we check if the row at +* the position I in the matrix A is an included row (not -1 value). +* If it is an included row, we increment MSUB pointer, otherwise +* we do not change MSUB index pointer. Then, we bring this included +* row from the index I in the matrix A into smaller (or same) +* MSUB index in the matrix A. If I = MSUB, then the included row +* is already in place. Due to row swap, the deselected row +* at MSUB index will move into I index in the matrix A. In this way, +* we move all the included rows to the top matrix block preserving +* their initial order within the included block. The initial order +* of deselected rows will not be preserved withi n their block. * IF( USE_DESEL_ROWS ) THEN * @@ -1243,9 +1251,12 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( I.NE.MSUB ) THEN * -* Here, we swap A(I,1:N) into A(MSUB,1:N) +* Here, we swap A(I,1:N) into A(MSUB,1:N). * CALL DSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) +* +* Save the nterchange. +* IPIV( I ) = IPIV( MSUB ) IPIV( MSUB ) = I ITEMP = DESEL_ROWS( I ) From ed5b8231df71793fa281fc4958c282357dd4a332 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 28 Apr 2026 19:20:54 -0700 Subject: [PATCH 39/63] dgecxx.f: added 'On exit' parameter descriptions to DESEL_ROWS and SEL_DESEL_COLS, since they are modified on output. 1) added 'On exit' parameter descriptions to DESEL_ROWS and SEL_DESEL_COLS, since they are modified on output. 2) For row deselection, changed: IPIV( I ) = IPIV( MSUB ) IPIV( MSUB ) = I ITEMP = DESEL_ROWS( I ) DESEL_ROWS( I ) = DESEL_ROWS( MSUB ) DESEL_ROWS( MSUB ) = ITEMP into: into IPIV( I ) = IPIV( MSUB ) IPIV( MSUB ) = I DESEL_ROWS( MSUB ) = DESEL_ROWS( I ) DESEL_ROWS( I ) = -1 2) cleaned up comments in the code dgecxx.f modified: SRC/dgecxx.f --- SRC/dgecxx.f | 56 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 36 insertions(+), 20 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 63428c6f0..4233e9b96 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -169,8 +169,8 @@ *> of selected columns would be K = N_sel. Otherwise, the factorization *> routine finds a new column to select with the maximum column 2-norm *> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and swaps that -*> column with the first column of A(1:M,N_sel+1:N_sub). Then the routine -*> checks if the stopping criteria are met in the next residual +*> column with the first column of A(1:M,N_sel+1:N_sub). Then the +*> routine checks if the stopping criteria are met in the next residual *> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. *> *> Computation of the matrix factors. @@ -268,13 +268,14 @@ *> The number of columns of the matrix A. N >= 0. *> \endverbatim *> -*> \param[in] DESEL_ROWS +*> \param[in,out] DESEL_ROWS *> \verbatim *> DESEL_ROWS is INTEGER array, dimension (M) *> DESEL_ROWS is only accessed if USESD = 'R' or 'A'. *> This is a row deselection mask array that separates *> the rows of matrix A into 2 sets. *> +*> On entry: *> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is *> deselected by the user, i.e. chosen to be excluded from *> the column selection algorithm (in both preselection and @@ -289,15 +290,22 @@ *> the algorithm will use to select columns. *> After the permutation, this set will be at the top *> of the matrix A. +*> +*> On exit: +*> DESEL_ROWS will be permutted according to IPIV(i), +*> so that, if IPIV(i) = k, then the entry i of DESEL_ROWS +*> on exit was the entry k of DESEL_ROWS on entry. +*> *> \endverbatim *> -*> \param[in] SEL_DESEL_COLS +*> \param[in,out] SEL_DESEL_COLS *> \verbatim *> SEL_DESEL_COLS is INTEGER array, dimension (N) *> SEL_DESEL_COLS is only accessed if USESD = 'C' or 'A'. *> This is a column preselection-deselection mask array that *> separates the columns of matrix A into 3 sets. *> +*> On entry: *> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix *> A is preselected by the user to be included *> in the factor C and will be permuted to the left side @@ -312,10 +320,16 @@ *> *> c) If SEL_DESEL_COLS(j) is not equal to 1 and not equal *> to -1, the j-th column of A is a free column and will be -*> used by the column selection algorithm to determine if this -*> column will be selected. This defines a set of +*> used by the column selection algorithm to determine if +*> this column will be selected. This defines a set of *> columns of size N_free = N - N_sel - N_desel. *> +*> On exit: +*> SEL_DESEL_COLS will be permutted according to JPIV(j), +*> so that, if JPIV(j) = k, then the entry j +*> of SEL_DESEL_COLS on exit was the entry k +*> of SEL_DESEL_COLS on entry. +*> *> NOTE: An error returned as INFO = -6 means that the number *> of preselected N_sel columns is larger than M_sub. *> Therefore, the QR factorization of all N_sel preselected @@ -612,7 +626,7 @@ *> IPIV is INTEGER array, dimension (M) *> Row permutation indices due to row deselection, *> for 1 <= i <= M. -*> If IPIV(i)= k, then the row i of A_sub was +*> If IPIV(i) = k, then the row i of A was *> the row k of A. *> \endverbatim *> @@ -620,7 +634,7 @@ *> \verbatim *> JPIV is INTEGER array, dimension (N) *> Column permutation indices, for 1 <= j <= N. -*> If JPIV(j)= k, then the column j of A*P (and of A_sub) was +*> If JPIV(j)= k, then the column j of A*P was *> the column k of A. *> *> The first K elements of the array JPIV contain @@ -1020,8 +1034,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * a) Test the input workspace size LWORK and LIWORK for the * minimum size requirement LWKMIN and LIWKMIN respectively. -* b) Determine the optimal workspace sizes LWKOPT and LIWKOPT to be -* returned in WORK( 1 ) and IWORK( 1 ) respectively, +* b) Determine the optimal workspace sizes LWKOPT and LIWKOPT to +* be returned in WORK( 1 ) and IWORK( 1 ) respectively, * if INFO >= 0 in cases: * (1) LQUERY = .TRUE., * (2) when the routine exits. @@ -1122,7 +1136,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, IF( RETURNC ) THEN * * Integer minimum workspace computation. -* (Int_wk_part_3) LIWKMIN = 2*N for applying the interchanges +* (Int_wk_part_3) LIWKMIN = 2*N for applying the +* interchanges * for the columns in the matrix C. * LIWKMIN = MAX( LIWKMIN, 2*N ) @@ -1259,9 +1274,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IPIV( I ) = IPIV( MSUB ) IPIV( MSUB ) = I - ITEMP = DESEL_ROWS( I ) - DESEL_ROWS( I ) = DESEL_ROWS( MSUB ) - DESEL_ROWS( MSUB ) = ITEMP + DESEL_ROWS( MSUB ) = DESEL_ROWS( I ) + DESEL_ROWS( I ) = -1 END IF END IF * @@ -1272,7 +1286,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * We do not use the row deselection DESEL_ROWS array. * Initialize the row pivot array IPIV. * NOTE: MSUB=M has default value, -* which is set at the beginning of the routine, before argument checks. +* which is set at the beginning of the routine, before argument +* checks. * DO I = 1, M, 1 IPIV( I ) = I @@ -1293,8 +1308,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, IF( USE_SEL_DESEL_COLS ) THEN * * Column selection. -* NSEL is the number of selected columns, also the pointer to the last -* selected column. +* NSEL is the number of selected columns, also the pointer to +* the last selected column. * NSEL = 0 DO J = 1, N, 1 @@ -1302,7 +1317,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * Initialize column pivot array JPIV. JPIV( J ) = J * - IF( SEL_DESEL_COLS(J).EQ.1 ) THEN + IF( SEL_DESEL_COLS( J ).EQ.1 ) THEN NSEL = NSEL + 1 * * This is the check whether the selected column is @@ -1355,7 +1370,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * SEL_DESEL_COLS array. * Initialize column pivot array JPIV. * NOTE: NSUB=N has default value, -* which is set at the beginning of the routine, before argument checks. +* which is set at the beginning of the routine, before argument +* checks. * DO J = 1, N, 1 JPIV( J ) = J @@ -1637,7 +1653,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * We need to use C and A to compute X = pseudoinv(C) * A, as * the linear least squares solution to the overdetermined system -* C*X = A. We use LLS routin that uses the QR factorization. For +* C*X = A. We use LLS routine that uses the QR factorization. For * that purpose, we store the matrix C into the array QRC. * The matrix A was copied into the array X at the beginning * of the routine. From f6574307edaf932ebbd7e801125f499e2e325de3 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 28 Apr 2026 20:27:58 -0700 Subject: [PATCH 40/63] dgecxx.f: improved algorithm how the matrix C is generated. In case, when we return the matrrix X as well, we use the copy of the origonal matrix A that is stored in X. So that we do not need to save the matrix A into the array C, and do not need to select the columns of A in the array C in place. Instead, we just copy the selected columns of the matrix A into the matrix C. modified: SRC/dgecxx.f --- SRC/dgecxx.f | 63 +++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 50 insertions(+), 13 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 4233e9b96..ee68ed75d 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -660,10 +660,10 @@ *> If FACT = 'P': *> the array is not used, the array dimension >= (1,1). *> -*> If FACT = 'C' or 'X': +*> If FACT = 'C': *> the array dimension is (LDC,N). *> If K = 0: -*> the M-by-N array X contains a copy of +*> the M-by-N array C contains a copy of *> the original M-by-N matrix A. *> If K > 0: *> a) columns (1:K) of the array C contain @@ -672,6 +672,17 @@ *> b) columns (K+1:N) of the array C contain *> the deselected columns from the original *> matrix A. +*> +*> If FACT = 'X': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C is not used. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C are +*> not used. *> \endverbatim *> *> \param[in] LDC @@ -921,8 +932,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN * .. External Subroutines .. - EXTERNAL DLACPY, DGELS, DGEQP3RK, DGEQRF, DORMQR, - $ DSWAP, XERBLA + EXTERNAL DCOPY, DGELS, DGEQP3RK, DGEQRF, DORMQR, + $ DSWAP, DLACPY, XERBLA * .. * .. External Functions .. LOGICAL DISNAN, LSAME @@ -1207,13 +1218,6 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * K = 0 * -* If we need to return factor C, copy the original untouched matrix -* A into the array C. -* - IF( RETURNC ) THEN - CALL DLACPY( 'F', M, N, A, LDA, C, LDC ) - END IF -* * If we need to return factor X, copy the original untouched matrix * A into the array X. * @@ -1221,6 +1225,16 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, CALL DLACPY( 'F', M, N, A, LDA, X, LDX ) END IF * +* If we need to return the factor C, copy the original matrix A +* into the array C, only if do not return the factor X. In this +* case, we need to choose the columns of the matrix A in the array C +* in place, otherwise we can copy the columns of the matrix A from +* the array X. +* + IF( RETURNC .AND. .NOT. RETURNX ) THEN + CALL DLACPY( 'F', M, N, A, LDA, C, LDC ) + END IF +* * ================================================================== * Permute the deselected rows to the bottom of the matrix A. * 1) The initial order of included rows in their block is preserved. @@ -1560,8 +1574,25 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( RETURNC .AND. K.GT.0 ) THEN * -* The M-by-N matrix A was copied into the array C at the -* beginning of the routine, if RETURNC = .TRUE.. + IF( RETURNX ) THEN +* +* Copy the selected K columns of the original matrix A (that was +* saved into the array X) into the array C according to +* the pivot array JPIV. If we return X, then the matrix A is +* saved in the array X, and it is faster to copy into C than +* doing column permutation in place, as it is the ELSE case. +* + DO J = 1, K, 1 + CALL DCOPY( M, X( 1, JPIV( J ) ), 1, C( 1, J ), 1 ) + END DO +* + ELSE +* +* Swap the columns of the original matrix A copied into +* the array C in place. +* +* The original M-by-N matrix A was copied into the array C at +* the beginning of the routine, if RETURNC = .TRUE.. * Apply the column permutation matrix P stored in JPIV(1:K) * to the columns 1:K in the M-by-N array C in place. @@ -1642,6 +1673,12 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, END IF * END DO +* +* End of ELSE( RETURNX ) +* + END IF +* +* End of IF( RETURNC .AND. K.GT.0 ) * END IF * From 83a7af2acd45edb8bcdcdfb62de33932f7acb694 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 30 Apr 2026 13:56:07 -0700 Subject: [PATCH 41/63] SRC/lapack_64.h: restored blank line 29 to `#define CGBMV CGBMV_64` Line 29 was emtied in error while adding at commit ce5b69cbf0a7ac9bc8de281d0b3c7d9a5903fb22 index 9980399df..7a7c50f83 100644 --- a/SRC/lapack_64.h +++ b/SRC/lapack_64.h @@ -26,7 +26,7 @@ #define CGBCON CGBCON_64 #define CGBEQU CGBEQU_64 #define CGBEQUB CGBEQUB_64 - +#define CGBMV CGBMV_64 #define CGBRFS CGBRFS_64 #define CGBRFSX CGBRFSX_64 modified: SRC/lapack_64.h --- SRC/lapack_64.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/lapack_64.h b/SRC/lapack_64.h index 9980399df..7a7c50f83 100644 --- a/SRC/lapack_64.h +++ b/SRC/lapack_64.h @@ -26,7 +26,7 @@ #define CGBCON CGBCON_64 #define CGBEQU CGBEQU_64 #define CGBEQUB CGBEQUB_64 - +#define CGBMV CGBMV_64 #define CGBRFS CGBRFS_64 #define CGBRFSX CGBRFSX_64 #define CGBSV CGBSV_64 From 9c27a2452461b1f0ef538b555b75fb70fd50cb02 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 30 Apr 2026 14:50:30 -0700 Subject: [PATCH 42/63] SRC/dgecxx.f: Coorrrected spelling mistakes comments. modified: SRC/dgecxx.f --- SRC/dgecxx.f | 31 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index ee68ed75d..fa1ff810f 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -103,7 +103,7 @@ *> effectively running on the submatrix A_sub = A(1:M_sub,1:N_sub) of *> the matrix A after the permutations described above. Here M_sub is *> the number of rows of the matrix A minus the number of deselected -*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number *> of columns of the matrix A minus the number of deselected columns *> N_desel, i.e. N_sub = N - N_desel. *> @@ -147,7 +147,7 @@ *> *> To perform a full-rank factorization of the matrix A_sub, use *> selection criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) -*> and ABSTOL < 0.0 and RELTOL < 0.0. +*> and ABSTOL < 0.0 and RELTOL < 0.0. *> *> If the user wishes to verify that the columns of the matrix C are *> sufficiently linearly independent for their intended use, the user @@ -292,7 +292,7 @@ *> of the matrix A. *> *> On exit: -*> DESEL_ROWS will be permutted according to IPIV(i), +*> DESEL_ROWS will be permuted according to IPIV(i), *> so that, if IPIV(i) = k, then the entry i of DESEL_ROWS *> on exit was the entry k of DESEL_ROWS on entry. *> @@ -325,7 +325,7 @@ *> columns of size N_free = N - N_sel - N_desel. *> *> On exit: -*> SEL_DESEL_COLS will be permutted according to JPIV(j), +*> SEL_DESEL_COLS will be permuted according to JPIV(j), *> so that, if JPIV(j) = k, then the entry j *> of SEL_DESEL_COLS on exit was the entry k *> of SEL_DESEL_COLS on entry. @@ -732,7 +732,7 @@ *> a) rows (1:K) of the M-by-N array X contain *> the K-by-N factor X, where K <= N. *> b) rows (K+1:M) of the M-by-N array X. -*> Each column of these rows comtains the elements +*> Each column of these rows contains the elements *> whose sum of squares is the residual sum of *> squares for the solution in each column of *> the least squares problem. @@ -785,9 +785,9 @@ *> *> NOTE: The decision, whether the routine uses unblocked *> BLAS 2 or blocked BLAS 3 code is based not only on the -*> dimension LWORK of the availbale workspace WORK, but +*> dimension LWORK of the available workspace WORK, but *> also on: -*> 1a) colum preselection stage using DGEQRF: +*> 1a) column preselection stage using DGEQRF: *> the optimal block size NB, the crossover point NX *> returned by ILAENV for the routine DGEQRF *> in comparison to N_sel. (For N_sel <= NX @@ -837,7 +837,7 @@ *> If LIWORK = -1 or LWORK =-1 then a workspace query is assumed. *> The routine only calculates the optimal size of the WORK and *> IWORK arrays, returns these values as the first entry of -*> the WORK and IWORK arrays respectively, and no error message +*> the WORK and IWORK arrays respectively, and no error message *> related to LIWORK is issued by XERBLA. *> *> Exact minimal workspace requirements. @@ -1148,8 +1148,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * Integer minimum workspace computation. * (Int_wk_part_3) LIWKMIN = 2*N for applying the -* interchanges -* for the columns in the matrix C. +* interchanges for the columns in the matrix C. * LIWKMIN = MAX( LIWKMIN, 2*N ) END IF @@ -1200,7 +1199,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * ================================================================== * -* Quick return if possible for +* Quick return if possible for: * a) M = 0 or N = 0. There is no matrix A(1:M,1:N). * b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). * We need to return correct values for all scalar output parameters, @@ -1259,7 +1258,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * at MSUB index will move into I index in the matrix A. In this way, * we move all the included rows to the top matrix block preserving * their initial order within the included block. The initial order -* of deselected rows will not be preserved withi n their block. +* of deselected rows will not be preserved within their block. * IF( USE_DESEL_ROWS ) THEN * @@ -1284,7 +1283,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * CALL DSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) * -* Save the nterchange. +* Save the interchange. * IPIV( I ) = IPIV( MSUB ) IPIV( MSUB ) = I @@ -1309,7 +1308,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, END IF * * ================================================================== -* Permute the pseselected columns to the left and deselected +* Permute the preselected columns to the left and deselected * columns to the right of the matrix A. * 1) The order of preselected columns is preserved. * 2) The order of free columns is not preserved. @@ -1660,12 +1659,12 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, CALL DSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) * * Update the array IWORK(1:N) for the original column -* I that was swaped with IP. +* I that was swapped with IP. * IWORK( I ) = IWORK( IP ) * * Update the array IWORK(N+1:2*N) for the current column -* index JP that was swaped with the current column +* index JP that was swapped with the current column * index J. * IWORK( N + JP ) = IWORK( N + J ) From b26a74e4968df1cc78d0bd105c47bfc59b2cdf66 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 30 Apr 2026 16:26:12 -0700 Subject: [PATCH 43/63] SRC/dgecxx.f: Changed how the number of selected columns K is updated after NSEL columns and NFREE columns factorization: from update style K = NSEL, and K = NSEL + KFREE to increment style K = K + NSEL, K = K + KFEE modified: SRC/dgecxx.f --- SRC/dgecxx.f | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index fa1ff810f..eb43360d5 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -1212,6 +1212,10 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, FNRMK = ZERO RETURN END IF +* +* Quick return if possible for; +* + * * ================================================================== * @@ -1451,7 +1455,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, $ LWORK, IINFO ) END IF * - K = NSEL + K = K + NSEL * * End of IF(NSEL.GT.0) * @@ -1541,7 +1545,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * submatrix A_sub. We do not use RELMAXC2NRMKFREE * returned from DGEQP3RK. * - K = NSEL + KFREE + K = K + KFREE MAXC2NRMK = MAXC2NRMKFREE RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM * From c90d404e5fe222396334192f1404f68152ac056c Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 30 Apr 2026 16:40:33 -0700 Subject: [PATCH 44/63] SRC/dgecxx.f: Simplified quick return condition. since min( M, N) = 0 implies min( MSUB, NSUB) = 0, changed From: IF( MIN( MINMN, MIN( MSUB, NSUB )).EQ.0 ) THEN K = 0 MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO FNRMK = ZERO RETURN END IF To: IF( MIN( MSUB, NSUB ).EQ.0 ) THEN K = 0 MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO FNRMK = ZERO RETURN END IF modified: SRC/dgecxx.f --- SRC/dgecxx.f | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index eb43360d5..ad3c911e1 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -1202,20 +1202,17 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * Quick return if possible for: * a) M = 0 or N = 0. There is no matrix A(1:M,1:N). * b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). +* NOTE: min( M, N) = 0 implies min( MSUB, NSUB) = 0. * We need to return correct values for all scalar output parameters, * including WORK(1) and IWORK(1), which is set above. * - IF( MIN( MINMN , MIN( MSUB, NSUB ) ).EQ.0 ) THEN + IF( MIN( MSUB, NSUB ).EQ.0 ) THEN K = 0 MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO FNRMK = ZERO RETURN END IF -* -* Quick return if possible for; -* - * * ================================================================== * From 2dc6a549301003509d15ad74cd746ae901825eac Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 30 Apr 2026 17:17:19 -0700 Subject: [PATCH 45/63] SRC/dgecxx.f: Corrected the descriptions of K and TAU parameters. modified: SRC/dgecxx.f --- SRC/dgecxx.f | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index ad3c911e1..cef423629 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -558,7 +558,9 @@ *> (K is the factorization rank). *> 0 <= K <= min( M_sub, N_sel+KMAXFREE, N_sub ). *> -*> If K = 0, the arrays A and TAU were not modified. +*> NOTE: If K = 0, a) the arrays A is not, modified. +*> b) the array TAU(1,min(M_sub,N_sub)) +*> is set to ZERO. *> \endverbatim *> *> \param[out] MAXC2NRMK @@ -647,10 +649,11 @@ *> TAU is DOUBLE PRECISION array, dimension (min(M_sub,N_sub)) *> The scalar factors of the elementary reflectors. *> -*> If 0 < K <= min(M_sub,N_sub), only elements TAU(1:K) of -*> the array TAU may be modified. The elements -*> TAU(K+1:min(M_sub,N_sub)) are set to zero. -*> If K = 0, all elements of TAU are set to zero. +*> If 0 < K <= min(M_sub,N_sub): +*> only the elements TAU(1:K) may be modified, +*> the elements TAU(K+1:min(M_sub,N_sub)) are set to zero. +*> If K = 0, all elements TAU(1:min(M_sub,N_sub)) are set +*> to zero. *> \endverbatim *> *> \param[out] C From 40f50c003e40f4f3c5b4294e994762387ee32397 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 30 Apr 2026 17:47:46 -0700 Subject: [PATCH 46/63] SRC/dgecxx.f: changed TAU parameter description modified: SRC/dgecxx.f --- SRC/dgecxx.f | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index cef423629..3ed710c7f 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -649,11 +649,11 @@ *> TAU is DOUBLE PRECISION array, dimension (min(M_sub,N_sub)) *> The scalar factors of the elementary reflectors. *> +*> If K = 0, all elements TAU(1:min(M_sub,N_sub)) are set +*> to zero. *> If 0 < K <= min(M_sub,N_sub): *> only the elements TAU(1:K) may be modified, *> the elements TAU(K+1:min(M_sub,N_sub)) are set to zero. -*> If K = 0, all elements TAU(1:min(M_sub,N_sub)) are set -*> to zero. *> \endverbatim *> *> \param[out] C @@ -1207,7 +1207,7 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). * NOTE: min( M, N) = 0 implies min( MSUB, NSUB) = 0. * We need to return correct values for all scalar output parameters, -* including WORK(1) and IWORK(1), which is set above. +* (including WORK(1) and IWORK(1), which are set above). * IF( MIN( MSUB, NSUB ).EQ.0 ) THEN K = 0 From 26a38b10fbf8ae90548508ed2841d3929922d021 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 4 May 2026 19:44:49 -0700 Subject: [PATCH 47/63] SRC/dgecxx.f: reordered the variables in variable declarations cosmetic change modified: SRC/dgecxx.f --- SRC/dgecxx.f | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 3ed710c7f..e5ab5f4b5 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -30,8 +30,8 @@ * CHARACTER FACT, USESD * INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, * $ LDX, LIWORK, LWORK, M, N -* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, -* $ RELMAXC2NRMK, FNRMK +* DOUBLE PRECISION ABSTOL, FNRMK, MAXC2NRMK, +* $ RELMAXC2NRMK, RELTOL * .. * .. Array Arguments .. * INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), @@ -906,8 +906,8 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, CHARACTER FACT, USESD INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, $ LDX, LIWORK, LWORK, M, N - DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELTOL, - $ RELMAXC2NRMK, FNRMK + DOUBLE PRECISION ABSTOL, FNRMK, MAXC2NRMK, + $ RELMAXC2NRMK, RELTOL * .. * .. Array Arguments .. INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), @@ -926,17 +926,17 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * .. Local Scalars .. LOGICAL LQUERY, RETURNC, RETURNX, $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL - INTEGER I, IP, J, JP, NSUB, MFREE, MSUB, NSEL, JDESEL, - $ ITEMP, IINFO, KFREE, KMAXLS, KP0, - $ LIWKMIN, LWKMIN, LIWKOPT, LWKOPT, - $ MRESID, NRESID, MINMN, - $ MINMNFREE, MDESEL, NDESEL, NFREE + INTEGER I, IP, IINFO, ITEMP, J, JDESEL, JP, KFREE, + $ KMAXLS, KP0, LIWKMIN, LIWKOPT, LWKMIN, + $ LWKOPT, MFREE, MDESEL, MINMN, MINMNFREE, + $ MRESID, MSUB, NFREE, NDESEL, NRESID, NSEL, + $ NSUB DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN * .. External Subroutines .. - EXTERNAL DCOPY, DGELS, DGEQP3RK, DGEQRF, DORMQR, - $ DSWAP, DLACPY, XERBLA + EXTERNAL DCOPY, DGELS, DGEQP3RK, DGEQRF, DLACPY, + $ DORMQR, DSWAP, XERBLA * .. * .. External Functions .. LOGICAL DISNAN, LSAME From b6c54a758f5a0dbe0143f3e00cf164c6b623ec13 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 4 May 2026 20:49:19 -0700 Subject: [PATCH 48/63] added single precision file SRC/sgecxx.f Also included sgecxx.f in to SRC/CMakeLists.txt SRC/Makefile and modified SRC/lapack_64.h to reflect the addition SRC/sgecxx.f modified: SRC/CMakeLists.txt modified: SRC/Makefile modified: SRC/lapack_64.h new file: SRC/sgecxx.f --- SRC/CMakeLists.txt | 2 +- SRC/Makefile | 2 +- SRC/lapack_64.h | 1 + SRC/sgecxx.f | 1714 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 1717 insertions(+), 2 deletions(-) create mode 100644 SRC/sgecxx.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index 2959b7d9f..61931b3a4 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -90,7 +90,7 @@ set(SLASRC sgebrd.f sgecon.f sgeequ.f sgees.f sgeesx.f sgeev.f sgeevx.f sgehd2.f sgehrd.f sgelq2.f sgelqf.f sgels.f sgelst.f sgelsd.f sgelss.f sgelsy.f sgeql2.f sgeqlf.f - sgeqp3.f sgeqp3rk.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f + sgeqp3.f sgeqp3rk.f sgecxx.f sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f sgesc2.f sgesdd.f sgesv.f sgesvd.f sgesvdx.f sgesvx.f sgetc2.f sgetf2.f sgetri.f sggbak.f sggbal.f diff --git a/SRC/Makefile b/SRC/Makefile index 0de238db3..d698a03f8 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -119,7 +119,7 @@ SLASRC = \ sgebrd.o sgecon.o sgeequ.o sgees.o sgeesx.o sgeev.o sgeevx.o \ sgehd2.o sgehrd.o sgelq2.o sgelqf.o \ sgels.o sgelst.o sgelsd.o sgelss.o sgelsy.o sgeql2.o sgeqlf.o \ - sgeqp3.o sgeqp3rk.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \ + sgeqp3.o sgeqp3rk.o sgecxx.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \ sgerq2.o sgerqf.o sgesc2.o sgesdd.o sgesv.o sgesvd.o sgesvdx.o sgesvx.o \ sgetc2.o sgetf2.o sgetri.o \ sggbak.o sggbal.o sgges.o sgges3.o sggesx.o \ diff --git a/SRC/lapack_64.h b/SRC/lapack_64.h index 7a7c50f83..dc7cb701a 100644 --- a/SRC/lapack_64.h +++ b/SRC/lapack_64.h @@ -1233,6 +1233,7 @@ #define SGEQLF SGEQLF_64 #define SGEQP3 SGEQP3_64 #define SGEQP3RK SGEQP3RK_64 +#define SGECXX SGECXX_64 #define SGEQPF SGEQPF_64 #define SGEQR SGEQR_64 #define SGEQR2 SGEQR2_64 diff --git a/SRC/sgecxx.f b/SRC/sgecxx.f new file mode 100644 index 000000000..e95e451e4 --- /dev/null +++ b/SRC/sgecxx.f @@ -0,0 +1,1714 @@ +*> \brief \b SGECXX computes a CX factorization of a real M-by-N matrix A using a truncated (rank k) Householder QR factorization with column pivoting. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SGECXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SGECXX( FACT, USESD, M, N, +* $ DESEL_ROWS, SEL_DESEL_COLS, +* $ KMAXFREE, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, +* $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, +* $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER FACT, USESD +* INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, +* $ LDX, LIWORK, LWORK, M, N +* REAL ABSTOL, FNRMK, MAXC2NRMK, +* $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), +* $ JPIV( * ), SEL_DESEL_COLS( * ) +* REAL A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), +* $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGECXX computes a CX factorization of a real M-by-N matrix A using +*> a truncated rank-K Householder QR factorization with a column +*> pivoting algorithm, which is implemented in the SGEQP3RK routine. +*> +*> A * P = C*X + A_resid, where +*> +*> C is an M-by-K matrix consisting of K columns selected +*> from the original matrix A, +*> +*> X is a K-by-N matrix that minimizes the Frobenius norm of the +*> residual matrix A_resid, X = pseudoinv(C) * A, +*> +*> P is an N-by-N permutation matrix chosen so that the first +*> K columns of A*P equal C, +*> +*> A_resid is an M-by-N residual matrix. +*> +*> The column selection for the matrix C has two stages. +*> +*> Column preselection stage 1 (optional). +*> ======================================= +*> +*> The user can select N_sel columns and deselect N_desel columns +*> of the matrix A that MUST be included and excluded respectively +*> from the matrix C a priori, before running the column selection +*> algorithm. This is controlled by flags in the array +*> SEL_DESEL_COLS. The deselected columns are permuted to the right +*> side of the matrix A and selected columns are permuted to the left +*> side of the matrix A. The details of the column permutation +*> (i.e. the column permutation matrix P) are stored in the +*> array JPIV. This feature can be used when the goal is to approximate +*> the deselected columns by linear combinations of K selected columns, +*> where the K columns MUST include the N_sel preselected columns. +*> +*> Column selection stage 2. +*> ========================= +*> +*> The routine runs a column selection algorithm that can +*> be controlled by three stopping criteria described below. +*> For column selection, the routine uses a truncated (rank-K) +*> Householder QR factorization with column pivoting algorithm using +*> the routine SGEQP3RK. +*> +*> Optionally, before running the column selection +*> algorithm, the user can deselect M_desel rows of the matrix A that +*> should NOT be considered by the column selection algorithm (i.e. +*> during the factorization). This is controlled by flags in +*> the array DESEL_ROWS. The deselected rows are permuted to the +*> bottom of the matrix A. The details of the row permutation (i.e. the +*> row permutation matrix) are stored in the array IPIV. This feature +*> can be used when the goal is to use the deselected rows as test data, +*> and the selected rows as training data. +*> +*> This means that the column selection factorization algorithm is +*> effectively running on the submatrix A_sub = A(1:M_sub,1:N_sub) of +*> the matrix A after the permutations described above. Here M_sub is +*> the number of rows of the matrix A minus the number of deselected +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> of columns of the matrix A minus the number of deselected columns +*> N_desel, i.e. N_sub = N - N_desel. +*> +*> The reported column selection error metrics MAXC2NRMK, RELMAXC2NRMK +*> and FNRMK described below are computed using only A_sub. +*> +*> Column selection criteria. +*> ========================== +*> +*> The column selection criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) KMAXFREE: This input parameter specifies the maximum number of +*> columns to factorize in addition to the N_sel preselected +*> columns. The factorization rank is limited to N_sel + KMAXFREE. +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), this criterion +*> is not used. +*> +*> 2) ABSTOL: This input parameter specifies the absolute tolerance +*> for the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), where +*> A_sub(K) denotes the contents of the array +*> A_sub = A(1:M_sub, 1:N_sub) after K columns were factorized. +*> This means that the factorization stops if this norm is less +*> than or equal to ABSTOL. If ABSTOL < 0.0, this criterion is +*> not used. +*> +*> 3) RELTOL: This input parameter specifies the tolerance for +*> the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) divided +*> by the maximum column 2-norm of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub), where A_sub(K) denotes the contents +*> of the array A_sub after K columns were factorized. +*> This means that the factorization stops when the ratio of the +*> maximum column 2-norm of A_sub_resid(K) to the maximum column +*> 2-norm of A_sub is less than or equal to RELTOL. +*> If RELTOL < 0.0, this criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the entire submatrix A_sub is factorized. +*> +*> To perform a full-rank factorization of the matrix A_sub, use +*> selection criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) +*> and ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> If the user wishes to verify that the columns of the matrix C are +*> sufficiently linearly independent for their intended use, the user +*> can compute the condition number of its R factor by calling DTRCON +*> on the upper-triangular part of QRC(1:K,1:K) in the output +*> array QRC. +*> +*> How N_sel affects the column selection algorithm. +*> ================================================= +*> +*> As mentioned above, the N_sel preselected columns are permuted to the +*> left side of the matrix A, and will be included in the column +*> selection. Then the routine factorizes that block A(1:M_sub,1:N_sel), +*> and if any of the three stopping criteria is met immediately after +*> factoring the first N_sel columns the routine exits +*> (i.e. if the user does not want to select KMAXFREE > 0 extra columns, +*> or if the absolute or relative tolerance of the maximum column 2-norm +*> of the residual is satisfied). In this case, the number +*> of selected columns would be K = N_sel. Otherwise, the factorization +*> routine finds a new column to select with the maximum column 2-norm +*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and swaps that +*> column with the first column of A(1:M,N_sel+1:N_sub). Then the +*> routine checks if the stopping criteria are met in the next residual +*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. +*> +*> Computation of the matrix factors. +*> ================================== +*> +*> When the columns are selected for the factor C, and: +*> (a) If the flag FACT = 'P', the routine returns only the indices of +*> the selected columns from the original matrix A, which are +*> stored in the first K elements of the JPIV array. +*> (b) If the flag FACT = 'C', then in addition to (a), the routine +*> explicitly returns the matrix C in the array C. +*> (c) If the flag FACT = 'X', then in addition to (a) and (b), +*> the routine explicitly computes and returns the factor +*> X = pseudoinv(C) * A in the array X, and it also returns +*> the factor R alongside the Householder vectors +*> of the QR factorization of the matrix C in the array QRC. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> The flag specifies how the factors of a CX factorization +*> are returned. +*> +*> = 'P': the routine returns: +*> (1) only the column permutation matrix P in +*> the array JPIV. +*> (The first K elements of the array JPIV +*> contain indices of the columns that were +*> selected from the matrix A to form the +*> factor C.) +*> (fastest option, smallest memory space) +*> +*> = 'C': the routine returns: +*> (1) the column permutation matrix P +*> in the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (slower option, more memory space) +*> +*> = 'X': the routine returns: +*> (1) the column permutation matrix P in +*> the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (3) the K-by-N factor X explicitly in the array X. +*> (4) the K-by-K upper triangular factor R and +*> the Householder vectors of the QR factorization +*> of the factor C in the array QRC. +*> ( The factor R may be useful for checking +*> the factor C for singularity, in which case +*> R will have a zero on the diagonal, and +*> the factor X cannot be computed. ) +*> (slowest option, largest memory space) +*> \endverbatim +*> +*> \param[in] USESD +*> \verbatim +*> USESD is CHARACTER*1 +*> The flag specifies whether the row deselection and column +*> preselection-deselection functionality is turned ON or OFF. +*> +*> = 'N': Both row deselection and column +*> preselection-deselection are OFF. +*> Both arrays DESEL_ROWS and SEL_DESEL_COLS +*> are not used. +*> +*> = 'R': Only row deselection is ON. +*> Column preselection-deselection is OFF. +*> The array SEL_DESEL_COLS is not used. +*> +*> = 'C': Only column preselection-deselection is ON. +*> Row deselection is OFF. +*> The array DESEL_ROWS is not used. +*> +*> = 'A': Means "All". Both row deselection and column +*> preselection-deselection are ON. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (M) +*> DESEL_ROWS is only accessed if USESD = 'R' or 'A'. +*> This is a row deselection mask array that separates +*> the rows of matrix A into 2 sets. +*> +*> On entry: +*> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is +*> deselected by the user, i.e. chosen to be excluded from +*> the column selection algorithm (in both preselection and +*> selection stages) and will be permuted to the bottom +*> of the matrix A. +*> The number of deselected rows is denoted by M_desel. +*> +*> b) If DESEL_ROWS(i) is not equal -1, +*> the i-th row of A will be used in the column selection +*> algorithm (in both preselection and selection stages). +*> This defines a set of M_sub = M - M_desel rows that +*> the algorithm will use to select columns. +*> After the permutation, this set will be at the top +*> of the matrix A. +*> +*> On exit: +*> DESEL_ROWS will be permuted according to IPIV(i), +*> so that, if IPIV(i) = k, then the entry i of DESEL_ROWS +*> on exit was the entry k of DESEL_ROWS on entry. +*> +*> \endverbatim +*> +*> \param[in,out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (N) +*> SEL_DESEL_COLS is only accessed if USESD = 'C' or 'A'. +*> This is a column preselection-deselection mask array that +*> separates the columns of matrix A into 3 sets. +*> +*> On entry: +*> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix +*> A is preselected by the user to be included +*> in the factor C and will be permuted to the left side +*> of the array A. The number of selected columns is +*> denoted by N_sel. +*> +*> b) If SEL_DESEL_COLS(j) = -1, the j-th column of the matrix +*> A is deselected by the user, i.e. chosen to be excluded +*> from the factor C and will be permuted to the right side +*> of the array A. The number of deselected columns is +*> denoted by N_desel. +*> +*> c) If SEL_DESEL_COLS(j) is not equal to 1 and not equal +*> to -1, the j-th column of A is a free column and will be +*> used by the column selection algorithm to determine if +*> this column will be selected. This defines a set of +*> columns of size N_free = N - N_sel - N_desel. +*> +*> On exit: +*> SEL_DESEL_COLS will be permuted according to JPIV(j), +*> so that, if JPIV(j) = k, then the entry j +*> of SEL_DESEL_COLS on exit was the entry k +*> of SEL_DESEL_COLS on entry. +*> +*> NOTE: An error returned as INFO = -6 means that the number +*> of preselected N_sel columns is larger than M_sub. +*> Therefore, the QR factorization of all N_sel preselected +*> columns cannot be completed. +*> \endverbatim +*> +*> \param[in] KMAXFREE +*> \verbatim +*> KMAXFREE is INTEGER, KMAXFREE >= 0. +*> +*> The first column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> KMAXFREE is the maximum number of columns of the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) to select +*> during the column selection stage 2. +*> +*> KMAXFREE does not include the preselected N_sel columns. +*> N_sel + KMAXFREE is the maximum factorization rank of +*> the matrix A_sub. +*> +*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this +*> stopping criterion is not used, i.e. columns are +*> selected in the factorization stage 2 depending +*> on ABSTOL and RELTOL. +*> +*> b) If KMAXFREE = 0, then this stopping criterion is +*> satisfied on input and the routine exits without +*> performing column selection stage 2 +*> on the submatrix A_sub. This means that the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified +*> in the column selection stage 2 +*> and A_free is itself the residual for the factorization. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL, cannot be NaN. +*> +*> The second column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> ABSTOL is the absolute tolerance (stopping threshold) +*> for maxcol2norm(A_sub_resid(K)), where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> The column selection algorithm converges +*> (stops the factorization) when +*> maxcol2norm(A_sub_resid(K)) <= ABSTOL, where K >= N_sel. +*> +*> In the following, +*> SAFMIN = SLAMCH('S'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> maxcol2norm(A_free) is the maximum column 2-norm +*> of the matrix A_free. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -8 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and RELTOL. +*> This includes the case where ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case where ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> If ABSTOL chosen above is >= maxcol2norm(A_free), then +*> this stopping criterion is satisfied on input, and +*> the routine only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. The routine +*> then computes maxcol2norm(A_free) and returns it +*> in MAXC2NORMK, computes and returns RELMAXC2NORMK of A_free, +*> and exits immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified in the column selection stage 2. +*> This includes the case where ABSTOL = +Inf. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL, cannot be NaN. +*> +*> The third column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> RELTOL is the tolerance (stopping threshold) for the ratio +*> relmaxcol2norm(A_sub_resid(K)) = +*> = maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub), +*> where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> maxcol2norm(A_sub) is the maximum column 2-norm +*> of the original submatrix A_sub = A(1:M_sub, 1:N_sub). +*> The column selection algorithm converges +*> (stops the factorization) when the ratio +*> relmaxcol2norm(A_sub_resid(K)) <= RELTOL, where K >= N_sel. +*> +*> In the following, +*> EPS = SLAMCH('E'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -9 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input, and the routine +*> only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. +*> The routine then computes maxcol2norm(A_free) and returns +*> it in MAXC2NORMK, returns RELMAXC2NORMK as 1.0, and exits +*> immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified. +*> This includes the case RELTOL = +Inf. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> +*> On entry: +*> the M-by-N matrix A. +*> +*> On exit: +*> +*> NOTE: +*> The output parameter K, the number of selected +*> columns, is described later. +*> A_sub = A(1:M_sub, 1:N_sub). +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> +*> 2) If K > 0, A(1:M,1:N) contains the following parts: +*> +*> (a) If M_sub < M (which is the same as M_desel > 0), +*> the subarray A(M_sub+1:M,1:N) contains the deselected +*> rows. +*> +*> (b) If N_sub < N ( which is the same as N_desel > 0 ), +*> the subarray A(1:M,N_sub+1:N) contains the +*> deselected columns. +*> +*> (c) If N_sel > 0, +*> the union of the subarray A(1:M_sub, 1:N_sel) +*> and the subarray A(1:N_sel, 1:N_sub) contains parts +*> of the factors obtained by computing Householder QR +*> factorization WITHOUT column pivoting of N_sel +*> preselected columns using the routine SGEQRF. +*> +*> (d) The subarray A(N_sel+1:M_sub, N_sel+1:N_sub) +*> contains parts of the factors obtained by computing +*> a truncated (rank K) Householder QR factorization with +*> column pivoting using the routine SGEQP3RK on +*> the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> which is the result of applying selection and +*> deselection of columns, applying deselection of rows +*> to the original matrix A, and applying orthogonal +*> transformation from the factorization of the first +*> N_sel columns as described in part (c). +*> +*> 1. The elements below the diagonal of the subarray +*> A_sub(1:M_sub,1:K) together with TAU(1:K) +*> represent the orthogonal matrix Q(K) as a +*> product of K Householder elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A_sub(1:K,1:N_sub) contain the +*> K-by-N_sub upper-trapezoidal matrix +*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). +*> NOTE: If K = min(M_sub,N_sub), i.e. full rank +*> factorization, then R_sub_approx(K) is the +*> full factor R which is upper-trapezoidal. +*> If, in addition, M_sub >= N_sub, then R is +*> upper-triangular. +*> +*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains +*> the (M_sub-K)-by-(N_sub-K) rectangular matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were selected +*> (K is the factorization rank). +*> 0 <= K <= min( M_sub, N_sel+KMAXFREE, N_sub ). +*> +*> NOTE: If K = 0, a) the arrays A is not, modified. +*> b) the array TAU(1,min(M_sub,N_sub)) +*> is set to ZERO. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, so +*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified +*> and is itself a residual matrix, then MAXC2NRMK equals +*> the maximum column 2-norm of the original matrix A_sub. +*> +*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. +*> +*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K is equal +*> to the diagonal element R_sub(K+1,K+1) of the factor +*> R_sub in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM +*> of the maximum column 2-norm MAXC2NRMK of the residual +*> matrix A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when +*> factorization stopped at rank K) and maximum column 2-norm +*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). +*> RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub was not modified +*> and is itself a residual matrix, +*> then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M_sub,N_sub), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix +*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next +*> factorization step K+1, where R_sub(K+1,K+1) is the +*> diagonal element of the factor R_sub in the next +*> factorization step K+1. +*> \endverbatim +*> +*> \param[out] FNRMK +*> \verbatim +*> FNRMK is REAL +*> Frobenius norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). +*> FNRMK >= 0.0 +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (M) +*> Row permutation indices due to row deselection, +*> for 1 <= i <= M. +*> If IPIV(i) = k, then the row i of A was +*> the row k of A. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column permutation indices, for 1 <= j <= N. +*> If JPIV(j)= k, then the column j of A*P was +*> the column k of A. +*> +*> The first K elements of the array JPIV contain +*> indices of the columns of the factor C that were selected +*> from the matrix A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (min(M_sub,N_sub)) +*> The scalar factors of the elementary reflectors. +*> +*> If K = 0, all elements TAU(1:min(M_sub,N_sub)) are set +*> to zero. +*> If 0 < K <= min(M_sub,N_sub): +*> only the elements TAU(1:K) may be modified, +*> the elements TAU(K+1:min(M_sub,N_sub)) are set to zero. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is REAL array. +*> +*> If FACT = 'P': +*> the array is not used, the array dimension >= (1,1). +*> +*> If FACT = 'C': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C contains a copy of +*> the original M-by-N matrix A. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C contain +*> the deselected columns from the original +*> matrix A. +*> +*> If FACT = 'X': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C is not used. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C are +*> not used. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> If FACT = 'P', LDC >= 1. +*> If FACT = 'C' or 'X', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is REAL array. +*> +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': the array dimension is (LDQRC,min(M,N)). +*> +*> If K = 0, the array is not used. +*> If K > 0, QRC(1:M,1:K) stores two components from +*> the QR factorization of the factor C. The K-by-K +*> factor R is stored in the upper triangle. +*> The Householder vectors are stored in the lower +*> trapezoid below the diagonal. +*> \endverbatim +*> +*> \param[in] LDQRC +*> \verbatim +*> LDQRC is INTEGER +*> The leading dimension of the array QRC. +*> If FACT = 'P' or 'C', LDQRC >= 1. +*> If FACT = 'X', LDQRC >= max(1,M). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array. +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': The array dimension is (LDX,N). +*> 1) If K = 0: +*> the M-by-N array X contains a copy of +*> the original M-by-N matrix A. +*> 2) If K > 0: +*> a) rows (1:K) of the M-by-N array X contain +*> the K-by-N factor X, where K <= N. +*> b) rows (K+1:M) of the M-by-N array X. +*> Each column of these rows contains the elements +*> whose sum of squares is the residual sum of +*> squares for the solution in each column of +*> the least squares problem. +*> min|| A - C*X ||_F for the unknown X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> If FACT = 'P' or 'C', LDX >= 1. +*> If FACT = 'X', LDX >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)). +*> +*> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> Minimal LWORK workspace general requirement. +*> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> For good performance, LWORK should generally be larger, and +*> the user should query the routine for the optimal LWORK. +*> +*> If LWORK = -1 or LIWORK =-1 then a workspace query is assumed. +*> The routine only calculates the optimal size of the WORK and +*> IWORK arrays, returns these values as the first entry of +*> the WORK and IWORK arrays respectively, and no error message +*> related to LWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R' and for all FACT: +*> LWORK >= max( 1, 3*N - 1 ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P' or 'C': +*> LWORK >= max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +*> b) If FACT = 'X': +*> LWORK >= max( 1, min(M,N)+N, +*> min(1,MINMNFREE)*(3*N_free-1) ) +*> where MINMNFREE = min( M_free, N_free ). +*> +*> NOTE: The decision, whether the routine uses unblocked +*> BLAS 2 or blocked BLAS 3 code is based not only on the +*> dimension LWORK of the available workspace WORK, but +*> also on: +*> 1a) column preselection stage using SGEQRF: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine SGEQRF +*> in comparison to N_sel. (For N_sel <= NX +*> or N_sel <= NB, unblocked code is used in SGEQRF.) +*> 1b) column preselection stage using SORMQR: +*> the optimal block size NB returned by ILAENV for +*> the routine SORMQR in comparison to N_sel. (For +*> N_sel <= NB, unblocked code is used in SORMQR.) +*> 2) column selection stage via criteria using SGEQRP3RK: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine SGEQRP3RK +*> in comparison to min(M,N_sel). (For +*> min(M_sub, N_free, KMAXFREE) <= NX +*> or min(M_sub, N_free, KMAXFREE) <= NB, unblocked code +*> is used in SGEQRP3RK.) +*> 3a) computation of the factor X using SGEQRF in SGELS: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine SGEQRF +*> in comparison to K. (For K <= NX or K <= NB, +*> unblocked code is used in SGEQRF inside SGELS.) +*> 3b) computation of the factor X using SORMQR in SGELS: +*> the optimal block size NB returned by ILAENV for +*> the routine SORMQR in comparison to N. (For +*> N <= NB, unblocked code is used in SORMQR +*> inside SGELS.) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)). +*> +*> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> +*> Minimal LIWORK workspace general requirement. +*> LIWORK >= max( 1, 2*N ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> The optimal LIWORK is the same as the minimal LIWORK. +*> The user can still query the routine for the optimal LIWORK. +*> +*> If LIWORK = -1 or LWORK =-1 then a workspace query is assumed. +*> The routine only calculates the optimal size of the WORK and +*> IWORK arrays, returns these values as the first entry of +*> the WORK and IWORK arrays respectively, and no error message +*> related to LIWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, N-1 ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular R factor of the QR factorization of +*> the matrix C is zero. Consequently, C does not have +*> full rank, and X cannot be computed as the least +*> squares solution to the overdetermined system C*X = A. +*> (R is stored in the array QRC.) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2026, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> \endverbatim +* +*> \ingroup gecxx +* +* ===================================================================== + SUBROUTINE SGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER FACT, USESD + INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, + $ LDX, LIWORK, LWORK, M, N + REAL ABSTOL, FNRMK, MAXC2NRMK, + $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), + $ JPIV( * ), SEL_DESEL_COLS( * ) + REAL A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), + $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, TWO, MINUSONE + PARAMETER ( ZERO = 0.0E+0, TWO = 2.0E+0, + $ MINUSONE = -1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, RETURNC, RETURNX, + $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL + INTEGER I, IP, IINFO, ITEMP, J, JDESEL, JP, KFREE, + $ KMAXLS, KP0, LIWKMIN, LIWKOPT, LWKMIN, + $ LWKOPT, MFREE, MDESEL, MINMN, MINMNFREE, + $ MRESID, MSUB, NFREE, NDESEL, NRESID, NSEL, + $ NSUB + REAL ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, + $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN + +* .. External Subroutines .. + EXTERNAL SCOPY, SGELS, SGEQP3RK, SGEQRF, SLACPY, + $ SORMQR, SSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL SISNAN, LSAME + INTEGER ISAMAX, ILAENV + REAL SLAMCH, SLANGE, SNRM2 + EXTERNAL SISNAN, SLAMCH, SLANGE, SNRM2, ISAMAX, + $ ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MDESEL = 0 + NSEL = 0 + NDESEL = 0 + MSUB = M + NSUB = N + MFREE = MSUB + NFREE = NSUB + MINMN = MIN( M, N ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + RETURNX = LSAME( FACT, 'X' ) + RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX +* + USE_DESEL_ROWS = LSAME( USESD, 'R' ) + $ .OR. LSAME( USESD, 'A' ) + USE_SEL_DESEL_COLS = LSAME( USESD, 'C' ) + $ .OR. LSAME( USESD, 'A' ) +* + IF( .NOT.( RETURNC .OR. LSAME( FACT, 'P') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS + $ .OR. LSAME( USESD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE +* +* This is to check that the number of preselected columns NSEL +* cannot be larger than MSUB, which is the number of rows +* without MDESEL deselected rows. When the number of +* preselected columns NSEL is larger than MSUB, +* the factorization of all preselected NSEL columns cannot be +* completed. MSUB also will be used for LDX argument check +* later. +* + IF( USE_DESEL_ROWS ) THEN +* +* Count the number of free rows MSUB. +* + DO I = 1, M + IF( DESEL_ROWS( I ).EQ.-1 ) MDESEL = MDESEL + 1 + END DO + MSUB = M - MDESEL + MFREE = MSUB + END IF +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Count the number of preselected columns NSEL and the +* number of preselected and free columns NSUB = N - NDESEL. +* + DO J = 1, N + IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 + END DO + NSUB = N - NDESEL + MFREE = MSUB - NSEL + NFREE = NSUB - NSEL +* + END IF + MINMNFREE = MIN( MFREE, NFREE ) +* + IF( NSEL.GT.MSUB ) THEN + INFO = -6 + ELSE IF( KMAXFREE.LT.0 ) THEN + INFO = -7 + ELSE IF( SISNAN( ABSTOL ) ) THEN + INFO = -8 + ELSE IF( SISNAN( RELTOL ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 +* This is a check for LDC + ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN + INFO = -20 +* This is a check for LDQRC + ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN + INFO = -22 +* This is a check for LDX + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN + INFO = -24 + END IF +* + END IF +* +* ================================================================== +* +* a) Test the input workspace size LWORK and LIWORK for the +* minimum size requirement LWKMIN and LIWKMIN respectively. +* b) Determine the optimal workspace sizes LWKOPT and LIWKOPT to +* be returned in WORK( 1 ) and IWORK( 1 ) respectively, +* if INFO >= 0 in cases: +* (1) LQUERY = .TRUE., +* (2) when the routine exits. +* Here, LWKMIN and LIWKMIN are the minimum workspaces required for +* unblocked code. +* + IF( INFO.EQ.0 ) THEN + IF( MINMN.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + LIWKMIN = 1 + LIWKOPT = 1 + ELSE +* +* (Real_wk_part_a) Real minimum workspace computation. +* LWKMIN = MAX(1, NSUB) for column 2-norm computation +* + LWKMIN = MAX( 1, NSUB ) +* +* (Int_wk_part_1) Integer minimum workspace computation. +* + LIWKMIN = 1 +* +* Optimal workspace for column 2-norm computation. +* + LWKOPT = LWKMIN +* +* Call of SGEQRF. +* + IF( NSEL.GT.0 ) THEN +* +* (Real_wk_part_b) Real minimum workspace computation. +* LWKMIN = MAX(1, NSEL) for the call of SGEQRF. +* We can skip counting this workspace as +* LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. +* +* Query for optimal workspace size for SGEQRF. +* + CALL SGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* Call of SORMQR. +* + IF( NFREE.GT.0 ) THEN +* +* (Real_wk_part_c) Real minimum workspace computation. +* NOTE: minimum workspace requirement for SORMQR +* LWKMIN = MAX(1, NFREE) is smaller than +* LWKMIN = 3*NFREE-1 for SGEQP3RK and it is +* smaller than NSUB. We can skip counting this +* workspace as LWKMIN = MAX( LWKMIN, NFREE ). +* +* Query for optimal workspace size for SORMQR. +* + CALL SORMQR( 'L', 'T', MSUB, NFREE, + $ NSEL, A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) + END IF +* + END IF +* +* Call of SGEQP3RK. +* + + IF ( MINMNFREE.NE.0 ) THEN +* +* (Real_wk_part_d) Real minimum workspace computation. +* LWKMIN = MAX(1, 3*NFREE-1) for the call of SGEQP3RK. +* + LWKMIN = MAX( LWKMIN, 3*NFREE - 1 ) +* +* Query for optimal workspace size for SGEQP3RK. +* + CALL SGEQP3RK( MFREE, NFREE, 0, NFREE, + $ MINUSONE, MINUSONE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), + $ WORK, -1, IWORK, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* (Int_wk_part_2) Integer minimum workspace computation. +* LIWKMIN = NFREE-1 for the call of SGEQP3RK. +* + LIWKMIN = MAX( LIWKMIN, NFREE-1 ) +* + IF( NSEL.NE.0 ) THEN +* +* (Int_wk_part_3) Integer minimum workspace computation. +* NFREE is for SGEQP3RK and NFREE-1 for JPIV adjustment. +* + LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) + END IF +* + END IF +* + IF( RETURNC ) THEN +* +* Integer minimum workspace computation. +* (Int_wk_part_3) LIWKMIN = 2*N for applying the +* interchanges for the columns in the matrix C. +* + LIWKMIN = MAX( LIWKMIN, 2*N ) + END IF + LIWKOPT = LIWKMIN +* +* Call of SGELS. +* + IF( RETURNX ) THEN +* +* (Real_wk_part_d) Real minimum workspace computation. +* LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = +* = max( 1, MINMN + N ) for the call of SGELS. +* + LWKMIN = MAX( LWKMIN, MINMN + N ) +* +* Query for optimal workspace size for SGELS. +* + KMAXLS = MINMN +* + CALL SGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, + $ WORK, -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) +* + END IF +* +* End of ELSE for IF( MINMN.EQ.0 ) +* + END IF +* + IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -26 + ELSE IF( ( LIWORK.LT.LIWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -28 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = REAL( LWKOPT ) + IWORK( 1 ) = LIWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGECXX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* ================================================================== +* +* Quick return if possible for: +* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). +* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). +* NOTE: min( M, N) = 0 implies min( MSUB, NSUB) = 0. +* We need to return correct values for all scalar output parameters, +* (including WORK(1) and IWORK(1), which are set above). +* + IF( MIN( MSUB, NSUB ).EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO + RETURN + END IF +* +* ================================================================== +* + K = 0 +* +* If we need to return factor X, copy the original untouched matrix +* A into the array X. +* + IF( RETURNX ) THEN + CALL SLACPY( 'F', M, N, A, LDA, X, LDX ) + END IF +* +* If we need to return the factor C, copy the original matrix A +* into the array C, only if do not return the factor X. In this +* case, we need to choose the columns of the matrix A in the array C +* in place, otherwise we can copy the columns of the matrix A from +* the array X. +* + IF( RETURNC .AND. .NOT. RETURNX ) THEN + CALL SLACPY( 'F', M, N, A, LDA, C, LDC ) + END IF +* +* ================================================================== +* Permute the deselected rows to the bottom of the matrix A. +* 1) The initial order of included rows in their block is preserved. +* 2) The initial order of deselected rows in their block is not +* preserved. +* ================================================================== +* +* I is an index of DESEL_ROWS array and a row index of +* the matrix A. MSUB is the number of processed included rows, which +* is also an index pointer to the last included row in the matrix A. +* We can think of I as a row source index, and MSUB as a destination +* index for moving an included row in the matrix A. +* +* ( We start with MSUB = 0. We loop over index I in (1:M), and +* for each position I in DESEL_ROWS array, we check if the row at +* the position I in the matrix A is an included row (not -1 value). +* If it is an included row, we increment MSUB pointer, otherwise +* we do not change MSUB index pointer. Then, we bring this included +* row from the index I in the matrix A into smaller (or same) +* MSUB index in the matrix A. If I = MSUB, then the included row +* is already in place. Due to row swap, the deselected row +* at MSUB index will move into I index in the matrix A. In this way, +* we move all the included rows to the top matrix block preserving +* their initial order within the included block. The initial order +* of deselected rows will not be preserved within their block. +* + IF( USE_DESEL_ROWS ) THEN +* + MSUB = 0 + DO I = 1, M, 1 +* +* Initialize the row pivot array IPIV. + IPIV( I ) = I +* +* The row at the index I is an included row and should be +* moved to the top of the matrix A. +* + IF( DESEL_ROWS( I ).NE.-1 ) THEN + MSUB = MSUB + 1 +* +* This is a check whether the included row is +* on the included place already. +* + IF( I.NE.MSUB ) THEN +* +* Here, we swap A(I,1:N) into A(MSUB,1:N). +* + CALL SSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) +* +* Save the interchange. +* + IPIV( I ) = IPIV( MSUB ) + IPIV( MSUB ) = I + DESEL_ROWS( MSUB ) = DESEL_ROWS( I ) + DESEL_ROWS( I ) = -1 + END IF + END IF +* + END DO +* + ELSE +* +* We do not use the row deselection DESEL_ROWS array. +* Initialize the row pivot array IPIV. +* NOTE: MSUB=M has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO I = 1, M, 1 + IPIV( I ) = I + END DO + END IF +* +* ================================================================== +* Permute the preselected columns to the left and deselected +* columns to the right of the matrix A. +* 1) The order of preselected columns is preserved. +* 2) The order of free columns is not preserved. +* 3) The order of deselected columns is not preserved. +* ================================================================== +* +* J is the index of SEL_DESEL_COLS array and column J +* of the matrix A. +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Column selection. +* NSEL is the number of selected columns, also the pointer to +* the last selected column. +* + NSEL = 0 + DO J = 1, N, 1 +* +* Initialize column pivot array JPIV. + JPIV( J ) = J +* + IF( SEL_DESEL_COLS( J ).EQ.1 ) THEN + NSEL = NSEL + 1 +* +* This is the check whether the selected column is +* on the selected place already. +* + IF( J.NE.NSEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,NSEL) +* + CALL SSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) + JPIV( J ) = JPIV( NSEL ) + JPIV( NSEL ) = J + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) + SEL_DESEL_COLS( NSEL ) = 1 + END IF + END IF + END DO +* +* Column deselection. +* JDESEL the pointer to the last +* deselected column counting right-to-left. +* + JDESEL = N+1 + DO J = N, NSEL+1, -1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN + JDESEL = JDESEL - 1 +* +* This is the check whether the deselected column is +* on the deselected place already. +* + IF( J.NE.JDESEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) +* + CALL SSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) + ITEMP = JPIV( J ) + JPIV( J ) = JPIV( JDESEL ) + JPIV( JDESEL ) = ITEMP + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) + SEL_DESEL_COLS( JDESEL ) = -1 + END IF + END IF + END DO +* + NSUB = JDESEL - 1 +* + ELSE +* +* We do not use the column selection deselection +* SEL_DESEL_COLS array. +* Initialize column pivot array JPIV. +* NOTE: NSUB=N has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO J = 1, N, 1 + JPIV( J ) = J + END DO +* + END IF +* +* ================================================================== +* Compute the complete column 2-norms of the submatrix +* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). +* + DO J = 1, NSUB + WORK( J ) = SNRM2( MSUB, A( 1, J ), 1 ) + END DO +* +* Compute the column index of the maximum column 2-norm and +* the maximum column 2-norm itself for the submatrix +* A_sub = A(1:MSUB, 1:NSUB). +* + KP0 = ISAMAX( NSUB, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP0 ) +* +* ================================================================== +* Process preselected columns +* +* Compute the QR factorization of NSEL preselected columns (1:NSEL) +* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update +* remaining NFREE free columns (NSEL+1:NSUB). +* NSUB = NSEL + NFREE +* + IF( NSEL.GT.0 ) THEN +* +* Case (a): MSUB < NSEL. +* +* This is handled at the argument check stage in the +* beginning of the routine. When the number of preselected +* columns is larger than MSUB, hence the factorization of +* all NSEL columns cannot be completed. Return from the +* routine with the error of COL_SEL_DESEL parameter. +* +* Case (b): MSUB = NSEL. +* Case (c-1): MSUB > NSEL and NSEL = NSUB. +* +* For cases (b) and (c-1), there will be no residual +* submatrix after factorization of NSEL columns +* at step K = NSEL: +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). +* +* Case (c-2): MSUB > NSEL and NSEL < NSUB. +* +* For Case (c-2) is a submatrix residual at step K=NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL SGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) +* +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) +* + IF( NFREE.GT.0 ) THEN +* +* This is only for case (c-2) ('L' = Left, 'T' = Transpose) +* + CALL SORMQR( 'L', 'T', MSUB, NFREE, NSEL, + $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ LWORK, IINFO ) + END IF +* + K = K + NSEL +* +* End of IF(NSEL.GT.0) +* + END IF +* +* ================================================================== +* + KFREE = 0 +* + IF( MINMNFREE.NE.0 ) THEN +* +* Factorize NFREE free columns of +* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), +* KFREE is the number of columns that were actually factorized +* among NFREE columns. +* +* ================================================================== +* + EPS = SLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = SLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Adjust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* +* Disable RELTOLFREE when calling SGEQP3RK for free columns +* factorization, since SGEQP3RK expects RELTOLFREE with respect +* to the residual matrix A_sub_resid(NSEL), not the whole +* original matrix A. We can use RELTOL criterion by passing it +* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that +* the negative values of ABSTOL and RELTOL are propagated +* to ABSTOLFREE and RELTOLFREE, since negative values means +* that the criterion is disabled. +* + IF( USETOL ) THEN + ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) + ELSE + ABSTOLFREE = MINUSONE + END IF + RELTOLFREE = MINUSONE +* +* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + IWORK( NFREE + J ) = JPIV( NSEL+J ) + END DO + END IF +* + CALL SGEQP3RK( MFREE, NFREE, 0, KMAXFREE, + $ ABSTOLFREE, RELTOLFREE, + $ A( NSEL+1, NSEL+1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( NSEL+1 ), + $ TAU( NSEL+1 ), WORK, LWORK, IWORK, IINFO ) +* +* Adjust JPIV +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + JPIV( NSEL+J ) = IWORK( NFREE + JPIV( NSEL+J ) ) + END DO + END IF +* +* 1) Adjust the return value for the number of factorized +* columns K for the whole submatrix A_sub. +* 2) MAXC2NRMK is returned transparently without change +* as MAXC2NRMKFREE is returned from SGEQP3RK. +* 3) Adjust the return value RELMAXC2NRMK for the whole +* submatrix A_sub. We do not use RELMAXC2NRMKFREE +* returned from SGEQP3RK. +* + K = K + KFREE + MAXC2NRMK = MAXC2NRMKFREE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + ELSE +* +* Set norms to zero +* + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + END IF +* +* Now, MRESID and NRESID is the number of rows and columns +* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). +* + MRESID = MFREE-KFREE + NRESID = NFREE-KFREE +* + IF( MIN( MRESID, NRESID ).NE.0 ) THEN + FNRMK = SLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), + $ LDA, WORK ) + ELSE + FNRMK = ZERO + END IF +* +* ================================================================== +* +* Return the matrix C. +* + IF( RETURNC .AND. K.GT.0 ) THEN +* + IF( RETURNX ) THEN +* +* Copy the selected K columns of the original matrix A (that was +* saved into the array X) into the array C according to +* the pivot array JPIV. If we return X, then the matrix A is +* saved in the array X, and it is faster to copy into C than +* doing column permutation in place, as it is the ELSE case. +* + DO J = 1, K, 1 + CALL SCOPY( M, X( 1, JPIV( J ) ), 1, C( 1, J ), 1 ) + END DO +* + ELSE +* +* Swap the columns of the original matrix A copied into +* the array C in place. +* +* The original M-by-N matrix A was copied into the array C at +* the beginning of the routine, if RETURNC = .TRUE.. + +* Apply the column permutation matrix P stored in JPIV(1:K) +* to the columns 1:K in the M-by-N array C in place. +* After column interchanges, the first K columns of C should +* be the same as the first K columns of A*P, i.e. +* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm +* is min(K,N-1). +* +* Index I is the original column index in the +* array C before interchanges. +* J is the current column index of the original column I at +* each step of interchanges. +* +* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) +* of the current column permutation matrix P(J) at each +* column interchange step J only for the array +* values >= J:N. +* C_prev = P_inv(J) * C_next. +* Each IWORK(I) contains JJ corresponding to I +* Initialize IWORK(1:N) as (1:N). +* + DO I = 1, N, 1 + IWORK( I ) = I + END DO +* +* Auxiliary array IWORK(N+1:2N) stores the current column +* permutation matrix P_(J) at each column interchange step J +* only for the array index >= J:N. +* C_prev * P_(J) = C_next. +* Each IWORK(N+JJ) contains I corresponding to JJ. +* Initialize IWORK(N+1:2*N) as (1:N). +* + DO J = 1, N, 1 + IWORK( N + J ) = J + END DO +* +* Loop over the columns J = ( 1:min( K, N-1 ) ) in C. +* + DO J = 1, MIN( K, N-1 ), 1 +* +* IP is the original pivot column, i.e. is the original +* column that should be placed in the current column index +* J in the array C. +* + IP = JPIV( J ) +* +* I is the original column that is +* currently in the column index J in the array C after +* previous column interchanges. +* + I = IWORK( N+J ) +* + IF( I.NE.IP ) THEN +* +* JP is the current index of the original pivot +* column IP in the array C after previous column +* interchanges. +* + JP = IWORK( IP ) + +* Swap the original pivot column IP = JPIV( J ), +* at the current pivot index JP = IWORK( IP ) into +* index J. +* + CALL SSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) +* +* Update the array IWORK(1:N) for the original column +* I that was swapped with IP. +* + IWORK( I ) = IWORK( IP ) +* +* Update the array IWORK(N+1:2*N) for the current column +* index JP that was swapped with the current column +* index J. +* + IWORK( N + JP ) = IWORK( N + J ) +* + END IF +* + END DO +* +* End of ELSE( RETURNX ) +* + END IF +* +* End of IF( RETURNC .AND. K.GT.0 ) +* + END IF +* +* ================================================================== +* +* Return the matrix X. +* + IF( RETURNX .AND. K.GT.0 ) THEN +* +* We need to use C and A to compute X = pseudoinv(C) * A, as +* the linear least squares solution to the overdetermined system +* C*X = A. We use LLS routine that uses the QR factorization. For +* that purpose, we store the matrix C into the array QRC. +* The matrix A was copied into the array X at the beginning +* of the routine. +* + CALL SLACPY( 'F', M, K, C, LDC, QRC, LDQRC ) +* + CALL SGELS( 'N', M, K, N, QRC, LDQRC, X, LDX, + $ WORK, LWORK, IINFO ) + INFO = IINFO +* + END IF +* + WORK( 1 ) = REAL( LWKOPT ) + IWORK( 1 ) = LIWKOPT +* +* End of SGECXX +* + END From bd16e522682870d8dd786135cf0d5b80fa97d5af Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 4 May 2026 22:23:59 -0700 Subject: [PATCH 49/63] TESTING/LIN/dchkaa.F: fixed routine declaraiton truncation modified: TESTING/LIN/dchkaa.F --- TESTING/LIN/dchkaa.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/TESTING/LIN/dchkaa.F b/TESTING/LIN/dchkaa.F index 27729352c..762248e78 100644 --- a/TESTING/LIN/dchkaa.F +++ b/TESTING/LIN/dchkaa.F @@ -172,8 +172,8 @@ PROGRAM DCHKAA $ DCHKSY_AA, DCHKTB, DCHKTP, DCHKTR, DCHKTZ, $ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO, $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, - $ DDRVSY_RK, DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, - $ DCHKQRTP, DCHKLQT,DCHKTSQR + $ DDRVSY_RK, DDRVSY_AA, ILAVER, DCHKLQTP, + $ DCHKQRT, DCHKQRTP, DCHKLQT,DCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK From 0a260664a969a193c046b59d1017699a9dc9b9eb Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 4 May 2026 22:25:49 -0700 Subject: [PATCH 50/63] TESTING/LIN/dchkcxx.f: removed unused variable and routine declarations also changed Definition sections in the top comments modified: TESTING/LIN/dchkcxx.f --- TESTING/LIN/dchkcxx.f | 27 ++++++++++----------------- 1 file changed, 10 insertions(+), 17 deletions(-) diff --git a/TESTING/LIN/dchkcxx.f b/TESTING/LIN/dchkcxx.f index 579354e7e..b0a17c96e 100644 --- a/TESTING/LIN/dchkcxx.f +++ b/TESTING/LIN/dchkcxx.f @@ -18,16 +18,12 @@ * $ WORK, IWORK, NOUT ) * IMPLICIT NONE * -* -- LAPACK test routine -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* -* .. Scalar Arguments .. +* .. Scalar Arguments .. * LOGICAL TSTERR * INTEGER NM, NN, NNB, NOUT * DOUBLE PRECISION THRESH -* .. -* .. Array Arguments .. +* .. +* .. Array Arguments .. * LOGICAL DOTYPE( * ) * INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), * $ NXVAL( * ), @@ -309,13 +305,11 @@ SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, * .. Local Scalars .. CHARACTER DIST, TYPE, FACT, USESD CHARACTER*3 PATH - INTEGER I, IHIGH, ILOW, IM, IMAT, IN, INC_ZERO, - $ INB, IND_OFFSET_GEN, - $ IND_IN, IND_OUT, INS, INFO, - $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO, - $ K, KL, KMAXFREE, KU, LDA, LDC, LDQRC, LDX, - $ LIWORK,LWORK, LWKTST, - $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N, + INTEGER I, IM, IMAT, IN, INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INFO, J, J_INC, J_FIRST_NZ, + $ JB_ZERO, K, KL, KMAXFREE, KU, LDA, LDC, + $ LDQRC, LDX, LIWORK,LWORK, LWKTST, + $ M, MINMN, MINMNB_GEN, MODE, N, $ NB, NBMAX_ORMQR, NB_ZERO, NERRS, NFAIL, $ NB_GEN, NRUN, NX, T DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, @@ -323,11 +317,10 @@ SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) - DOUBLE PRECISION RESULT( NTESTS ), RDUMMY( 1 ) + DOUBLE PRECISION RESULT( NTESTS ) * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE, - $ DLAPY2 + DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE * .. * .. External Subroutines .. From 24e0eafe29bc250861527b2d43fea87e8279f279 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 4 May 2026 22:39:09 -0700 Subject: [PATCH 51/63] TESTING/LIN/dchkcxx.f: removed unused function declaration fro DLANGE modified: TESTING/LIN/dchkcxx.f --- TESTING/LIN/dchkcxx.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/TESTING/LIN/dchkcxx.f b/TESTING/LIN/dchkcxx.f index b0a17c96e..18e5e6e7a 100644 --- a/TESTING/LIN/dchkcxx.f +++ b/TESTING/LIN/dchkcxx.f @@ -320,8 +320,8 @@ SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, DOUBLE PRECISION RESULT( NTESTS ) * .. * .. External Functions .. - DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE - EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE + DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12 + EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12 * .. * .. External Subroutines .. EXTERNAL ALAERH, ALAHD, ALASUM, DAXPY, DERRCXX, From 0346d21074998bc3cf4e369c4e9f1e63989f7f5a Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 4 May 2026 22:48:58 -0700 Subject: [PATCH 52/63] TESTING/LIN/dchkcxx.f: removed more unsused routine declarations modified: TESTING/LIN/dchkcxx.f --- TESTING/LIN/dchkcxx.f | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/TESTING/LIN/dchkcxx.f b/TESTING/LIN/dchkcxx.f index 18e5e6e7a..b784a8163 100644 --- a/TESTING/LIN/dchkcxx.f +++ b/TESTING/LIN/dchkcxx.f @@ -324,12 +324,12 @@ SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12 * .. * .. External Subroutines .. - EXTERNAL ALAERH, ALAHD, ALASUM, DAXPY, DERRCXX, - $ DGEQP3RK, DLACPY, DLAORD, DLASET, DLATB4, - $ DLATMS, DORMQR, DSWAP, ICOPY, XLAENV + EXTERNAL ALAERH, ALAHD, ALASUM, DERRCXX, + $ DGECXX, DLACPY, DLAORD, DLASET, DLATB4, + $ DLATMS, DSWAP, ICOPY, XLAENV * .. * .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, MOD + INTRINSIC ABS, MAX, MIN, MOD * .. * .. Scalars in Common .. LOGICAL LERR, OK From 95f751d9e0a4318298a34ef88ccd15cd877bb778 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 4 May 2026 23:10:41 -0700 Subject: [PATCH 53/63] TESTING/LIN/dchkcxx.f: replaced constant 0D+0 with ZERO parameter from RESULT( 5 ) = 0D+0 to RESULT( 5 ) = ZERO modified: TESTING/LIN/dchkcxx.f --- TESTING/LIN/dchkcxx.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/TESTING/LIN/dchkcxx.f b/TESTING/LIN/dchkcxx.f index b784a8163..edd4f6aa1 100644 --- a/TESTING/LIN/dchkcxx.f +++ b/TESTING/LIN/dchkcxx.f @@ -870,7 +870,7 @@ SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, * equal (including NaN and Inf) * to the JPIV(J)-th column of A. * - RESULT( 5 ) = 0.0D+0 + RESULT( 5 ) = ZERO IF(.FALsE.) THEN DO J = 1, K, 1 DO I = 1, M, 1 From 5c1c526b52a8e3de136e13357a62611baede05a3 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Mon, 4 May 2026 23:38:48 -0700 Subject: [PATCH 54/63] TESTING/LIN/dchkaa.F: added DCHKCXX to routine declaration modified: TESTING/LIN/dchkaa.F --- TESTING/LIN/dchkaa.F | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/TESTING/LIN/dchkaa.F b/TESTING/LIN/dchkaa.F index 762248e78..119b2a372 100644 --- a/TESTING/LIN/dchkaa.F +++ b/TESTING/LIN/dchkaa.F @@ -165,15 +165,16 @@ PROGRAM DCHKAA EXTERNAL LSAME, LSAMEN, DLAMCH, DSECND * .. * .. External Subroutines .. - EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, - $ DCHKORHR_COL, DCHKPB, DCHKPO, DCHKPS, DCHKPP, - $ DCHKPT, DCHKQ3, DCHKQP3RK, DCHKQL, DCHKQR, - $ DCHKRQ, DCHKSP, DCHKSY, DCHKSY_ROOK, DCHKSY_RK, - $ DCHKSY_AA, DCHKTB, DCHKTP, DCHKTR, DCHKTZ, - $ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO, - $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, - $ DDRVSY_RK, DDRVSY_AA, ILAVER, DCHKLQTP, - $ DCHKQRT, DCHKQRTP, DCHKLQT,DCHKTSQR + EXTERNAL ALAREQ, DCHKCXX, DCHKEQ, DCHKGB, DCHKGE, + $ DCHKGT, DCHKLQ, DCHKORHR_COL, DCHKPB, DCHKPO, + $ DCHKPS, DCHKPP, DCHKPT, DCHKQ3, DCHKQP3RK, + $ DCHKQL, DCHKQR, DCHKRQ, DCHKSP, DCHKSY, + $ DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, DCHKTB, + $ DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, DDRVGT, + $ DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT, DDRVSP, + $ DDRVSY, DDRVSY_ROOK, DDRVSY_RK, DDRVSY_AA, + $ ILAVER, DCHKLQTP, DCHKQRT, DCHKQRTP, DCHKLQT, + $ DCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK From 656fbeb7a3391acaedcd502c1059ccc5e575df88 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 5 May 2026 11:03:09 -0700 Subject: [PATCH 55/63] LIN/dchkcxx.f: chnaged comments for test 5. modified: LIN/dchkcxx.f --- TESTING/LIN/dchkcxx.f | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/TESTING/LIN/dchkcxx.f b/TESTING/LIN/dchkcxx.f index edd4f6aa1..2acf0a5f8 100644 --- a/TESTING/LIN/dchkcxx.f +++ b/TESTING/LIN/dchkcxx.f @@ -866,12 +866,13 @@ SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, * =============== * This test is only for the factorizations with the * rank greater than 0. -* For J=1:K, the J-th column of C should be element-wize +* For J=1:K, the J-th column of C should be elementwise * equal (including NaN and Inf) * to the JPIV(J)-th column of A. * RESULT( 5 ) = ZERO - IF(.FALsE.) THEN +* Disable for now, incomplete test. + IF(.FALSE.) THEN DO J = 1, K, 1 DO I = 1, M, 1 IF( .NOT. (C( (J-1)*LDC+I ) From 9c3d06a1b686e40461a2826aa5a824a88ae807b4 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 5 May 2026 11:18:44 -0700 Subject: [PATCH 56/63] added single precision test code for SGECXX modified: TESTING/LIN/CMakeLists.txt modified: TESTING/LIN/Makefile modified: TESTING/LIN/schkaa.F new file: TESTING/LIN/schkcxx.f new file: TESTING/LIN/serrcxx.f modified: TESTING/LIN/slatb4.f modified: TESTING/stest.in --- TESTING/LIN/CMakeLists.txt | 37 +- TESTING/LIN/Makefile | 5 +- TESTING/LIN/schkaa.F | 55 +- TESTING/LIN/schkcxx.f | 933 ++++++++++++++++++++ TESTING/LIN/serrcxx.f | 1691 ++++++++++++++++++++++++++++++++++++ TESTING/LIN/slatb4.f | 108 ++- TESTING/stest.in | 1 + 7 files changed, 2795 insertions(+), 35 deletions(-) create mode 100644 TESTING/LIN/schkcxx.f create mode 100644 TESTING/LIN/serrcxx.f diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index c3d657f99..c770719e7 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -9,13 +9,13 @@ set(DZLNTST dlaord.f) set(SLINTST schkaa.F schkeq.f schkgb.f schkge.f schkgt.f schklq.f schkpb.f schkpo.f schkps.f schkpp.f - schkpt.f schkq3.f schkqp3rk.f schkql.f schkqr.f schkrq.f - schksp.f schksy.f schksy_rook.f schksy_rk.f - schksy_aa.f schksy_aa_2stage.f + schkpt.f schkq3.f schkqp3rk.f schkcxx.f schkql.f schkqr.f schkrq.f + schksp.f schksy.f schksy_rook.f schksy_rk.f + schksy_aa.f schksy_aa_2stage.f schktb.f schktp.f schktr.f schktz.f sdrvgt.f sdrvls.f sdrvpb.f - sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy_rook.f sdrvsy_rk.f + sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy_rook.f sdrvsy_rk.f sdrvsy_aa.f sdrvsy_aa_2stage.f serrgt.f serrlq.f serrls.f serrps.f serrql.f serrqp.f serrqr.f @@ -32,7 +32,7 @@ set(SLINTST schkaa.F sqrt01.f sqrt01p.f sqrt02.f sqrt03.f sqrt11.f sqrt12.f sqrt13.f sqrt14.f sqrt15.f sqrt16.f sqrt17.f srqt01.f srqt02.f srqt03.f srzt01.f srzt02.f - sspt01.f ssyt01.f ssyt01_rook.f ssyt01_3.f + sspt01.f ssyt01.f ssyt01_rook.f ssyt01_3.f ssyt01_aa.f stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f stpt02.f stpt03.f stpt05.f stpt06.f strt01.f @@ -40,7 +40,8 @@ set(SLINTST schkaa.F sgennd.f sqrt04.f sqrt05.f schkqrt.f serrqrt.f schkqrtp.f serrqrtp.f schklqt.f schklqtp.f schktsqr.f serrlqt.f serrlqtp.f serrtsqr.f stsqr01.f slqt04.f slqt05.f - schkorhr_col.f serrorhr_col.f sorhr_col01.f sorhr_col02.f) + schkorhr_col.f serrorhr_col.f sorhr_col01.f sorhr_col02.f + serrcxx.f) if(USE_XBLAS) list(APPEND SLINTST sdrvgbx.f sdrvgex.f sdrvsyx.f sdrvpox.f @@ -53,7 +54,7 @@ endif() set(CLINTST cchkaa.F cchkeq.f cchkgb.f cchkge.f cchkgt.f - cchkhe.f cchkhe_rook.f cchkhe_rk.f + cchkhe.f cchkhe_rook.f cchkhe_rk.f cchkhe_aa.f cchkhe_aa_2stage.f cchkhp.f cchklq.f cchkpb.f cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkqp3rk.f cchkql.f @@ -61,12 +62,12 @@ set(CLINTST cchkaa.F cchksy_aa.f cchksy_aa_2stage.f cchktb.f cchktp.f cchktr.f cchktz.f - cdrvgt.f cdrvhe_rook.f cdrvhe_rk.f + cdrvgt.f cdrvhe_rook.f cdrvhe_rk.f cdrvhe_aa.f cdrvhe_aa_2stage.f cdrvsy_aa_2stage.f cdrvhp.f cdrvls.f cdrvpb.f cdrvpp.f cdrvpt.f - cdrvsp.f cdrvsy_rook.f cdrvsy_rk.f - cdrvsy_aa.f + cdrvsp.f cdrvsy_rook.f cdrvsy_rk.f + cdrvsy_aa.f cerrgt.f cerrlq.f cerrls.f cerrps.f cerrql.f cerrqp.f cerrqr.f cerrrq.f cerrtr.f cerrtz.f @@ -87,7 +88,7 @@ set(CLINTST cchkaa.F cqrt17.f crqt01.f crqt02.f crqt03.f crzt01.f crzt02.f csbmv.f cspt01.f cspt02.f cspt03.f csyt01.f csyt01_rook.f csyt01_3.f - csyt01_aa.f + csyt01_aa.f csyt02.f csyt03.f ctbt02.f ctbt03.f ctbt05.f ctbt06.f ctpt01.f ctpt02.f ctpt03.f ctpt05.f ctpt06.f ctrt01.f @@ -110,13 +111,13 @@ endif() set(DLINTST dchkaa.F dchkeq.f dchkgb.f dchkge.f dchkgt.f dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f - dchkpt.f dchkq3.f dchkqp3rk.f dchkcxx.f dchkql.f dchkqr.f - dchkrq.f dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f + dchkpt.f dchkq3.f dchkqp3rk.f dchkcxx.f dchkql.f dchkqr.f + dchkrq.f dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f dchksy_aa.f dchksy_aa_2stage.f dchktb.f dchktp.f dchktr.f dchktz.f ddrvgt.f ddrvls.f ddrvpb.f - ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy_rook.f ddrvsy_rk.f + ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy_rook.f ddrvsy_rk.f ddrvsy_aa.f ddrvsy_aa_2stage.f derrgt.f derrlq.f derrls.f derrps.f derrql.f derrqp.f derrqr.f @@ -156,7 +157,7 @@ endif() set(ZLINTST zchkaa.F zchkeq.f zchkgb.f zchkge.f zchkgt.f - zchkhe.f zchkhe_rook.f zchkhe_rk.f + zchkhe.f zchkhe_rook.f zchkhe_rk.f zchkhe_aa.f zchkhe_aa_2stage.f zchkhp.f zchklq.f zchkpb.f zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkqp3rk.f zchkql.f @@ -164,12 +165,12 @@ set(ZLINTST zchkaa.F zchksy_aa.f zchksy_aa_2stage.f zchktb.f zchktp.f zchktr.f zchktz.f - zdrvgt.f zdrvhe_rook.f zdrvhe_rk.f + zdrvgt.f zdrvhe_rook.f zdrvhe_rk.f zdrvhe_aa.f zdrvhe_aa_2stage.f zdrvhp.f zdrvls.f zdrvpb.f zdrvpp.f zdrvpt.f - zdrvsp.f zdrvsy_rook.f zdrvsy_rk.f - zdrvsy_aa.f zdrvsy_aa_2stage.f + zdrvsp.f zdrvsy_rook.f zdrvsy_rk.f + zdrvsy_aa.f zdrvsy_aa_2stage.f zerrgt.f zerrlq.f zerrls.f zerrps.f zerrql.f zerrqp.f zerrqr.f zerrrq.f zerrtr.f zerrtz.f diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 6072d0d42..2f4686e7a 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -45,7 +45,7 @@ DZLNTST = dlaord.o SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ - schkpt.o schkq3.o schkqp3rk.o schkql.o schkqr.o schkrq.o \ + schkpt.o schkq3.o schkqp3rk.o schkcxx.o schkql.o schkqr.o schkrq.o \ schksp.o schksy.o schksy_rook.o schksy_rk.o \ schksy_aa.o schksy_aa_2stage.o schktb.o schktp.o schktr.o \ schktz.o \ @@ -74,7 +74,8 @@ SLINTST = schkaa.o \ sgennd.o sqrt04.o sqrt05.o schkqrt.o serrqrt.o schkqrtp.o serrqrtp.o \ schklqt.o schklqtp.o schktsqr.o \ serrlqt.o serrlqtp.o serrtsqr.o stsqr01.o slqt04.o slqt05.o \ - schkorhr_col.o serrorhr_col.o sorhr_col01.o sorhr_col02.o + schkorhr_col.o serrorhr_col.o sorhr_col01.o sorhr_col02.o \ + serrcxx.o ifdef USEXBLAS SLINTST += sdrvgbx.o sdrvgex.o sdrvsyx.o sdrvpox.o \ diff --git a/TESTING/LIN/schkaa.F b/TESTING/LIN/schkaa.F index ad6ea8776..75b9602cd 100644 --- a/TESTING/LIN/schkaa.F +++ b/TESTING/LIN/schkaa.F @@ -63,7 +63,8 @@ *> SLQ 8 List types on next line if 0 < NTYPES < 8 *> SQL 8 List types on next line if 0 < NTYPES < 8 *> SQP 6 List types on next line if 0 < NTYPES < 6 -*> DQK 19 List types on next line if 0 < NTYPES < 19 +*> SQK 19 List types on next line if 0 < NTYPES < 19 +*> SCX 19 List types on next line if 0 < NTYPES < 19 *> STZ 3 List types on next line if 0 < NTYPES < 3 *> SLS 6 List types on next line if 0 < NTYPES < 6 *> SEQ @@ -144,13 +145,14 @@ PROGRAM SCHKAA * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) - INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ), + INTEGER MVAL( MAXIN ), $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus + INTEGER, DIMENSION(:), ALLOCATABLE :: IWORK REAL, DIMENSION(:), ALLOCATABLE :: RWORK, S REAL, DIMENSION(:), ALLOCATABLE :: E REAL, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK @@ -161,15 +163,16 @@ PROGRAM SCHKAA EXTERNAL LSAME, LSAMEN, SECOND, SLAMCH * .. * .. External Subroutines .. - EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ, - $ SCHKORHR_COL, SCHKPB, SCHKPO, SCHKPS, SCHKPP, - $ SCHKPT, SCHKQ3, SCHKQP3RK, SCHKQL, SCHKQR, - $ SCHKRQ, SCHKSP, SCHKSY, SCHKSY_ROOK, SCHKSY_RK, - $ SCHKSY_AA, SCHKTB, SCHKTP, SCHKTR, SCHKTZ, - $ SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB, SDRVPO, - $ SDRVPP, SDRVPT, SDRVSP, SDRVSY, SDRVSY_ROOK, - $ SDRVSY_RK, SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, - $ SCHKQRTP, SCHKLQT, SCHKTSQR + EXTERNAL ALAREQ, SCHKCXX, SCHKEQ, SCHKGB, SCHKGE, + $ SCHKGT, SCHKLQ, SCHKORHR_COL, SCHKPB, SCHKPO, + $ SCHKPS, SCHKPP, SCHKPT, SCHKQ3, SCHKQP3RK, + $ SCHKQL, SCHKQR, SCHKRQ, SCHKSP, SCHKSY, + $ SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA, SCHKTB, + $ SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, SDRVGT, + $ SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, SDRVSP, + $ SDRVSY, SDRVSY_ROOK, SDRVSY_RK, SDRVSY_AA, + $ ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP, SCHKLQT, + $ SCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -189,7 +192,9 @@ PROGRAM SCHKAA * .. * .. Allocate memory dynamically .. * - ALLOCATE ( A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus ) + ALLOCATE ( IWORK( 34*NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( A( ( KDMAX+1 )*NMAX, 8 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" @@ -200,7 +205,7 @@ PROGRAM SCHKAA ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * .. * .. Executable Statements .. * @@ -942,6 +947,30 @@ PROGRAM SCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* CX: CX decomposition +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), A( 1, 4 ), + $ A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), A( 1, 8 ), + $ B( 1, 1 ), B( 1, 2 ), + $ IWORK( 1 ), IWORK( 1+2*NMAX ), + $ IWORK(1+4*NMAX), IWORK(1+6*NMAX), + $ IWORK(1+8*NMAX), IWORK(1+10*NMAX), + $ IWORK(1+12*NMAX), IWORK(1+14*NMAX), + $ WORK, IWORK(1+16*NMAX), NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN * diff --git a/TESTING/LIN/schkcxx.f b/TESTING/LIN/schkcxx.f new file mode 100644 index 000000000..03b739919 --- /dev/null +++ b/TESTING/LIN/schkcxx.f @@ -0,0 +1,933 @@ +*> \brief \b SCHKCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, +* $ NNB, NBVAL, NXVAL, THRESH, TSTERR, +* $ A, COPYA, +* $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, +* $ DESEL_ROWS, COPY_DESEL_ROWS, +* $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, +* $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, +* $ WORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), +* $ NXVAL( * ), +* $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), +* $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), +* $ IPIV( * ), COPY_IPIV( * ), +* $ JPIV( * ), COPY_JPIV( * ) +* REAL A( * ), COPYA( * ), C( * ), COPYC( * ), +* $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), +* $ S( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKCXX tests SGECXX. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is 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. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYC +*> \verbatim +*> COPYC is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYQRC +*> \verbatim +*> COPYQRC is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYX +*> \verbatim +*> COPYX is REAL array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is REAL array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_DESEL_ROWS +*> \verbatim +*> COPY_DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_SEL_DESEL_COLS +*> \verbatim +*> COPY_SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_IPIV +*> \verbatim +*> COPY_IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_JPIV +*> \verbatim +*> COPY_JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, +*> dimension is maximum of the following: +*> (1) ((MMAX + 6) * max(MMAX,NMAX)) +*> for matrix generation and test routines +*> (2) max( 2*NMAX + NBMAX*( NMAX + 1 ), +*> NMAX*min(NBMAX_ORMQR,NBMAX) + (NBMAX_ORMQR+1)*NBMAX_ORMQR ) ) +*> where NBMAX_ORMQR=64 is harwiredi in DORMQR. +*> for SGECXX optimal WORK size. +*> +*> Assuming NBMAX = NMAX, the expressions become: +*> (1) 3*NMAX + NMAX*NMAX +*> (2) NMAX * min(64,NMAX) + 4160 +*> +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> for SGECXX optimal IWORK size. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A, COPYA, + $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, + $ DESEL_ROWS, COPY_DESEL_ROWS, + $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, + $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, + $ WORK, IWORK, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NXVAL( * ), + $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), + $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), + $ IPIV( * ), COPY_IPIV( * ), + $ JPIV( * ), COPY_JPIV( * ) + REAL A( * ), COPYA( * ), C( * ), COPYC( * ), + $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), + $ S( * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + REAL ONE, ZERO, BIGNUM + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, + $ BIGNUM = 1.0E+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE, FACT, USESD + CHARACTER*3 PATH + INTEGER I, IM, IMAT, IN, INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INFO, J, J_INC, J_FIRST_NZ, + $ JB_ZERO, K, KL, KMAXFREE, KU, LDA, LDC, + $ LDQRC, LDX, LIWORK,LWORK, LWKTST, + $ M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NBMAX_ORMQR, NB_ZERO, NERRS, NFAIL, + $ NB_GEN, NRUN, NX, T + REAL ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK, FNRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLAMCH, SQPT01, SQRT11, SQRT12 + EXTERNAL SLAMCH, SQPT01, SQRT11, SQRT12 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRCXX, + $ SGECXX, SLACPY, SLAORD, SLASET, SLATB4, + $ SLATMS, SSWAP, ICOPY, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'CX' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = SLAMCH( 'Epsilon' ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRCXX( PATH, NOUT ) +* + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) + LDC = MAX( 1, M ) + LDQRC = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LDX = MAX( 1, N ) +* +* Set work for testing routines. +* + LWKTST = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* + DO IMAT = 1, NTYPES +* +* Do for each value of IMAT in NTYPES. +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE +* +* The type of distribution used to generate the random +* eigen-/singular values: +* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 ) +* +* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE +* 1. Zero matrix CNDNUM = Inf 0 N/A +* 2. Random, Diagonal CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1 column, +* zero block size N - MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 11. Random, Half of MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1 column, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) 1 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS 1 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, one small singular value S(N)=1/CNDNUM CNDNUM = BADC2 = 0.1/EPS 1 2 ( one small singular value, S(N)=1/CNDNUM ) +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN 3 ( geometric distribution of singular values ) +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* +* Generate matrices. +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1 (Zero matrix). +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in the test. +* We set the array S explicitly here, since we are not using +* SLATMS (which sets the array S) to generate zero matrix. +* + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( ( IMAT.EQ.2 .OR. IMAT.EQ.3 .OR. IMAT.EQ.4 ) + $ .OR. ( IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrix 2 (Diagonal), +* Matrix 3 (Upper triangular), +* Matrix 4 (Lower triangular), +* Matrices 14-19 (Various rectangular random matrices +* without zero columns). +* +* Set up parameters with SLATB4 and generate a test +* matrix with SLATMS. +* + CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' + CALL SLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in +* the test. Unordered singular values are returned by +* SLATMS in S. We need to order singular values in S. +* + CALL SLAORD ( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Matrices 5-13 (Rectangular random matrices that +* contain zero columns). Only for matrices MINMN >= 2. +* +* JB_ZERO is the column index of ZERO block. +* NB_ZERO is the column block size of ZERO block. +* NB_GEN is the column blcok size of the +* generated block. +* J_INC in the non_zero column index increment +* to generate matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column to generate matrix 12 and 13. +* + IF( IMAT.EQ.5 ) THEN +* +* Matrix 5. First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Matrix 6. Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Matrix 7. Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* MAtrix 8. Middle column in MINMN is zero. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.9 ) THEN +* +* Matrix 9. First half of MINMN columns is zero, zero block size MINMN/2. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Matrix 10. Last columns are zero columns, +* starting from (MINMN / 2 + 1) column,zero block size N - MINMN/2 +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Matrix 11. Half of the columns in the middle of first MINMN +* columns is zero, starting from MINMN/2 - (MINMN/2)/2 + 1 column, +* zero block size MINMN/2. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* Matrix 12. Odd-numbered columns are zero, +* + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 +* + ELSE IF( IMAT.EQ.13 ) THEN +* +* Matrix 13. Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL SLASET( 'Full', M, NB_ZERO, ZERO, ZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL SLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL SLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL SSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL SSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN ), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing absolute value order and +* add trailing zeros that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) + CALL SLAORD ( 'Decreasing', MINMNB_GEN, S, 1 ) +* + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF( MINMN.LT.2 .AND. ( IMAT.GE.5 .AND. IMAT.LE.13 ) ) +* skip this size for this matrix type. +* + CYCLE + END IF +* +* End generate COPYA matrix. +* +* Initialize COPYC matrix with zeros. +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYC, LDC ) +* +* Initialize COPYQRC matrix with zeros. +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYQRC, LDQRC ) +* +* Initialize COPYX matrix with zeros. +* + CALL SLASET( 'Full', MINMN, N, ZERO, ZERO, COPYX, LDX ) +* +* Initialize a copy array for pivot IPIV for SGECXX. +* + DO I = 1, M + COPY_IPIV( I ) = 0 + END DO +* +* Initialize a copy array for pivot JPIV for SGECXX. +* + DO J = 1, N + COPY_JPIV( J ) = 0 + END DO +* +* Initialize a copy array COPY_DESEL_ROWS for SGECXX. +* + DO I = 1, M + COPY_DESEL_ROWS( I ) = 0 + END DO +* +* Initialize a copy array COPY_SEL_DESEL_COLS for SGECXX. +* + DO J = 1, N + COPY_SEL_DESEL_COLS( J ) = 0 + END DO +* + DO INB = 1, NNB +* +* Do for each pair of values (NB,NX) in NBVAL and NXVAL. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + NX = NXVAL( INB ) + CALL XLAENV( 3, NX ) +* +* We do MIN(M,N)+1 because we need a test for KMAX > N, +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) +* + DO KMAXFREE = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYC into C( 1:M,1:N ). +* Get a working copy of COPYQRC into QRC( 1:M,1:N ). +* Get a working copy of COPYX into X( 1:N,1:N ). +* Get a working copy of COPY_IPIV(1:M) into IPIV(1:M). +* Get a working copy of COPY_JPIV(1:N) into JPIV(1:N). +* Get a working copy of COPY_DESEL_ROWS(1:M) into DESEL_ROWS(1:M). +* Get a working copy of COPY_SEL_DESEL_COLS(1:N) into SEL_DESEL_COLS(1:N). +* + CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL SLACPY( 'All', M, N, COPYC, LDC, C, LDC ) + CALL SLACPY( 'All', M, N, COPYQRC, LDQRC, QRC, LDQRC ) + CALL SLACPY( 'All', MINMN, N, COPYX, LDX, X, LDX ) + CALL ICOPY( M, COPY_IPIV, 1, IPIV, 1 ) + CALL ICOPY( N, COPY_JPIV, 1, JPIV, 1 ) + CALL ICOPY( M, COPY_DESEL_ROWS, 1, DESEL_ROWS, 1 ) + CALL ICOPY( N, COPY_SEL_DESEL_COLS, 1, + $ SEL_DESEL_COLS, 1 ) +* +* Set test ratios for all tests to zero. +* + DO I = 1, NTESTS + RESULT( I ) = ZERO + END DO +* +* We are not testing with ABSTOL and RELTOL stopping criteria. +* Disable them. +* + FACT = 'C' + USESD = 'N' + ABSTOL = -ONE + RELTOL = -ONE +* +* Compute the QR factorization with pivoting of A +* +* NBMAX_ORMQR is hardwired in DORMQR as NBMAX = 64. +* + NBMAX_ORMQR = 64 + LWORK = MAX( 1, + $ 2*N + NB*( N + 1 ), + $ N*min(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) +* + LIWORK = MAX( 1, 2*N ) +* +* Compute SGECXX factorization of A. +* + SRNAMT = 'SGECXX' + CALL SGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, IWORK, LIWORK, + $ INFO ) +* +* Check an error code from SGECXX. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'SGECXX', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute test 1: +* +* This test in only for the full rank factorization of +* the matrix A. +* +* Array S(1:min(M,N)) contains svd(A) the sigular values +* of the original matrix A in decreasing absolute value +* order. The test computes svd(R), the vector sigular +* values of the upper trapezoid of A(1:M,1:N) that +* contains the factor R, in decreasing order. The test +* returns the ratio: +* +* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) +* + IF( K.EQ.MINMN ) THEN +* + RESULT( 1 ) = SQRT12( M, N, A, LDA, S, WORK, + $ LWKTST ) +* + NRUN = NRUN + 1 +* +* End test 1 +* + END IF +* +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = SQPT01( M, N, K, COPYA, A, LDA, TAU, + $ JPIV, WORK, LWKTST ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = SQRT11( M, K, A, LDA, TAU, WORK, + $ LWKTST ) +* + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater then 1. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+100 if abs(R(j+1,j+1)) > abs(R(j,j)), +* j=1:K-1 +* + IF( MIN(K, MINMN).GT.1 ) THEN +* + DO J = 1, K-1, 1 + + DTEMP = (( ABS( A( (J-1)*LDA+J ) ) - + $ ABS( A( (J)*LDA+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* =============== +* Compute test 5: +* =============== +* This test is only for the factorizations with the +* rank greater than 0. +* For J=1:K, the J-th column of C should be elementwise +* equal (including NaN and Inf) +* to the JPIV(J)-th column of A. +* + RESULT( 5 ) = ZERO +* Disable for now, incomplete test. + IF(.FALSE.) THEN + DO J = 1, K, 1 + DO I = 1, M, 1 + IF( .NOT. (C( (J-1)*LDC+I ) + $ .EQ. A( (JPIV( J )-1)*LDA+I ) ) ) THEN + RESULT( 5 ) = BIGNUM + END IF + END DO + END DO + END IF +* +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'SGECXX', M, N, + $ FACT, USESD, KMAXFREE, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO +* +* END DO KMAX = 1, MIN(M,N)+1 +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for IN = 1, NN +* + END DO +* +* END DO for IM = 1, NM +* + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, + $ ', FACT = ''', A1, ''', USESD = ''', A1, + $ ''', KMAXFREE =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of SCHKCXX +* + END diff --git a/TESTING/LIN/serrcxx.f b/TESTING/LIN/serrcxx.f new file mode 100644 index 000000000..495424b36 --- /dev/null +++ b/TESTING/LIN/serrcxx.f @@ -0,0 +1,1691 @@ +*> \brief \b SERRCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRCXX( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SERRCXX tests the error exits for SERRCXX that does +*> CX decomposition. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SERRCXX( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER(LEN=3) PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 5 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, K + REAL MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ NAN, ONE, ZERO +* .. +* .. Local Arrays .. + INTEGER DESEL_ROWS( NMAX ), SEL_DESEL_COLS( NMAX ), + $ IPIV( NMAX ), JPIV( NMAX ), IW( NMAX ) + REAL A( NMAX, NMAX ), C( NMAX, NMAX ), + $ QRC( NMAX, NMAX ), X( NMAX, NMAX ), + $ TAU( NMAX ), W( NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SGECXX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER(LEN=32) SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, SQRT +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DESEL_ROWS( J ) = 0 + SEL_DESEL_COLS( J ) = 0 + IPIV( J ) = 0 + JPIV( J ) = 0 + TAU( J ) = 1.E+0 / REAL( J ) + W( J ) = 1.E+0 / REAL( J ) + IW( J ) = -J + DO I = 1, NMAX + A( I, J ) = 1.E+0 / REAL( I+J ) + C( I, J ) = 1.E+0 / REAL( I+J ) + QRC( I, J ) = 1.E+0 / REAL( I+J ) + X( I, J ) = 1.E+0 / REAL( I+J ) + END DO + END DO +* +* Create a NaN +* + ONE = 1.0E+0 + ZERO = 0.0E+0 + NAN = SQRT( -ONE ) +* + OK = .TRUE. +* +* Error exits for CX decomposition +* +* SGECXX +* + SRNAMT = 'SGECXX' +* +* ====================== +* Test parameter FACT +* ====================== + INFOT = 1 + CALL SGECXX( '/', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter USESD +* ====================== +* + INFOT = 2 +* + CALL SGECXX( 'P', '/', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter M +* ====================== +* + INFOT = 3 +* + CALL SGECXX( 'P', 'A', -1, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter N +* ======================= +* + INFOT = 4 +* + CALL SGECXX( 'P', 'A', 0, -1, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter SEL_DESEL_COLS +* ======================= +* +* NSEL (the number of preselected columns in SEL_DESEL_COLS +* (element value = 1)) cannot be greater then MSUB. +* + INFOT = 6 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + CALL SGECXX( 'P', 'A', 1, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter KMAXFREE +* ======================= +* + INFOT = 7 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ -1, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter ABSTOL +* ======================= +* + INFOT = 8 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, NAN, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) + +* +* ======================= +* Test parameter RELTOL +* ======================= +* + INFOT = 9 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, NAN, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDA +* ======================= +* + INFOT = 11 +* +* min(M,N) = 0 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 0, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + CALL SGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDC +* ======================= +* + INFOT = 20 +* +* min(M,N) = 0 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 1, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL SGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL SGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL SGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDQRC +* ======================= +* +* QRC is used only when the matrix X is returned. +* + INFOT = 22 +* +* min(M,N) = 0 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 0, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL SGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL SGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL SGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 1, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDX +* ======================= +* + INFOT = 24 +* +* min(M,N) = 0 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL SGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL SGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL SGECXX( 'X', 'A', 4, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 3, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LWORK +* ======================= +* + INFOT = 26 +* +* Test group 1. LWORK test for MIN(M,N) = 0, then LWKMIN => 1 +* ========================================== +* + CALL SGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 0, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LWORK tests for USESD = 'N'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'C', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'X', LWKMIN = MAX(1, 3*N - 1, MINMN + N) = MAX(1, 3*N - 1) +* + CALL SGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + CALL SGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + CALL SGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) + + + +* +* Test group 3. LWORK tests for USESD = 'R'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'C', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'X', LWKMIN = MAX(1, 3*N - 1, MINMN + N) = MAX(1, 3*N - 1) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1), min(M,N)+N ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a1). Set min(1,MINMNFREE == 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'C', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b1). min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'C', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (min(M,N)+N) = 8 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 7, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 5, +* M_sub = M = 2, N_sub = N = 5, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 0, 3 ) = 0, +* (3*N_free - 1) = 8 +* (min(M,N)+N) = 2 + 5 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'C', 2, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 2, W, 6, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 3+4 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 6, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1), min(M,N)+N ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 + + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b1). min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (min(M,N)+N) = 8 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 7, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 5, +* M_sub = 2, N_sub = N = 5, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 0, 3 ) = 0, +* (3*N_free - 1) = 8 +* (min(M,N)+N) = 2 + 5 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 6, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 5, N = 4, +* M_sub = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 3+4 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 6, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LIWORK +* ======================= +* + INFOT = 28 +* +* Test group 1. LIWORK test for MIN(M,N) = 0, then LWKMIN => 1 +* ========================================== +* + CALL SGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 0, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LIWORK tests for USESD = 'N' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + CALL SGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 2, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) + CALL SGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 7, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) + CALL SGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 7, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 3. LIWORK tests for USESD = 'R' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 7, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 7, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LIWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, 2*N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, 2*N ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b1). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c2). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5` +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LIWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRCXX +* + END diff --git a/TESTING/LIN/slatb4.f b/TESTING/LIN/slatb4.f index 8156bb998..69a33c46b 100644 --- a/TESTING/LIN/slatb4.f +++ b/TESTING/LIN/slatb4.f @@ -236,8 +236,8 @@ SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, * TYPE = 'N' * -* Set DIST, the type of distribution for the random -* number generator. 'S' is +* Set DIST, the type of distribution for the randomom +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * DIST = 'S' * @@ -321,6 +321,110 @@ SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE IF( IMAT.EQ.19 ) THEN * * 19. Random, scaled near overflow +* + CNDNUM = TWO + ANORM = LARGE + MODE = 3 +* + END IF +* + END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* xCX: CX factorization +* Set parameters to generate a general +* M x N matrix. +* +* Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. +* + TYPE = 'N' +* +* Set DIST, the type of distribution for the random +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) +* + DIST = 'S' +* +* Set the lower bandwidth KL and the upper bandwidth KU. +* + IF( IMAT.EQ.2 ) THEN +* +* 2. Random, Diagonal, CNDNUM = 2 +* + KL = 0 + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.3 ) THEN +* +* 3. Random, Upper triangular, CNDNUM = 2 +* + KL = 0 + KU = MAX( N-1, 0 ) + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.4 ) THEN +* +* 4. Random, Lower triangular, CNDNUM = 2 +* + KL = MAX( M-1, 0 ) + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE +* +* 5.-19. Rectangular matrix +* + KL = MAX( M-1, 0 ) + KU = MAX( N-1, 0 ) +* + IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN +* +* 5.-14. Random, CNDNUM = 2. +* + CNDNUM = TWO + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.15 ) THEN +* +* 15. Random, CNDNUM = sqrt(0.1/EPS) +* + CNDNUM = BADC1 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.16 ) THEN +* +* 16. Random, CNDNUM = 0.1/EPS +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.17 ) THEN +* +* 17. Random, CNDNUM = 0.1/EPS, +* one small singular value S(N)=1/CNDNUM +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 2 +* + ELSE IF( IMAT.EQ.18 ) THEN +* +* 18. Random, scaled near underflow +* + CNDNUM = TWO + ANORM = SMALL + MODE = 3 +* + ELSE IF( IMAT.EQ.19 ) THEN +* +* 19. Random, scaled near overflow * CNDNUM = TWO ANORM = LARGE diff --git a/TESTING/stest.in b/TESTING/stest.in index 7faa8b7a1..abfd639fd 100644 --- a/TESTING/stest.in +++ b/TESTING/stest.in @@ -37,6 +37,7 @@ SLQ 8 List types on next line if 0 < NTYPES < 8 SQL 8 List types on next line if 0 < NTYPES < 8 SQP 6 List types on next line if 0 < NTYPES < 6 SQK 19 List types on next line if 0 < NTYPES < 19 +SCX 19 LIst types on next line if 0 < NTYPES < 19 STZ 3 List types on next line if 0 < NTYPES < 3 SLS 6 List types on next line if 0 < NTYPES < 6 SEQ From 0e096623f202b6cc0dbc9c562102080500524a0e Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 7 May 2026 10:11:52 -0700 Subject: [PATCH 57/63] SRC/dgecxx.f and sgecxx.f changed formattting in description of LWORK and LIWORK modified: SRC/dgecxx.f modified: SRC/sgecxx.f --- SRC/dgecxx.f | 24 ++++++++++++------------ SRC/sgecxx.f | 24 ++++++++++++------------ 2 files changed, 24 insertions(+), 24 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index e5ab5f4b5..e0ad45aa6 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -763,17 +763,17 @@ *> The dimension of the array WORK. *> *> Minimal LWORK workspace general requirement. -*> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all values -*> of FACT and USESD flags. +*> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all +*> values of FACT and USESD flags. *> *> For good performance, LWORK should generally be larger, and *> the user should query the routine for the optimal LWORK. *> -*> If LWORK = -1 or LIWORK =-1 then a workspace query is assumed. -*> The routine only calculates the optimal size of the WORK and -*> IWORK arrays, returns these values as the first entry of -*> the WORK and IWORK arrays respectively, and no error message -*> related to LWORK is issued by XERBLA. +*> If LWORK = -1 or LIWORK =-1 then a workspace query is +*> assumed. The routine only calculates the optimal size of +*> the WORK and IWORK arrays, returns these values as the +*> first entry of the WORK and IWORK arrays respectively, and +*> no error message related to LWORK is issued by XERBLA. *> *> Exact minimal workspace requirements. *> For USESD = 'N' or 'R' and for all FACT: @@ -837,11 +837,11 @@ *> The optimal LIWORK is the same as the minimal LIWORK. *> The user can still query the routine for the optimal LIWORK. *> -*> If LIWORK = -1 or LWORK =-1 then a workspace query is assumed. -*> The routine only calculates the optimal size of the WORK and -*> IWORK arrays, returns these values as the first entry of -*> the WORK and IWORK arrays respectively, and no error message -*> related to LIWORK is issued by XERBLA. +*> If LWORK = -1 or LIWORK =-1 then a workspace query is +*> assumed. The routine only calculates the optimal size of +*> the WORK and IWORK arrays, returns these values as the first +*> entry of the WORK and IWORK arrays respectively, and no +*> error message related to LIWORK is issued by XERBLA. *> *> Exact minimal workspace requirements. *> For USESD = 'N' or 'R': diff --git a/SRC/sgecxx.f b/SRC/sgecxx.f index e95e451e4..2eb3b4474 100644 --- a/SRC/sgecxx.f +++ b/SRC/sgecxx.f @@ -763,17 +763,17 @@ *> The dimension of the array WORK. *> *> Minimal LWORK workspace general requirement. -*> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all values -*> of FACT and USESD flags. +*> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all +*> values of FACT and USESD flags. *> *> For good performance, LWORK should generally be larger, and *> the user should query the routine for the optimal LWORK. *> -*> If LWORK = -1 or LIWORK =-1 then a workspace query is assumed. -*> The routine only calculates the optimal size of the WORK and -*> IWORK arrays, returns these values as the first entry of -*> the WORK and IWORK arrays respectively, and no error message -*> related to LWORK is issued by XERBLA. +*> If LWORK = -1 or LIWORK =-1 then a workspace query is +*> assumed. The routine only calculates the optimal size of +*> the WORK and IWORK arrays, returns these values as the +*> first entry of the WORK and IWORK arrays respectively, and +*> no error message related to LWORK is issued by XERBLA. *> *> Exact minimal workspace requirements. *> For USESD = 'N' or 'R' and for all FACT: @@ -837,11 +837,11 @@ *> The optimal LIWORK is the same as the minimal LIWORK. *> The user can still query the routine for the optimal LIWORK. *> -*> If LIWORK = -1 or LWORK =-1 then a workspace query is assumed. -*> The routine only calculates the optimal size of the WORK and -*> IWORK arrays, returns these values as the first entry of -*> the WORK and IWORK arrays respectively, and no error message -*> related to LIWORK is issued by XERBLA. +*> If LWORK = -1 or LIWORK =-1 then a workspace query is +*> assumed. The routine only calculates the optimal size of +*> the WORK and IWORK arrays, returns these values as the first +*> entry of the WORK and IWORK arrays respectively, and no +*> error message related to LIWORK is issued by XERBLA. *> *> Exact minimal workspace requirements. *> For USESD = 'N' or 'R': From d5f8b888371122a314b5421ddb009dd99e8c2663 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 7 May 2026 11:09:26 -0700 Subject: [PATCH 58/63] SRC/dgecxx.f and sgecxx.f changed MAX to max in WORK and IWORK descript. modified: SRC/dgecxx.f modified: SRC/sgecxx.f --- SRC/dgecxx.f | 4 ++-- SRC/sgecxx.f | 18 +++++++++--------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index e0ad45aa6..78d18d400 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -752,7 +752,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)). +*> WORK is DOUBLE PRECISION array, dimension (max(1,LWORK)). *> *> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. *> \endverbatim @@ -820,7 +820,7 @@ *> *> \param[out] IWORK *> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)). +*> IWORK is INTEGER array, dimension (max(1,LIWORK)). *> *> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim diff --git a/SRC/sgecxx.f b/SRC/sgecxx.f index 2eb3b4474..5dd920c07 100644 --- a/SRC/sgecxx.f +++ b/SRC/sgecxx.f @@ -752,7 +752,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is REAL array, dimension (MAX(1,LWORK)). +*> WORK is REAL array, dimension (max(1,LWORK)). *> *> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. *> \endverbatim @@ -763,17 +763,17 @@ *> The dimension of the array WORK. *> *> Minimal LWORK workspace general requirement. -*> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all -*> values of FACT and USESD flags. +*> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all values +*> of FACT and USESD flags. *> *> For good performance, LWORK should generally be larger, and *> the user should query the routine for the optimal LWORK. *> -*> If LWORK = -1 or LIWORK =-1 then a workspace query is -*> assumed. The routine only calculates the optimal size of -*> the WORK and IWORK arrays, returns these values as the -*> first entry of the WORK and IWORK arrays respectively, and -*> no error message related to LWORK is issued by XERBLA. +*> If LWORK = -1 or LIWORK =-1 then a workspace query is assumed. +*> The routine only calculates the optimal size of the WORK and +*> IWORK arrays, returns these values as the first entry of +*> the WORK and IWORK arrays respectively, and no error message +*> related to LWORK is issued by XERBLA. *> *> Exact minimal workspace requirements. *> For USESD = 'N' or 'R' and for all FACT: @@ -820,7 +820,7 @@ *> *> \param[out] IWORK *> \verbatim -*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)). +*> IWORK is INTEGER array, dimension (max(1,LIWORK)). *> *> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. *> \endverbatim From 05fc5d31f22844d4217ffcb3b31faeab2b0d23ae Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 7 May 2026 13:42:26 -0700 Subject: [PATCH 59/63] SRC/dgecxx.f and sgecxx.f edited comments in workspace calculation modified: SRC/dgecxx.f modified: SRC/sgecxx.f --- SRC/dgecxx.f | 30 +++++++++++++++--------------- SRC/sgecxx.f | 32 ++++++++++++++++---------------- 2 files changed, 31 insertions(+), 31 deletions(-) diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f index 78d18d400..5d3af6c95 100644 --- a/SRC/dgecxx.f +++ b/SRC/dgecxx.f @@ -1064,24 +1064,22 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, LIWKOPT = 1 ELSE * -* (Real_wk_part_a) Real minimum workspace computation. +* (Real_wk_part_1) Real minimum and optimal workspace +* computation. * LWKMIN = MAX(1, NSUB) for column 2-norm computation * LWKMIN = MAX( 1, NSUB ) + LWKOPT = LWKMIN * * (Int_wk_part_1) Integer minimum workspace computation. * LIWKMIN = 1 * -* Optimal workspace for column 2-norm computation. -* - LWKOPT = LWKMIN -* * Call of DGEQRF. * IF( NSEL.GT.0 ) THEN * -* (Real_wk_part_b) Real minimum workspace computation. +* (Real_wk_part_2) Real minimum workspace computation. * LWKMIN = MAX(1, NSEL) for the call of DGEQRF. * We can skip counting this workspace as * LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. @@ -1096,12 +1094,12 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * IF( NFREE.GT.0 ) THEN * -* (Real_wk_part_c) Real minimum workspace computation. +* (Real_wk_part_3) Real minimum workspace computation. * NOTE: minimum workspace requirement for DORMQR -* LWKMIN = MAX(1, NFREE) is smaller than -* LWKMIN = 3*NFREE-1 for DGEQP3RK and it is -* smaller than NSUB. We can skip counting this -* workspace as LWKMIN = MAX( LWKMIN, NFREE ). +* LWKMIN = MAX(1, NFREE) is smaller than NSUB +* and it is smaller than LWKMIN = 3*NFREE-1 for +* DGEQP3RK. We can skip counting this workspace as +* as LWKMIN = MAX( LWKMIN, NFREE ). * * Query for optimal workspace size for DORMQR. * @@ -1115,10 +1113,9 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, * * Call of DGEQP3RK. * - IF ( MINMNFREE.NE.0 ) THEN * -* (Real_wk_part_d) Real minimum workspace computation. +* (Real_wk_part_4) Real minimum workspace computation. * LWKMIN = MAX(1, 3*NFREE-1) for the call of DGEQP3RK. * LWKMIN = MAX( LWKMIN, 3*NFREE - 1 ) @@ -1150,18 +1147,21 @@ SUBROUTINE DGECXX( FACT, USESD, M, N, IF( RETURNC ) THEN * * Integer minimum workspace computation. -* (Int_wk_part_3) LIWKMIN = 2*N for applying the +* (Int_wk_part_4) LIWKMIN = 2*N for applying the * interchanges for the columns in the matrix C. * LIWKMIN = MAX( LIWKMIN, 2*N ) END IF +* +* Integer optimal workspace computation. +* LIWKOPT = LIWKMIN * * Call of DGELS. * IF( RETURNX ) THEN * -* (Real_wk_part_d) Real minimum workspace computation. +* (Real_wk_part_5) Real minimum workspace computation. * LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = * = max( 1, MINMN + N ) for the call of DGELS. * diff --git a/SRC/sgecxx.f b/SRC/sgecxx.f index 5dd920c07..d50cf78ef 100644 --- a/SRC/sgecxx.f +++ b/SRC/sgecxx.f @@ -1064,24 +1064,22 @@ SUBROUTINE SGECXX( FACT, USESD, M, N, LIWKOPT = 1 ELSE * -* (Real_wk_part_a) Real minimum workspace computation. +* (Real_wk_part_1) Real minimum and optimal workspace +* computation. * LWKMIN = MAX(1, NSUB) for column 2-norm computation * LWKMIN = MAX( 1, NSUB ) + LWKOPT = LWKMIN * * (Int_wk_part_1) Integer minimum workspace computation. * LIWKMIN = 1 * -* Optimal workspace for column 2-norm computation. -* - LWKOPT = LWKMIN -* * Call of SGEQRF. * IF( NSEL.GT.0 ) THEN * -* (Real_wk_part_b) Real minimum workspace computation. +* (Real_wk_part_2) Real minimum workspace computation. * LWKMIN = MAX(1, NSEL) for the call of SGEQRF. * We can skip counting this workspace as * LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. @@ -1096,12 +1094,12 @@ SUBROUTINE SGECXX( FACT, USESD, M, N, * IF( NFREE.GT.0 ) THEN * -* (Real_wk_part_c) Real minimum workspace computation. -* NOTE: minimum workspace requirement for SORMQR -* LWKMIN = MAX(1, NFREE) is smaller than -* LWKMIN = 3*NFREE-1 for SGEQP3RK and it is -* smaller than NSUB. We can skip counting this -* workspace as LWKMIN = MAX( LWKMIN, NFREE ). +* (Real_wk_part_3) Real minimum workspace computation. +* NOTE: minimum workspace requirement for DORMQR +* LWKMIN = MAX(1, NFREE) is smaller than NSUB +* and it is smaller than LWKMIN = 3*NFREE-1 for +* DGEQP3RK. We can skip counting this workspace as +* as LWKMIN = MAX( LWKMIN, NFREE ).). * * Query for optimal workspace size for SORMQR. * @@ -1115,10 +1113,9 @@ SUBROUTINE SGECXX( FACT, USESD, M, N, * * Call of SGEQP3RK. * - IF ( MINMNFREE.NE.0 ) THEN * -* (Real_wk_part_d) Real minimum workspace computation. +* (Real_wk_part_4) Real minimum workspace computation. * LWKMIN = MAX(1, 3*NFREE-1) for the call of SGEQP3RK. * LWKMIN = MAX( LWKMIN, 3*NFREE - 1 ) @@ -1150,18 +1147,21 @@ SUBROUTINE SGECXX( FACT, USESD, M, N, IF( RETURNC ) THEN * * Integer minimum workspace computation. -* (Int_wk_part_3) LIWKMIN = 2*N for applying the +* (Int_wk_part_4) LIWKMIN = 2*N for applying the * interchanges for the columns in the matrix C. * LIWKMIN = MAX( LIWKMIN, 2*N ) END IF +* +* Integer optimal workspace computation. +* LIWKOPT = LIWKMIN * * Call of SGELS. * IF( RETURNX ) THEN * -* (Real_wk_part_d) Real minimum workspace computation. +* (Real_wk_part_5) Real minimum workspace computation. * LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = * = max( 1, MINMN + N ) for the call of SGELS. * From b4a0548f9439aeeaddc9bf0efd2da7b55657a951 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Thu, 7 May 2026 14:48:47 -0700 Subject: [PATCH 60/63] SRC/zgecxx.f: added COMPLEX*16 code for CXX modified: SRC/CMakeLists.txt modified: SRC/Makefile modified: SRC/lapack_64.h new file: SRC/zgecxx.f --- SRC/CMakeLists.txt | 2 +- SRC/Makefile | 2 +- SRC/lapack_64.h | 1 + SRC/zgecxx.f | 1773 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 1776 insertions(+), 2 deletions(-) create mode 100644 SRC/zgecxx.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index 61931b3a4..6e35c84f0 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -380,7 +380,7 @@ set(ZLASRC zgecon.f zgeequ.f zgees.f zgeesx.f zgeev.f zgeevx.f zgehd2.f zgehrd.f zgelq2.f zgelqf.f zgels.f zgelst.f zgelsd.f zgelss.f zgelsy.f zgeql2.f zgeqlf.f - zgeqp3.f zgeqp3rk.f + zgeqp3.f zgeqp3rk.f zgecxx.f zgeqr2.f zgeqr2p.f zgeqrf.f zgeqrfp.f zgerfs.f zgerq2.f zgerqf.f zgesc2.f zgesdd.f zgesv.f zgesvd.f zgesvdx.f zgesvx.f zgesvj.f zgejsv.f zgsvj0.f zgsvj1.f diff --git a/SRC/Makefile b/SRC/Makefile index d698a03f8..34af2804c 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -413,7 +413,7 @@ ZLASRC = \ zgecon.o zgeequ.o zgees.o zgeesx.o zgeev.o zgeevx.o \ zgehd2.o zgehrd.o zgelq2.o zgelqf.o \ zgels.o zgelst.o zgelsd.o zgelss.o zgelsy.o zgeql2.o zgeqlf.o \ - zgeqp3.o zgeqp3rk.o \ + zgeqp3.o zgeqp3rk.o zgecxx.o \ zgeqr2.o zgeqr2p.o zgeqrf.o zgeqrfp.o zgerfs.o zgerq2.o zgerqf.o \ zgesc2.o zgesdd.o zgesv.o zgesvd.o zgesvdx.o \ zgesvj.o zgejsv.o zgsvj0.o zgsvj1.o \ diff --git a/SRC/lapack_64.h b/SRC/lapack_64.h index dc7cb701a..2d2801bb8 100644 --- a/SRC/lapack_64.h +++ b/SRC/lapack_64.h @@ -1797,6 +1797,7 @@ #define ZGEQLF ZGEQLF_64 #define ZGEQP3 ZGEQP3_64 #define ZGEQP3RK ZGEQP3RK_64 +#define ZGECXX ZGECXX_64 #define ZGEQPF ZGEQPF_64 #define ZGEQR ZGEQR_64 #define ZGEQR2 ZGEQR2_64 diff --git a/SRC/zgecxx.f b/SRC/zgecxx.f new file mode 100644 index 000000000..5bf13517e --- /dev/null +++ b/SRC/zgecxx.f @@ -0,0 +1,1773 @@ +*> \brief \b ZGECXX computes a CX factorization of a real M-by-N matrix A using a truncated (rank k) Householder QR factorization with column pivoting. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGECXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGECXX( FACT, USESD, M, N, +* $ DESEL_ROWS, SEL_DESEL_COLS, +* $ KMAXFREE, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, +* $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, +* $ X, LDX, WORK, LWORK, RWORK, LRWORK, +* $ IWORK, LIWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER FACT, USESD +* INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, +* $ LDX, LIWORK, LRWORK, LWORK, M, N +* DOUBLE PRECISION ABSTOL, FNRMK, MAXC2NRMK, +* $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), +* $ JPIV( * ), SEL_DESEL_COLS( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), +* $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGECXX computes a CX factorization of a real M-by-N matrix A using +*> a truncated rank-K Householder QR factorization with a column +*> pivoting algorithm, which is implemented in the ZGEQP3RK routine. +*> +*> A * P = C*X + A_resid, where +*> +*> C is an M-by-K matrix consisting of K columns selected +*> from the original matrix A, +*> +*> X is a K-by-N matrix that minimizes the Frobenius norm of the +*> residual matrix A_resid, X = pseudoinv(C) * A, +*> +*> P is an N-by-N permutation matrix chosen so that the first +*> K columns of A*P equal C, +*> +*> A_resid is an M-by-N residual matrix. +*> +*> The column selection for the matrix C has two stages. +*> +*> Column preselection stage 1 (optional). +*> ======================================= +*> +*> The user can select N_sel columns and deselect N_desel columns +*> of the matrix A that MUST be included and excluded respectively +*> from the matrix C a priori, before running the column selection +*> algorithm. This is controlled by flags in the array +*> SEL_DESEL_COLS. The deselected columns are permuted to the right +*> side of the matrix A and selected columns are permuted to the left +*> side of the matrix A. The details of the column permutation +*> (i.e. the column permutation matrix P) are stored in the +*> array JPIV. This feature can be used when the goal is to approximate +*> the deselected columns by linear combinations of K selected columns, +*> where the K columns MUST include the N_sel preselected columns. +*> +*> Column selection stage 2. +*> ========================= +*> +*> The routine runs a column selection algorithm that can +*> be controlled by three stopping criteria described below. +*> For column selection, the routine uses a truncated (rank-K) +*> Householder QR factorization with column pivoting algorithm using +*> the routine ZGEQP3RK. +*> +*> Optionally, before running the column selection +*> algorithm, the user can deselect M_desel rows of the matrix A that +*> should NOT be considered by the column selection algorithm (i.e. +*> during the factorization). This is controlled by flags in +*> the array DESEL_ROWS. The deselected rows are permuted to the +*> bottom of the matrix A. The details of the row permutation (i.e. the +*> row permutation matrix) are stored in the array IPIV. This feature +*> can be used when the goal is to use the deselected rows as test data, +*> and the selected rows as training data. +*> +*> This means that the column selection factorization algorithm is +*> effectively running on the submatrix A_sub = A(1:M_sub,1:N_sub) of +*> the matrix A after the permutations described above. Here M_sub is +*> the number of rows of the matrix A minus the number of deselected +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> of columns of the matrix A minus the number of deselected columns +*> N_desel, i.e. N_sub = N - N_desel. +*> +*> The reported column selection error metrics MAXC2NRMK, RELMAXC2NRMK +*> and FNRMK described below are computed using only A_sub. +*> +*> Column selection criteria. +*> ========================== +*> +*> The column selection criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) KMAXFREE: This input parameter specifies the maximum number of +*> columns to factorize in addition to the N_sel preselected +*> columns. The factorization rank is limited to N_sel + KMAXFREE. +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), this criterion +*> is not used. +*> +*> 2) ABSTOL: This input parameter specifies the absolute tolerance +*> for the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), where +*> A_sub(K) denotes the contents of the array +*> A_sub = A(1:M_sub, 1:N_sub) after K columns were factorized. +*> This means that the factorization stops if this norm is less +*> than or equal to ABSTOL. If ABSTOL < 0.0, this criterion is +*> not used. +*> +*> 3) RELTOL: This input parameter specifies the tolerance for +*> the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) divided +*> by the maximum column 2-norm of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub), where A_sub(K) denotes the contents +*> of the array A_sub after K columns were factorized. +*> This means that the factorization stops when the ratio of the +*> maximum column 2-norm of A_sub_resid(K) to the maximum column +*> 2-norm of A_sub is less than or equal to RELTOL. +*> If RELTOL < 0.0, this criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the entire submatrix A_sub is factorized. +*> +*> To perform a full-rank factorization of the matrix A_sub, use +*> selection criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) +*> and ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> If the user wishes to verify that the columns of the matrix C are +*> sufficiently linearly independent for their intended use, the user +*> can compute the condition number of its R factor by calling DTRCON +*> on the upper-triangular part of QRC(1:K,1:K) in the output +*> array QRC. +*> +*> How N_sel affects the column selection algorithm. +*> ================================================= +*> +*> As mentioned above, the N_sel preselected columns are permuted to the +*> left side of the matrix A, and will be included in the column +*> selection. Then the routine factorizes that block A(1:M_sub,1:N_sel), +*> and if any of the three stopping criteria is met immediately after +*> factoring the first N_sel columns the routine exits +*> (i.e. if the user does not want to select KMAXFREE > 0 extra columns, +*> or if the absolute or relative tolerance of the maximum column 2-norm +*> of the residual is satisfied). In this case, the number +*> of selected columns would be K = N_sel. Otherwise, the factorization +*> routine finds a new column to select with the maximum column 2-norm +*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and swaps that +*> column with the first column of A(1:M,N_sel+1:N_sub). Then the +*> routine checks if the stopping criteria are met in the next residual +*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. +*> +*> Computation of the matrix factors. +*> ================================== +*> +*> When the columns are selected for the factor C, and: +*> (a) If the flag FACT = 'P', the routine returns only the indices of +*> the selected columns from the original matrix A, which are +*> stored in the first K elements of the JPIV array. +*> (b) If the flag FACT = 'C', then in addition to (a), the routine +*> explicitly returns the matrix C in the array C. +*> (c) If the flag FACT = 'X', then in addition to (a) and (b), +*> the routine explicitly computes and returns the factor +*> X = pseudoinv(C) * A in the array X, and it also returns +*> the factor R alongside the Householder vectors +*> of the QR factorization of the matrix C in the array QRC. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> The flag specifies how the factors of a CX factorization +*> are returned. +*> +*> = 'P': the routine returns: +*> (1) only the column permutation matrix P in +*> the array JPIV. +*> (The first K elements of the array JPIV +*> contain indices of the columns that were +*> selected from the matrix A to form the +*> factor C.) +*> (fastest option, smallest memory space) +*> +*> = 'C': the routine returns: +*> (1) the column permutation matrix P +*> in the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (slower option, more memory space) +*> +*> = 'X': the routine returns: +*> (1) the column permutation matrix P in +*> the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (3) the K-by-N factor X explicitly in the array X. +*> (4) the K-by-K upper triangular factor R and +*> the Householder vectors of the QR factorization +*> of the factor C in the array QRC. +*> ( The factor R may be useful for checking +*> the factor C for singularity, in which case +*> R will have a zero on the diagonal, and +*> the factor X cannot be computed. ) +*> (slowest option, largest memory space) +*> \endverbatim +*> +*> \param[in] USESD +*> \verbatim +*> USESD is CHARACTER*1 +*> The flag specifies whether the row deselection and column +*> preselection-deselection functionality is turned ON or OFF. +*> +*> = 'N': Both row deselection and column +*> preselection-deselection are OFF. +*> Both arrays DESEL_ROWS and SEL_DESEL_COLS +*> are not used. +*> +*> = 'R': Only row deselection is ON. +*> Column preselection-deselection is OFF. +*> The array SEL_DESEL_COLS is not used. +*> +*> = 'C': Only column preselection-deselection is ON. +*> Row deselection is OFF. +*> The array DESEL_ROWS is not used. +*> +*> = 'A': Means "All". Both row deselection and column +*> preselection-deselection are ON. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (M) +*> DESEL_ROWS is only accessed if USESD = 'R' or 'A'. +*> This is a row deselection mask array that separates +*> the rows of matrix A into 2 sets. +*> +*> On entry: +*> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is +*> deselected by the user, i.e. chosen to be excluded from +*> the column selection algorithm (in both preselection and +*> selection stages) and will be permuted to the bottom +*> of the matrix A. +*> The number of deselected rows is denoted by M_desel. +*> +*> b) If DESEL_ROWS(i) is not equal -1, +*> the i-th row of A will be used in the column selection +*> algorithm (in both preselection and selection stages). +*> This defines a set of M_sub = M - M_desel rows that +*> the algorithm will use to select columns. +*> After the permutation, this set will be at the top +*> of the matrix A. +*> +*> On exit: +*> DESEL_ROWS will be permuted according to IPIV(i), +*> so that, if IPIV(i) = k, then the entry i of DESEL_ROWS +*> on exit was the entry k of DESEL_ROWS on entry. +*> +*> \endverbatim +*> +*> \param[in,out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (N) +*> SEL_DESEL_COLS is only accessed if USESD = 'C' or 'A'. +*> This is a column preselection-deselection mask array that +*> separates the columns of matrix A into 3 sets. +*> +*> On entry: +*> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix +*> A is preselected by the user to be included +*> in the factor C and will be permuted to the left side +*> of the array A. The number of selected columns is +*> denoted by N_sel. +*> +*> b) If SEL_DESEL_COLS(j) = -1, the j-th column of the matrix +*> A is deselected by the user, i.e. chosen to be excluded +*> from the factor C and will be permuted to the right side +*> of the array A. The number of deselected columns is +*> denoted by N_desel. +*> +*> c) If SEL_DESEL_COLS(j) is not equal to 1 and not equal +*> to -1, the j-th column of A is a free column and will be +*> used by the column selection algorithm to determine if +*> this column will be selected. This defines a set of +*> columns of size N_free = N - N_sel - N_desel. +*> +*> On exit: +*> SEL_DESEL_COLS will be permuted according to JPIV(j), +*> so that, if JPIV(j) = k, then the entry j +*> of SEL_DESEL_COLS on exit was the entry k +*> of SEL_DESEL_COLS on entry. +*> +*> NOTE: An error returned as INFO = -6 means that the number +*> of preselected N_sel columns is larger than M_sub. +*> Therefore, the QR factorization of all N_sel preselected +*> columns cannot be completed. +*> \endverbatim +*> +*> \param[in] KMAXFREE +*> \verbatim +*> KMAXFREE is INTEGER, KMAXFREE >= 0. +*> +*> The first column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> KMAXFREE is the maximum number of columns of the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) to select +*> during the column selection stage 2. +*> +*> KMAXFREE does not include the preselected N_sel columns. +*> N_sel + KMAXFREE is the maximum factorization rank of +*> the matrix A_sub. +*> +*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this +*> stopping criterion is not used, i.e. columns are +*> selected in the factorization stage 2 depending +*> on ABSTOL and RELTOL. +*> +*> b) If KMAXFREE = 0, then this stopping criterion is +*> satisfied on input and the routine exits without +*> performing column selection stage 2 +*> on the submatrix A_sub. This means that the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified +*> in the column selection stage 2 +*> and A_free is itself the residual for the factorization. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> ABSTOL is the absolute tolerance (stopping threshold) +*> for maxcol2norm(A_sub_resid(K)), where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> The column selection algorithm converges +*> (stops the factorization) when +*> maxcol2norm(A_sub_resid(K)) <= ABSTOL, where K >= N_sel. +*> +*> In the following, +*> SAFMIN = DLAMCH('S'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> maxcol2norm(A_free) is the maximum column 2-norm +*> of the matrix A_free. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -8 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and RELTOL. +*> This includes the case where ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case where ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> If ABSTOL chosen above is >= maxcol2norm(A_free), then +*> this stopping criterion is satisfied on input, and +*> the routine only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. The routine +*> then computes maxcol2norm(A_free) and returns it +*> in MAXC2NORMK, computes and returns RELMAXC2NORMK of A_free, +*> and exits immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified in the column selection stage 2. +*> This includes the case where ABSTOL = +Inf. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> RELTOL is the tolerance (stopping threshold) for the ratio +*> relmaxcol2norm(A_sub_resid(K)) = +*> = maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub), +*> where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> maxcol2norm(A_sub) is the maximum column 2-norm +*> of the original submatrix A_sub = A(1:M_sub, 1:N_sub). +*> The column selection algorithm converges +*> (stops the factorization) when the ratio +*> relmaxcol2norm(A_sub_resid(K)) <= RELTOL, where K >= N_sel. +*> +*> In the following, +*> EPS = DLAMCH('E'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -9 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input, and the routine +*> only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. +*> The routine then computes maxcol2norm(A_free) and returns +*> it in MAXC2NORMK, returns RELMAXC2NORMK as 1.0, and exits +*> immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified. +*> This includes the case RELTOL = +Inf. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> +*> On entry: +*> the M-by-N matrix A. +*> +*> On exit: +*> +*> NOTE: +*> The output parameter K, the number of selected +*> columns, is described later. +*> A_sub = A(1:M_sub, 1:N_sub). +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> +*> 2) If K > 0, A(1:M,1:N) contains the following parts: +*> +*> (a) If M_sub < M (which is the same as M_desel > 0), +*> the subarray A(M_sub+1:M,1:N) contains the deselected +*> rows. +*> +*> (b) If N_sub < N ( which is the same as N_desel > 0 ), +*> the subarray A(1:M,N_sub+1:N) contains the +*> deselected columns. +*> +*> (c) If N_sel > 0, +*> the union of the subarray A(1:M_sub, 1:N_sel) +*> and the subarray A(1:N_sel, 1:N_sub) contains parts +*> of the factors obtained by computing Householder QR +*> factorization WITHOUT column pivoting of N_sel +*> preselected columns using the routine ZGEQRF. +*> +*> (d) The subarray A(N_sel+1:M_sub, N_sel+1:N_sub) +*> contains parts of the factors obtained by computing +*> a truncated (rank K) Householder QR factorization with +*> column pivoting using the routine ZGEQP3RK on +*> the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> which is the result of applying selection and +*> deselection of columns, applying deselection of rows +*> to the original matrix A, and applying orthogonal +*> transformation from the factorization of the first +*> N_sel columns as described in part (c). +*> +*> 1. The elements below the diagonal of the subarray +*> A_sub(1:M_sub,1:K) together with TAU(1:K) +*> represent the orthogonal matrix Q(K) as a +*> product of K Householder elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A_sub(1:K,1:N_sub) contain the +*> K-by-N_sub upper-trapezoidal matrix +*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). +*> NOTE: If K = min(M_sub,N_sub), i.e. full rank +*> factorization, then R_sub_approx(K) is the +*> full factor R which is upper-trapezoidal. +*> If, in addition, M_sub >= N_sub, then R is +*> upper-triangular. +*> +*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains +*> the (M_sub-K)-by-(N_sub-K) rectangular matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were selected +*> (K is the factorization rank). +*> 0 <= K <= min( M_sub, N_sel+KMAXFREE, N_sub ). +*> +*> NOTE: If K = 0, a) the arrays A is not, modified. +*> b) the array TAU(1,min(M_sub,N_sub)) +*> is set to ZERO. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, so +*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified +*> and is itself a residual matrix, then MAXC2NRMK equals +*> the maximum column 2-norm of the original matrix A_sub. +*> +*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. +*> +*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K is equal +*> to the diagonal element R_sub(K+1,K+1) of the factor +*> R_sub in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM +*> of the maximum column 2-norm MAXC2NRMK of the residual +*> matrix A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when +*> factorization stopped at rank K) and maximum column 2-norm +*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). +*> RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub was not modified +*> and is itself a residual matrix, +*> then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M_sub,N_sub), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix +*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next +*> factorization step K+1, where R_sub(K+1,K+1) is the +*> diagonal element of the factor R_sub in the next +*> factorization step K+1. +*> \endverbatim +*> +*> \param[out] FNRMK +*> \verbatim +*> FNRMK is DOUBLE PRECISION +*> Frobenius norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). +*> FNRMK >= 0.0 +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (M) +*> Row permutation indices due to row deselection, +*> for 1 <= i <= M. +*> If IPIV(i) = k, then the row i of A was +*> the row k of A. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column permutation indices, for 1 <= j <= N. +*> If JPIV(j)= k, then the column j of A*P was +*> the column k of A. +*> +*> The first K elements of the array JPIV contain +*> indices of the columns of the factor C that were selected +*> from the matrix A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M_sub,N_sub)) +*> The scalar factors of the elementary reflectors. +*> +*> If K = 0, all elements TAU(1:min(M_sub,N_sub)) are set +*> to zero. +*> If 0 < K <= min(M_sub,N_sub): +*> only the elements TAU(1:K) may be modified, +*> the elements TAU(K+1:min(M_sub,N_sub)) are set to zero. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array. +*> +*> If FACT = 'P': +*> the array is not used, the array dimension >= (1,1). +*> +*> If FACT = 'C': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C contains a copy of +*> the original M-by-N matrix A. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C contain +*> the deselected columns from the original +*> matrix A. +*> +*> If FACT = 'X': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C is not used. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C are +*> not used. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> If FACT = 'P', LDC >= 1. +*> If FACT = 'C' or 'X', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is COMPLEX*16 array. +*> +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': the array dimension is (LDQRC,min(M,N)). +*> +*> If K = 0, the array is not used. +*> If K > 0, QRC(1:M,1:K) stores two components from +*> the QR factorization of the factor C. The K-by-K +*> factor R is stored in the upper triangle. +*> The Householder vectors are stored in the lower +*> trapezoid below the diagonal. +*> \endverbatim +*> +*> \param[in] LDQRC +*> \verbatim +*> LDQRC is INTEGER +*> The leading dimension of the array QRC. +*> If FACT = 'P' or 'C', LDQRC >= 1. +*> If FACT = 'X', LDQRC >= max(1,M). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array. +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': The array dimension is (LDX,N). +*> 1) If K = 0: +*> the M-by-N array X contains a copy of +*> the original M-by-N matrix A. +*> 2) If K > 0: +*> a) rows (1:K) of the M-by-N array X contain +*> the K-by-N factor X, where K <= N. +*> b) rows (K+1:M) of the M-by-N array X. +*> Each column of these rows contains the elements +*> whose sum of squares is the residual sum of +*> squares for the solution in each column of +*> the least squares problem. +*> min|| A - C*X ||_F for the unknown X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> If FACT = 'P' or 'C', LDX >= 1. +*> If FACT = 'X', LDX >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (max(1,LWORK)). +*> +*> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> Minimal LWORK workspace general requirement. +*> LWORK >= max( 1, min(M,N) + N ) would be sufficient for all +*> values of FACT and USESD flags. +*> +*> For good performance, LWORK should generally be larger, and +*> the user should query the routine for the optimal LWORK. +*> +*> If LWORK = -1, or LRWORK, or LIWORK =-1 then a workspace +*> query is assumed. The routine only calculates the optimal +*> size of the WORK, RWORK and IWORK arrays, returns these +*> values as the first entry of the WORK, RWORK, and IWORK +*> arrays respectively, and no error message related to LWORK +*> is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R' and for all FACT: +*> a) If FACT = 'P' or 'C': +*> LWORK >= max( 1, N-1 ) +*> b) If FACT = 'X': +*> LWORK >= max( 1, min(M,N) + N ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P' or 'C': +*> LWORK >= max( 1, N_sel, N_free ) +*> b) If FACT = 'X': +*> LWORK >= max( 1, min(M,N) + N ) +*> +*> NOTE: The decision, whether the routine uses unblocked +*> BLAS 2 or blocked BLAS 3 code is based not only on the +*> dimension LWORK of the available workspace WORK, but +*> also on: +*> 1a) column preselection stage using ZGEQRF: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine ZGEQRF +*> in comparison to N_sel. (For N_sel <= NX +*> or N_sel <= NB, unblocked code is used in ZGEQRF.) +*> 1b) column preselection stage using ZUNMQR: +*> the optimal block size NB returned by ILAENV for +*> the routine ZUNMQR in comparison to N_sel. (For +*> N_sel <= NB, unblocked code is used in ZUNMQR.) +*> 2) column selection stage via criteria using ZGEQRP3RK: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine ZGEQRP3RK +*> in comparison to min(M,N_sel). (For +*> min(M_sub, N_free, KMAXFREE) <= NX +*> or min(M_sub, N_free, KMAXFREE) <= NB, unblocked code +*> is used in ZGEQRP3RK.) +*> 3a) computation of the factor X using ZGEQRF in ZGELS: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine ZGEQRF +*> in comparison to K. (For K <= NX or K <= NB, +*> unblocked code is used in ZGEQRF inside ZGELS.) +*> 3b) computation of the factor X using ZUNMQR in ZGELS: +*> the optimal block size NB returned by ILAENV for +*> the routine ZUNMQR in comparison to N. (For +*> N <= NB, unblocked code is used in ZUNMQR +*> inside ZGELS.) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(1,LRWORK)). +*> +*> On exit, if INFO >= 0, RWORK(1) returns the optimal LRWORK. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of the array RWORK. +*> +*> Minimal LRWORK workspace general requirement. +*> LRWORK >= max( 1, 2*N ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> The optimal LRWORK is the same as the minimal LRWORK. +*> The user can still query the routine for the optimal LRWORK. +*> +*> If LWORK =-1, or LRWORK = -1, or LWORK = -1, then +*> a workspace query is assumed. The routine only calculates +*> the optimal size of the WORK, RWORK, and IWORK arrays, +*> returns these values as the first entry of the WORK, RWORK, +*> and IWORK arrays respectively, and no error message related +*> to LRWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R' and all FACT, +*> LRWORK >= max( 1, 2*N ) +*> For USESD = 'C' or 'A' and all FACT, +*> LRWORK >= max( 1, max(N_sub,2*N_free) ) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (max(1,LIWORK)). +*> +*> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> +*> Minimal LIWORK workspace general requirement. +*> LIWORK >= max( 1, 2*N ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> The optimal LIWORK is the same as the minimal LIWORK. +*> The user can still query the routine for the optimal LIWORK. +*> +*> If LWORK =-1, or LRWORK = -1, or LWORK = -1, then +*> a workspace query is assumed. The routine only calculates +*> the optimal size of the WORK, RWORK, and IWORK arrays, +*> returns these values as the first entry of the WORK, RWORK, +*> and IWORK arrays respectively, and no error message related +*> to LIWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, N-1 ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular R factor of the QR factorization of +*> the matrix C is zero. Consequently, C does not have +*> full rank, and X cannot be computed as the least +*> squares solution to the overdetermined system C*X = A. +*> (R is stored in the array QRC.) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2026, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> \endverbatim +* +*> \ingroup gecxx +* +* ===================================================================== + SUBROUTINE ZGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, RWORK, LRWORK, + $ IWORK, LIWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER FACT, USESD + INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, + $ LDX, LIWORK, LRWORK, LWORK, M, N + DOUBLE PRECISION ABSTOL, FNRMK, MAXC2NRMK, + $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), + $ JPIV( * ), SEL_DESEL_COLS( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), + $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, TWO, MINUSONE + PARAMETER ( ZERO = 0.0D+0, TWO = 2.0D+0, + $ MINUSONE = -1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, RETURNC, RETURNX, + $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL + INTEGER I, IP, IINFO, ITEMP, J, JDESEL, JP, KFREE, + $ KMAXLS, KP0, LIWKMIN, LIWKOPT, LRWKMIN, + $ LRWKOPT, LWKMIN, LWKOPT, MFREE, MDESEL, MINMN, + $ MINMNFREE, MRESID, MSUB, NFREE, NDESEL, NRESID, + $ NSEL, NSUB + DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, + $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN + +* .. External Subroutines .. + EXTERNAL ZCOPY, ZGELS, ZGEQP3RK, ZGEQRF, ZLACPY, + $ ZUNMQR, ZSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN, LSAME + INTEGER IZAMAX, ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE, DZNRM2 + EXTERNAL DISNAN, DLAMCH, ZLANGE, DZNRM2, IZAMAX, + $ ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MDESEL = 0 + NSEL = 0 + NDESEL = 0 + MSUB = M + NSUB = N + MFREE = MSUB + NFREE = NSUB + MINMN = MIN( M, N ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + RETURNX = LSAME( FACT, 'X' ) + RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX +* + USE_DESEL_ROWS = LSAME( USESD, 'R' ) + $ .OR. LSAME( USESD, 'A' ) + USE_SEL_DESEL_COLS = LSAME( USESD, 'C' ) + $ .OR. LSAME( USESD, 'A' ) +* + IF( .NOT.( RETURNC .OR. LSAME( FACT, 'P') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS + $ .OR. LSAME( USESD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE +* +* This is to check that the number of preselected columns NSEL +* cannot be larger than MSUB, which is the number of rows +* without MDESEL deselected rows. When the number of +* preselected columns NSEL is larger than MSUB, +* the factorization of all preselected NSEL columns cannot be +* completed. MSUB also will be used for LDX argument check +* later. +* + IF( USE_DESEL_ROWS ) THEN +* +* Count the number of free rows MSUB. +* + DO I = 1, M + IF( DESEL_ROWS( I ).EQ.-1 ) MDESEL = MDESEL + 1 + END DO + MSUB = M - MDESEL + MFREE = MSUB + END IF +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Count the number of preselected columns NSEL and the +* number of preselected and free columns NSUB = N - NDESEL. +* + DO J = 1, N + IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 + END DO + NSUB = N - NDESEL + MFREE = MSUB - NSEL + NFREE = NSUB - NSEL +* + END IF + MINMNFREE = MIN( MFREE, NFREE ) +* + IF( NSEL.GT.MSUB ) THEN + INFO = -6 + ELSE IF( KMAXFREE.LT.0 ) THEN + INFO = -7 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -8 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 +* This is a check for LDC + ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN + INFO = -20 +* This is a check for LDQRC + ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN + INFO = -22 +* This is a check for LDX + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN + INFO = -24 + END IF +* + END IF +* +* ================================================================== +* +* a) Test the input workspace size LWORK, LRWORK, LIWORK for the +* minimum size requirement LWKMIN, LRWKMIN, LIWKMIN +* respectively. +* b) Determine the optimal workspace sizes LWKOPT, LRWKOPT, +* and LIWKOPT to be returned in +* WORK( 1 ), RWORK( 1 ) and IWORK( 1 ) respectively, +* if INFO >= 0 in cases: +* (1) LQUERY = .TRUE., +* (2) when the routine exits. +* Here, LWKMIN, LRWKMIN and LIWKMIN are the minimum workspaces +* required for unblocked code. +* + IF( INFO.EQ.0 ) THEN + IF( MINMN.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + LRWKMIN = 1 + LRWKOPT = 1 + LIWKMIN = 1 + LIWKOPT = 1 + ELSE +* +* (Complex_wk_part_1) Complex minimum and optimal workspace +* computation. +* + LWKMIN = 1 + LWKOPT = LWKMIN +* +* (Real_wk_part_1) Real minimum workspace computation. +* LRWKMIN = MAX(1, NSUB) for column 2-norm computation +* + LRWKMIN = MAX( 1, NSUB ) +* +* (Int_wk_part_1) Integer minimum workspace computation. +* + LIWKMIN = 1 +* +* Call of ZGEQRF. +* + IF( NSEL.GT.0 ) THEN +* +* (Complex_wk_part_2) Complex minimum workspace +* computation. +* + LWKMIN = MAX( LWKMIN, NSEL ) +* +* Query for optimal workspace size for ZGEQRF. +* + CALL ZGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* Call of ZUNMQR. +* + IF( NFREE.GT.0 ) THEN +* +* (Complex_wk_part_3) Complex minimum workspace +* computation. +* + LWKMIN = MAX( LWKMIN, NFREE ) +* +* Query for optimal workspace size for ZUNMQR. +* + CALL ZUNMQR( 'L', 'T', MSUB, NFREE, + $ NSEL, A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) + END IF +* + END IF +* +* Call of ZGEQP3RK. +* + IF ( MINMNFREE.NE.0 ) THEN +* +* (Complex_wk_part_4) Complex minimum workspace +* computation. +* LWKMIN = MAX(1, NFREE-1) for the call of ZGEQP3RK. +* + LWKMIN = MAX( LWKMIN, NFREE - 1 ) +* +* Query for optimal workspace size for ZGEQP3RK. +* + CALL ZGEQP3RK( MFREE, NFREE, 0, NFREE, + $ MINUSONE, MINUSONE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), + $ WORK, -1, RWORK, IWORK, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* (Real_wk_part_2) Real minimum workspace computation. +* LRWKMIN = MAX(1, 2*NFREE) for the call of ZGEQP3RK. +* + LRWKMIN = MAX( LRWKMIN, 2*NFREE ) +* +* (Int_wk_part_2) Integer minimum workspace computation. +* LIWKMIN = NFREE-1 for the call of ZGEQP3RK. +* + LIWKMIN = MAX( LIWKMIN, NFREE-1 ) +* + IF( NSEL.NE.0 ) THEN +* +* (Int_wk_part_3) Integer minimum workspace computation. +* NFREE is for ZGEQP3RK and NFREE-1 for JPIV adjustment. +* + LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) + END IF +* + END IF +* + IF( RETURNC ) THEN +* +* Integer minimum workspace computation. +* (Int_wk_part_4) LIWKMIN = 2*N for applying the +* interchanges for the columns in the matrix C. +* + LIWKMIN = MAX( LIWKMIN, 2*N ) + END IF +* +* Real and Integer optimal workspace computation. +* + LRWKOPT = LRWKMIN + LIWKOPT = LIWKMIN +* +* Call of ZGELS. +* + IF( RETURNX ) THEN +* +* (Complex_wk_part_5) Complex minimum workspace computation. +* LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = +* = max( 1, MINMN + N ) for the call of ZGELS. +* + LWKMIN = MAX( LWKMIN, MINMN + N ) +* +* Query for optimal workspace size for ZGELS. +* + KMAXLS = MINMN +* + CALL ZGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, + $ WORK, -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) +* + END IF +* +* End of ELSE for IF( MINMN.EQ.0 ) +* + END IF +* + IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -26 + ELSE IF( ( LRWORK.LT.LRWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -28 + ELSE IF( ( LIWORK.LT.LIWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -30 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT ) + RWORK( 1 ) = DBLE( LRWKOPT ) + IWORK( 1 ) = LIWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGECXX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* ================================================================== +* +* Quick return if possible for: +* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). +* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). +* NOTE: min( M, N) = 0 implies min( MSUB, NSUB) = 0. +* We need to return correct values for all scalar output parameters, +* (including WORK(1) and IWORK(1), which are set above). +* + IF( MIN( MSUB, NSUB ).EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO + RETURN + END IF +* +* ================================================================== +* + K = 0 +* +* If we need to return factor X, copy the original untouched matrix +* A into the array X. +* + IF( RETURNX ) THEN + CALL ZLACPY( 'F', M, N, A, LDA, X, LDX ) + END IF +* +* If we need to return the factor C, copy the original matrix A +* into the array C, only if do not return the factor X. In this +* case, we need to choose the columns of the matrix A in the array C +* in place, otherwise we can copy the columns of the matrix A from +* the array X. +* + IF( RETURNC .AND. .NOT. RETURNX ) THEN + CALL ZLACPY( 'F', M, N, A, LDA, C, LDC ) + END IF +* +* ================================================================== +* Permute the deselected rows to the bottom of the matrix A. +* 1) The initial order of included rows in their block is preserved. +* 2) The initial order of deselected rows in their block is not +* preserved. +* ================================================================== +* +* I is an index of DESEL_ROWS array and a row index of +* the matrix A. MSUB is the number of processed included rows, which +* is also an index pointer to the last included row in the matrix A. +* We can think of I as a row source index, and MSUB as a destination +* index for moving an included row in the matrix A. +* +* ( We start with MSUB = 0. We loop over index I in (1:M), and +* for each position I in DESEL_ROWS array, we check if the row at +* the position I in the matrix A is an included row (not -1 value). +* If it is an included row, we increment MSUB pointer, otherwise +* we do not change MSUB index pointer. Then, we bring this included +* row from the index I in the matrix A into smaller (or same) +* MSUB index in the matrix A. If I = MSUB, then the included row +* is already in place. Due to row swap, the deselected row +* at MSUB index will move into I index in the matrix A. In this way, +* we move all the included rows to the top matrix block preserving +* their initial order within the included block. The initial order +* of deselected rows will not be preserved within their block. +* + IF( USE_DESEL_ROWS ) THEN +* + MSUB = 0 + DO I = 1, M, 1 +* +* Initialize the row pivot array IPIV. + IPIV( I ) = I +* +* The row at the index I is an included row and should be +* moved to the top of the matrix A. +* + IF( DESEL_ROWS( I ).NE.-1 ) THEN + MSUB = MSUB + 1 +* +* This is a check whether the included row is +* on the included place already. +* + IF( I.NE.MSUB ) THEN +* +* Here, we swap A(I,1:N) into A(MSUB,1:N). +* + CALL ZSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) +* +* Save the interchange. +* + IPIV( I ) = IPIV( MSUB ) + IPIV( MSUB ) = I + DESEL_ROWS( MSUB ) = DESEL_ROWS( I ) + DESEL_ROWS( I ) = -1 + END IF + END IF +* + END DO +* + ELSE +* +* We do not use the row deselection DESEL_ROWS array. +* Initialize the row pivot array IPIV. +* NOTE: MSUB=M has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO I = 1, M, 1 + IPIV( I ) = I + END DO + END IF +* +* ================================================================== +* Permute the preselected columns to the left and deselected +* columns to the right of the matrix A. +* 1) The order of preselected columns is preserved. +* 2) The order of free columns is not preserved. +* 3) The order of deselected columns is not preserved. +* ================================================================== +* +* J is the index of SEL_DESEL_COLS array and column J +* of the matrix A. +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Column selection. +* NSEL is the number of selected columns, also the pointer to +* the last selected column. +* + NSEL = 0 + DO J = 1, N, 1 +* +* Initialize column pivot array JPIV. + JPIV( J ) = J +* + IF( SEL_DESEL_COLS( J ).EQ.1 ) THEN + NSEL = NSEL + 1 +* +* This is the check whether the selected column is +* on the selected place already. +* + IF( J.NE.NSEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,NSEL) +* + CALL ZSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) + JPIV( J ) = JPIV( NSEL ) + JPIV( NSEL ) = J + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) + SEL_DESEL_COLS( NSEL ) = 1 + END IF + END IF + END DO +* +* Column deselection. +* JDESEL the pointer to the last +* deselected column counting right-to-left. +* + JDESEL = N+1 + DO J = N, NSEL+1, -1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN + JDESEL = JDESEL - 1 +* +* This is the check whether the deselected column is +* on the deselected place already. +* + IF( J.NE.JDESEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) +* + CALL ZSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) + ITEMP = JPIV( J ) + JPIV( J ) = JPIV( JDESEL ) + JPIV( JDESEL ) = ITEMP + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) + SEL_DESEL_COLS( JDESEL ) = -1 + END IF + END IF + END DO +* + NSUB = JDESEL - 1 +* + ELSE +* +* We do not use the column selection deselection +* SEL_DESEL_COLS array. +* Initialize column pivot array JPIV. +* NOTE: NSUB=N has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO J = 1, N, 1 + JPIV( J ) = J + END DO +* + END IF +* +* ================================================================== +* Compute the complete column 2-norms of the submatrix +* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). +* + DO J = 1, NSUB + RWORK( J ) = DZNRM2( MSUB, A( 1, J ), 1 ) + END DO +* +* Compute the column index of the maximum column 2-norm and +* the maximum column 2-norm itself for the submatrix +* A_sub = A(1:MSUB, 1:NSUB). +* + KP0 = IZAMAX( NSUB, WORK( 1 ), 1 ) + MAXC2NRM = RWORK( KP0 ) +* +* ================================================================== +* Process preselected columns +* +* Compute the QR factorization of NSEL preselected columns (1:NSEL) +* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update +* remaining NFREE free columns (NSEL+1:NSUB). +* NSUB = NSEL + NFREE +* + IF( NSEL.GT.0 ) THEN +* +* Case (a): MSUB < NSEL. +* +* This is handled at the argument check stage in the +* beginning of the routine. When the number of preselected +* columns is larger than MSUB, hence the factorization of +* all NSEL columns cannot be completed. Return from the +* routine with the error of COL_SEL_DESEL parameter. +* +* Case (b): MSUB = NSEL. +* Case (c-1): MSUB > NSEL and NSEL = NSUB. +* +* For cases (b) and (c-1), there will be no residual +* submatrix after factorization of NSEL columns +* at step K = NSEL: +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). +* +* Case (c-2): MSUB > NSEL and NSEL < NSUB. +* +* For Case (c-2) is a submatrix residual at step K=NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL ZGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) +* +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) +* + IF( NFREE.GT.0 ) THEN +* +* This is only for case (c-2) ('L' = Left, 'T' = Transpose) +* + CALL ZUNMQR( 'L', 'T', MSUB, NFREE, NSEL, + $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ LWORK, IINFO ) + END IF +* + K = K + NSEL +* +* End of IF(NSEL.GT.0) +* + END IF +* +* ================================================================== +* + KFREE = 0 +* + IF( MINMNFREE.NE.0 ) THEN +* +* Factorize NFREE free columns of +* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), +* KFREE is the number of columns that were actually factorized +* among NFREE columns. +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Adjust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* +* Disable RELTOLFREE when calling ZGEQP3RK for free columns +* factorization, since ZGEQP3RK expects RELTOLFREE with respect +* to the residual matrix A_sub_resid(NSEL), not the whole +* original matrix A. We can use RELTOL criterion by passing it +* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that +* the negative values of ABSTOL and RELTOL are propagated +* to ABSTOLFREE and RELTOLFREE, since negative values means +* that the criterion is disabled. +* + IF( USETOL ) THEN + ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) + ELSE + ABSTOLFREE = MINUSONE + END IF + RELTOLFREE = MINUSONE +* +* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + IWORK( NFREE + J ) = JPIV( NSEL+J ) + END DO + END IF +* + CALL ZGEQP3RK( MFREE, NFREE, 0, KMAXFREE, + $ ABSTOLFREE, RELTOLFREE, + $ A( NSEL+1, NSEL+1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( NSEL+1 ), + $ TAU( NSEL+1 ), WORK, LWORK, RWORK, IWORK, + $ IINFO ) +* +* Adjust JPIV +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + JPIV( NSEL+J ) = IWORK( NFREE + JPIV( NSEL+J ) ) + END DO + END IF +* +* 1) Adjust the return value for the number of factorized +* columns K for the whole submatrix A_sub. +* 2) MAXC2NRMK is returned transparently without change +* as MAXC2NRMKFREE is returned from ZGEQP3RK. +* 3) Adjust the return value RELMAXC2NRMK for the whole +* submatrix A_sub. We do not use RELMAXC2NRMKFREE +* returned from ZGEQP3RK. +* + K = K + KFREE + MAXC2NRMK = MAXC2NRMKFREE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + ELSE +* +* Set norms to zero +* + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + END IF +* +* Now, MRESID and NRESID is the number of rows and columns +* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). +* + MRESID = MFREE-KFREE + NRESID = NFREE-KFREE +* + IF( MIN( MRESID, NRESID ).NE.0 ) THEN + FNRMK = ZLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), + $ LDA, WORK ) + ELSE + FNRMK = ZERO + END IF +* +* ================================================================== +* +* Return the matrix C. +* + IF( RETURNC .AND. K.GT.0 ) THEN +* + IF( RETURNX ) THEN +* +* Copy the selected K columns of the original matrix A (that was +* saved into the array X) into the array C according to +* the pivot array JPIV. If we return X, then the matrix A is +* saved in the array X, and it is faster to copy into C than +* doing column permutation in place, as it is the ELSE case. +* + DO J = 1, K, 1 + CALL ZCOPY( M, X( 1, JPIV( J ) ), 1, C( 1, J ), 1 ) + END DO +* + ELSE +* +* Swap the columns of the original matrix A copied into +* the array C in place. +* +* The original M-by-N matrix A was copied into the array C at +* the beginning of the routine, if RETURNC = .TRUE.. + +* Apply the column permutation matrix P stored in JPIV(1:K) +* to the columns 1:K in the M-by-N array C in place. +* After column interchanges, the first K columns of C should +* be the same as the first K columns of A*P, i.e. +* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm +* is min(K,N-1). +* +* Index I is the original column index in the +* array C before interchanges. +* J is the current column index of the original column I at +* each step of interchanges. +* +* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) +* of the current column permutation matrix P(J) at each +* column interchange step J only for the array +* values >= J:N. +* C_prev = P_inv(J) * C_next. +* Each IWORK(I) contains JJ corresponding to I +* Initialize IWORK(1:N) as (1:N). +* + DO I = 1, N, 1 + IWORK( I ) = I + END DO +* +* Auxiliary array IWORK(N+1:2N) stores the current column +* permutation matrix P_(J) at each column interchange step J +* only for the array index >= J:N. +* C_prev * P_(J) = C_next. +* Each IWORK(N+JJ) contains I corresponding to JJ. +* Initialize IWORK(N+1:2*N) as (1:N). +* + DO J = 1, N, 1 + IWORK( N + J ) = J + END DO +* +* Loop over the columns J = ( 1:min( K, N-1 ) ) in C. +* + DO J = 1, MIN( K, N-1 ), 1 +* +* IP is the original pivot column, i.e. is the original +* column that should be placed in the current column index +* J in the array C. +* + IP = JPIV( J ) +* +* I is the original column that is +* currently in the column index J in the array C after +* previous column interchanges. +* + I = IWORK( N+J ) +* + IF( I.NE.IP ) THEN +* +* JP is the current index of the original pivot +* column IP in the array C after previous column +* interchanges. +* + JP = IWORK( IP ) + +* Swap the original pivot column IP = JPIV( J ), +* at the current pivot index JP = IWORK( IP ) into +* index J. +* + CALL ZSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) +* +* Update the array IWORK(1:N) for the original column +* I that was swapped with IP. +* + IWORK( I ) = IWORK( IP ) +* +* Update the array IWORK(N+1:2*N) for the current column +* index JP that was swapped with the current column +* index J. +* + IWORK( N + JP ) = IWORK( N + J ) +* + END IF +* + END DO +* +* End of ELSE( RETURNX ) +* + END IF +* +* End of IF( RETURNC .AND. K.GT.0 ) +* + END IF +* +* ================================================================== +* +* Return the matrix X. +* + IF( RETURNX .AND. K.GT.0 ) THEN +* +* We need to use C and A to compute X = pseudoinv(C) * A, as +* the linear least squares solution to the overdetermined system +* C*X = A. We use LLS routine that uses the QR factorization. For +* that purpose, we store the matrix C into the array QRC. +* The matrix A was copied into the array X at the beginning +* of the routine. +* + CALL ZLACPY( 'F', M, K, C, LDC, QRC, LDQRC ) +* + CALL ZGELS( 'N', M, K, N, QRC, LDQRC, X, LDX, + $ WORK, LWORK, IINFO ) + INFO = IINFO +* + END IF +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RWORK( 1 ) = DBLE( LRWKOPT ) + IWORK( 1 ) = LIWKOPT +* +* End of ZGECXX +* + END From 7fbc3e7bb0a02d710929711651e9715c1440440f Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 12 May 2026 18:43:30 -0700 Subject: [PATCH 61/63] TESTING/LIN/(d,s)chkcxx.f changed how workspace is calculated --- TESTING/LIN/dchkcxx.f | 71 +++++++++++++++++++++++++++++++++---------- TESTING/LIN/schkcxx.f | 71 ++++++++++++++++++++++++++++++++----------- 2 files changed, 109 insertions(+), 33 deletions(-) diff --git a/TESTING/LIN/dchkcxx.f b/TESTING/LIN/dchkcxx.f index 2acf0a5f8..af72f302a 100644 --- a/TESTING/LIN/dchkcxx.f +++ b/TESTING/LIN/dchkcxx.f @@ -222,18 +222,28 @@ *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, -*> dimension is maximum of the following: -*> (1) ((MMAX + 6) * max(MMAX,NMAX)) -*> for matrix generation and test routines -*> (2) max( 2*NMAX + NBMAX*( NMAX + 1 ), -*> NMAX*min(NBMAX_ORMQR,NBMAX) + (NBMAX_ORMQR+1)*NBMAX_ORMQR ) ) -*> where NBMAX_ORMQR=64 is harwiredi in DORMQR. -*> for DGECXX optimal WORK size. -*> -*> Assuming NBMAX = NMAX, the expressions become: -*> (1) 3*NMAX + NMAX*NMAX +*> dimension is the maximum of the following two expressions: +*> (1) Optimal 2orkspace dimension for matrix generation and test routines. +*> (MMAX + 6) * max(MMAX,NMAX) +*> This is an upper bound for: +*> a) DLATMS: 3*max(M,N) +*> b) DQRT12: max( M*N + 4*min(M,N) + max(M,N), +*> M*N + 2*min(M,N) + 4*N ) +*> c) DQPT01: M*N + N +*> d) DQRT11: M*M + M +*> +*> +*> (2) Optimal Workspace dimension for DGECXX. +*> max( NMAX*NBMAX, \\ for DGEQRF inside +*> NMAX*min(NBMAX_ORMQR,NBMAX) \\ for DORMQR inside +*> + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), +*> 2*NMAX + NBMAX*( NMAX + 1 ), \\ for DGEQP3RK inside +*> min(MMAX,NMAX) + NMAX*NBMAX ) \\ for DGELS inside +*> where NBMAX_ORMQR=64 is hardwired in DORMQR. +*> +*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: +*> (1) NMAX*NMAX + 6*NMAX *> (2) NMAX * min(64,NMAX) + 4160 -*> *> \endverbatim *> *> \param[out] IWORK @@ -381,10 +391,21 @@ SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, MINMN = MIN( M, N ) LDX = MAX( 1, N ) * -* Set work for testing routines. +* 1) NOTE: for matrix generation routine DLATMS, the workspace length +* LWKTMS = 3*MAX( M, N ). LWKTMS not used in the code. * - LWKTST = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), +* 2) Set workspace length for testing routines. +* a) for DQRT12 + LWKTST = MAX( 1, M*N + 4*MINMN + MAX( M, N ), $ M*N + 2*MINMN + 4*N ) +* +* b) for DQPT01 +* + LWKTST = MAX( LWKTST, M*N + N ) +* +* c) for DQRT11 +* + LWKTST = MAX( LWKTST, M*M + M ) * DO IMAT = 1, NTYPES * @@ -757,12 +778,30 @@ SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, * * Compute the QR factorization with pivoting of A * +* Determine LWORK +* * NBMAX_ORMQR is hardwired in DORMQR as NBMAX = 64. * NBMAX_ORMQR = 64 - LWORK = MAX( 1, - $ 2*N + NB*( N + 1 ), - $ N*min(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) +* +* a) For DGEQRF inside DGECXX +* + LWORK = MAX( 1, N*NB ) +* +* b) For DORMQR inside DGECXX +* + LWORK = MAX( LWORK, + $ N*min(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) +* +* c) For DGEQP3RK inside DGECXX +* + LWORK = MAX( LWORK, 2*N + NB*( N + 1 ) ) +* +* d) For DGELS inside DGECXX +* + LWORK = MAX( LWORK, MIN(M,N) + N*NB ) +* +* Determine LIWORK * LIWORK = MAX( 1, 2*N ) * diff --git a/TESTING/LIN/schkcxx.f b/TESTING/LIN/schkcxx.f index 03b739919..33d686289 100644 --- a/TESTING/LIN/schkcxx.f +++ b/TESTING/LIN/schkcxx.f @@ -221,19 +221,27 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is REAL array, -*> dimension is maximum of the following: -*> (1) ((MMAX + 6) * max(MMAX,NMAX)) -*> for matrix generation and test routines -*> (2) max( 2*NMAX + NBMAX*( NMAX + 1 ), -*> NMAX*min(NBMAX_ORMQR,NBMAX) + (NBMAX_ORMQR+1)*NBMAX_ORMQR ) ) -*> where NBMAX_ORMQR=64 is harwiredi in DORMQR. -*> for SGECXX optimal WORK size. -*> -*> Assuming NBMAX = NMAX, the expressions become: -*> (1) 3*NMAX + NMAX*NMAX +*> WORK is DOUBLE PRECISION array, +*> dimension is the maximum of the following: +*> (1) (MMAX + 6) * max(MMAX,NMAX) for matrix generation and test routines. +*> This is an upper bound for: +*> a) for DLATMS: 3*max(M,N) +*> b) for DQRT12: max( M*N + 4*min(M,N) + max(M,N), +*> M*N + 2*min(M,N) + 4*N ) +*> c) for DQPT01: M*N + N +*> d) for DQRT11: M*M + M +*> +*> +*> (2) max( NMAX*NBMAX, +*> 2*NMAX + NBMAX*( NMAX + 1 ), +*> NMAX*min(NBMAX_ORMQR,NBMAX) + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), +*> min(MMAX,NMAX) + NMAX*NBMAX ) +*> where NBMAX_ORMQR=64 is hardwired in DORMQR, +*> for DGECXX optimal WORK size. +*> +*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: +*> (1) NMAX*NMAX + 6*NMAX *> (2) NMAX * min(64,NMAX) + 4160 -*> *> \endverbatim *> *> \param[out] IWORK @@ -381,10 +389,21 @@ SUBROUTINE SCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, MINMN = MIN( M, N ) LDX = MAX( 1, N ) * -* Set work for testing routines. +* 1) NOTE: for matrix generation routine SLATMS, the workspace length +* LWKTMS = 3*MAX( M, N ). LWKTMS not used in the code. * - LWKTST = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), +* 2) Set workspace length for testing routines. +* a) for SQRT12 + LWKTST = MAX( 1, M*N + 4*MINMN + MAX( M, N ), $ M*N + 2*MINMN + 4*N ) +* +* b) for SQPT01 +* + LWKTST = MAX( LWKTST, M*N + N ) +* +* c) for SQRT11 +* + LWKTST = MAX( LWKTST, M*M + M ) * DO IMAT = 1, NTYPES * @@ -757,12 +776,30 @@ SUBROUTINE SCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, * * Compute the QR factorization with pivoting of A * +* Determine LWORK +* * NBMAX_ORMQR is hardwired in DORMQR as NBMAX = 64. * NBMAX_ORMQR = 64 - LWORK = MAX( 1, - $ 2*N + NB*( N + 1 ), - $ N*min(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) +* +* a) For SGEQRF inside SGECXX +* + LWORK = MAX( 1, N*NB ) +* +* b) For SORMQR inside SGECXX +* + LWORK = MAX( LWORK, + $ N*min(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) +* +* c) For SGEQP3RK inside SGECXX +* + LWORK = MAX( LWORK, 2*N + NB*( N + 1 ) ) +* +* d) For SGELS inside SGECXX +* + LWORK = MAX( LWORK, MIN(M,N) + N*NB ) +* +* Determine LIWORK * LIWORK = MAX( 1, 2*N ) * From 1ccf4a66409704c0d29b6aafb490fc438166ea28 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 12 May 2026 22:14:03 -0700 Subject: [PATCH 62/63] TESTING/LIN/(d,s)chkcxx.f corrected the descriptio of WORK parameter modified: TESTING/LIN/dchkcxx.f modified: TESTING/LIN/schkcxx.f --- TESTING/LIN/dchkcxx.f | 10 ++++----- TESTING/LIN/schkcxx.f | 50 +++++++++++++++++++++++++------------------ 2 files changed, 34 insertions(+), 26 deletions(-) diff --git a/TESTING/LIN/dchkcxx.f b/TESTING/LIN/dchkcxx.f index af72f302a..1134f19aa 100644 --- a/TESTING/LIN/dchkcxx.f +++ b/TESTING/LIN/dchkcxx.f @@ -223,7 +223,7 @@ *> \verbatim *> WORK is DOUBLE PRECISION array, *> dimension is the maximum of the following two expressions: -*> (1) Optimal 2orkspace dimension for matrix generation and test routines. +*> (1) Optimal workspace dimension for matrix generation and test routines. *> (MMAX + 6) * max(MMAX,NMAX) *> This is an upper bound for: *> a) DLATMS: 3*max(M,N) @@ -233,7 +233,7 @@ *> d) DQRT11: M*M + M *> *> -*> (2) Optimal Workspace dimension for DGECXX. +*> (2) Optimal workspace dimension for DGECXX. *> max( NMAX*NBMAX, \\ for DGEQRF inside *> NMAX*min(NBMAX_ORMQR,NBMAX) \\ for DORMQR inside *> + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), @@ -241,9 +241,9 @@ *> min(MMAX,NMAX) + NMAX*NBMAX ) \\ for DGELS inside *> where NBMAX_ORMQR=64 is hardwired in DORMQR. *> -*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: -*> (1) NMAX*NMAX + 6*NMAX -*> (2) NMAX * min(64,NMAX) + 4160 +*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: +*> (1) NMAX*NMAX + 6*NMAX +*> (2) NMAX * min(64,NMAX) + 4160 *> \endverbatim *> *> \param[out] IWORK diff --git a/TESTING/LIN/schkcxx.f b/TESTING/LIN/schkcxx.f index 33d686289..fba97414c 100644 --- a/TESTING/LIN/schkcxx.f +++ b/TESTING/LIN/schkcxx.f @@ -221,27 +221,35 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, -*> dimension is the maximum of the following: -*> (1) (MMAX + 6) * max(MMAX,NMAX) for matrix generation and test routines. -*> This is an upper bound for: -*> a) for DLATMS: 3*max(M,N) -*> b) for DQRT12: max( M*N + 4*min(M,N) + max(M,N), -*> M*N + 2*min(M,N) + 4*N ) -*> c) for DQPT01: M*N + N -*> d) for DQRT11: M*M + M -*> -*> -*> (2) max( NMAX*NBMAX, -*> 2*NMAX + NBMAX*( NMAX + 1 ), -*> NMAX*min(NBMAX_ORMQR,NBMAX) + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), -*> min(MMAX,NMAX) + NMAX*NBMAX ) -*> where NBMAX_ORMQR=64 is hardwired in DORMQR, -*> for DGECXX optimal WORK size. -*> -*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: -*> (1) NMAX*NMAX + 6*NMAX -*> (2) NMAX * min(64,NMAX) + 4160 +*> WORK is REAL array, +*> dimension is the maximum of the following two expressions: +*> (1) Optimal workspace dimension for matrix generation and test routines. +*> (MMAX + 6) * max(MMAX,NMAX) +*> This is an upper bound for: +*> a) SLATMS: 3*max(M,N) +*> b) SQRT12: max( M*N + 4*min(M,N) + max(M,N), +*> M*N + 2*min(M,N) + 4*N ) +*> c) SQPT01: M*N + N +*> d) SQRT11: M*M + M +*> +*> +*> (2) Optimal workspace dimension for SGECXX. +*> max( NMAX*NBMAX, \\ for SGEQRF inside +*> NMAX*min(NBMAX_ORMQR,NBMAX) \\ for SORMQR inside +*> + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), +*> 2*NMAX + NBMAX*( NMAX + 1 ), \\ for SGEQP3RK inside +*> min(MMAX,NMAX) + NMAX*NBMAX ) \\ for SGELS inside +*> where NBMAX_ORMQR=64 is hardwired in SORMQR. +*> +*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: +*> (1) NMAX*NMAX + 6*NMAX +*> (2) NMAX * min(64,NMAX) + 4160 +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> for DGECXX optimal IWORK size. *> \endverbatim *> *> \param[out] IWORK From 778a5370b1a5e6c6c02a9fd7c8806bfdf1e35a46 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 12 May 2026 23:43:37 -0700 Subject: [PATCH 63/63] TESTING/LIN/(d,s)chkcxx.f improved comments for WORK parameter modified: TESTING/LIN/dchkcxx.f modified: TESTING/LIN/schkcxx.f --- TESTING/LIN/dchkcxx.f | 36 ++++++++++++++++++------------------ TESTING/LIN/schkcxx.f | 38 +++++++++++++++++++------------------- 2 files changed, 37 insertions(+), 37 deletions(-) diff --git a/TESTING/LIN/dchkcxx.f b/TESTING/LIN/dchkcxx.f index 1134f19aa..04918ace6 100644 --- a/TESTING/LIN/dchkcxx.f +++ b/TESTING/LIN/dchkcxx.f @@ -221,29 +221,29 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, -*> dimension is the maximum of the following two expressions: -*> (1) Optimal workspace dimension for matrix generation and test routines. -*> (MMAX + 6) * max(MMAX,NMAX) -*> This is an upper bound for: +*> WORK is DOUBLE PRECISION array. +*> Dimension is the maximum of the following two expressions: +*> (1) Optimal complex workspace dimension for matrix generation +*> and test routines. +*> (MMAX + 6) * max(MMAX,NMAX) +*> This is an upper bound for: *> a) DLATMS: 3*max(M,N) *> b) DQRT12: max( M*N + 4*min(M,N) + max(M,N), *> M*N + 2*min(M,N) + 4*N ) *> c) DQPT01: M*N + N *> d) DQRT11: M*M + M *> +*> (2) Optimal workspace dimension for DGECXX. +*> max( NMAX*NBMAX, \\ for DGEQRF inside +*> NMAX*min(NBMAX_ORMQR,NBMAX) \\ for DORMQR inside +*> + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), +*> 2*NMAX + NBMAX*( NMAX + 1 ), \\ for DGEQP3RK inside +*> min(MMAX,NMAX) + NMAX*NBMAX ), \\ for DGELS inside +*> where NBMAX_ORMQR=64 is hardwired in DORMQR. *> -*> (2) Optimal workspace dimension for DGECXX. -*> max( NMAX*NBMAX, \\ for DGEQRF inside -*> NMAX*min(NBMAX_ORMQR,NBMAX) \\ for DORMQR inside -*> + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), -*> 2*NMAX + NBMAX*( NMAX + 1 ), \\ for DGEQP3RK inside -*> min(MMAX,NMAX) + NMAX*NBMAX ) \\ for DGELS inside -*> where NBMAX_ORMQR=64 is hardwired in DORMQR. -*> -*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: -*> (1) NMAX*NMAX + 6*NMAX -*> (2) NMAX * min(64,NMAX) + 4160 +*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: +*> (1) NMAX*NMAX + 6*NMAX +*> (2) NMAX * min(64,NMAX) + 4160 *> \endverbatim *> *> \param[out] IWORK @@ -318,7 +318,7 @@ SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, INTEGER I, IM, IMAT, IN, INB, IND_OFFSET_GEN, $ IND_IN, IND_OUT, INFO, J, J_INC, J_FIRST_NZ, $ JB_ZERO, K, KL, KMAXFREE, KU, LDA, LDC, - $ LDQRC, LDX, LIWORK,LWORK, LWKTST, + $ LDQRC, LDX, LIWORK, LWORK, LWKTST, $ M, MINMN, MINMNB_GEN, MODE, N, $ NB, NBMAX_ORMQR, NB_ZERO, NERRS, NFAIL, $ NB_GEN, NRUN, NX, T @@ -791,7 +791,7 @@ SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, * b) For DORMQR inside DGECXX * LWORK = MAX( LWORK, - $ N*min(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) + $ N*MIN(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) * * c) For DGEQP3RK inside DGECXX * diff --git a/TESTING/LIN/schkcxx.f b/TESTING/LIN/schkcxx.f index fba97414c..c08ba3d8b 100644 --- a/TESTING/LIN/schkcxx.f +++ b/TESTING/LIN/schkcxx.f @@ -221,35 +221,35 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is REAL array, -*> dimension is the maximum of the following two expressions: -*> (1) Optimal workspace dimension for matrix generation and test routines. -*> (MMAX + 6) * max(MMAX,NMAX) -*> This is an upper bound for: +*> WORK is REAL array. +*> Dimension is the maximum of the following two expressions: +*> (1) Optimal complex workspace dimension for matrix generation +*> and test routines. +*> (MMAX + 6) * max(MMAX,NMAX) +*> This is an upper bound for: *> a) SLATMS: 3*max(M,N) *> b) SQRT12: max( M*N + 4*min(M,N) + max(M,N), *> M*N + 2*min(M,N) + 4*N ) *> c) SQPT01: M*N + N *> d) SQRT11: M*M + M *> +*> (2) Optimal workspace dimension for SGECXX. +*> max( NMAX*NBMAX, \\ for SGEQRF inside +*> NMAX*min(NBMAX_ORMQR,NBMAX) \\ for SORMQR inside +*> + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), +*> 2*NMAX + NBMAX*( NMAX + 1 ), \\ for SGEQP3RK inside +*> min(MMAX,NMAX) + NMAX*NBMAX ), \\ for SGELS inside +*> where NBMAX_ORMQR=64 is hardwired in SORMQR. *> -*> (2) Optimal workspace dimension for SGECXX. -*> max( NMAX*NBMAX, \\ for SGEQRF inside -*> NMAX*min(NBMAX_ORMQR,NBMAX) \\ for SORMQR inside -*> + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), -*> 2*NMAX + NBMAX*( NMAX + 1 ), \\ for SGEQP3RK inside -*> min(MMAX,NMAX) + NMAX*NBMAX ) \\ for SGELS inside -*> where NBMAX_ORMQR=64 is hardwired in SORMQR. -*> -*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: -*> (1) NMAX*NMAX + 6*NMAX -*> (2) NMAX * min(64,NMAX) + 4160 +*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: +*> (1) NMAX*NMAX + 6*NMAX +*> (2) NMAX * min(64,NMAX) + 4160 *> \endverbatim *> *> \param[out] IWORK *> \verbatim *> IWORK is INTEGER array, dimension (2*NMAX) -*> for DGECXX optimal IWORK size. +*> for SGECXX optimal IWORK size. *> \endverbatim *> *> \param[out] IWORK @@ -324,7 +324,7 @@ SUBROUTINE SCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, INTEGER I, IM, IMAT, IN, INB, IND_OFFSET_GEN, $ IND_IN, IND_OUT, INFO, J, J_INC, J_FIRST_NZ, $ JB_ZERO, K, KL, KMAXFREE, KU, LDA, LDC, - $ LDQRC, LDX, LIWORK,LWORK, LWKTST, + $ LDQRC, LDX, LIWORK, LWORK, LWKTST, $ M, MINMN, MINMNB_GEN, MODE, N, $ NB, NBMAX_ORMQR, NB_ZERO, NERRS, NFAIL, $ NB_GEN, NRUN, NX, T @@ -797,7 +797,7 @@ SUBROUTINE SCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, * b) For SORMQR inside SGECXX * LWORK = MAX( LWORK, - $ N*min(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) + $ N*MIN(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) * * c) For SGEQP3RK inside SGECXX *