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 diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index 33f2764d4..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 @@ -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/Makefile b/SRC/Makefile index 13e47020d..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 \ @@ -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 \ diff --git a/SRC/dgecxx.f b/SRC/dgecxx.f new file mode 100644 index 000000000..e5ab5f4b5 --- /dev/null +++ b/SRC/dgecxx.f @@ -0,0 +1,1714 @@ +*> \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 =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGECXX + 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 ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER FACT, USESD +* INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, +* $ LDX, LIWORK, LWORK, M, N +* DOUBLE PRECISION ABSTOL, FNRMK, MAXC2NRMK, +* $ RELMAXC2NRMK, RELTOL +* .. +* .. 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 a column +*> 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, +*> +*> 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 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 +*> 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 DOUBLE PRECISION 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 DGEQRF. +*> +*> (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)(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 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. +*> \endverbatim +*> +*> \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': +*> 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 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 (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 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). +*> 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 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. +*> +*> 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 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 +*> 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 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.) +*> 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 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 is used in DORMQR +*> inside DGELS.) +*> \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 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 ) + 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 + DOUBLE PRECISION ABSTOL, FNRMK, MAXC2NRMK, + $ RELMAXC2NRMK, RELTOL +* .. +* .. 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 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 + DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, + $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN + +* .. External Subroutines .. + EXTERNAL DCOPY, DGELS, DGEQP3RK, DGEQRF, DLACPY, + $ 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 + 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( 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 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 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. +* +* 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 +* +* (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 +* 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. +* + + 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( 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 ) ) ) +* +* (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 +* +* (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 +* + 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 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 ) +* +* 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 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 ) = DBLE( LWKOPT ) + IWORK( 1 ) = LIWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGECXX', -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 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. +* 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 DSWAP( 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 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 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 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 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 ) = 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 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 DGEQRF( 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 DORMQR( '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 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 +* 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 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 ) +* +* 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 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 +* + 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 + 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 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. +* 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 DSWAP( 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 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 +* +* End of DGECXX +* + END diff --git a/SRC/lapack_64.h b/SRC/lapack_64.h index 3b9d4275a..dc7cb701a 100644 --- a/SRC/lapack_64.h +++ b/SRC/lapack_64.h @@ -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 @@ -1232,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 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