From fffd38fedc98ca421d2d29b2e98f709ad709b45e Mon Sep 17 00:00:00 2001 From: scr2016 Date: Tue, 8 Aug 2023 17:00:44 -0700 Subject: [PATCH 001/106] changed comment in dchkq3 --- TESTING/LIN/dchkq3.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/TESTING/LIN/dchkq3.f b/TESTING/LIN/dchkq3.f index 1fdf07252b..494008fa85 100644 --- a/TESTING/LIN/dchkq3.f +++ b/TESTING/LIN/dchkq3.f @@ -30,7 +30,7 @@ *> *> \verbatim *> -*> DCHKQ3 tests DGEQP3. +*> DCHKQ3 tests DGEQP3. *> \endverbatim * * Arguments: From b8475a728d621229054b5faf69d5d56c266bd569 Mon Sep 17 00:00:00 2001 From: scr2016 Date: Wed, 9 Aug 2023 09:07:52 -0700 Subject: [PATCH 002/106] added dgeqp3rk.f dlaqp2rk.f dlaqp3rk.f --- SRC/CMakeLists.txt | 4 +- SRC/Makefile | 4 +- SRC/dgeqp3rk.f | 866 +++++++++++++++++++++++++++++++++++++++++++++ SRC/dlaqp2rk.f | 502 ++++++++++++++++++++++++++ SRC/dlaqp3rk.f | 600 +++++++++++++++++++++++++++++++ 5 files changed, 1972 insertions(+), 4 deletions(-) create mode 100755 SRC/dgeqp3rk.f create mode 100755 SRC/dlaqp2rk.f create mode 100755 SRC/dlaqp3rk.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index a84f784182..f047dc4471 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -287,7 +287,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 dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f + dgeqp3.f dgeqp3rk.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 @@ -302,7 +302,7 @@ set(DLASRC dlangb.f dlange.f dlangt.f dlanhs.f dlansb.f dlansp.f dlansy.f dlantb.f dlantp.f dlantr.f dlanv2.f dlapll.f dlapmt.f - dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqsb.f dlaqsp.f dlaqsy.f + dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqp2rk.f dlaqp3rk.f dlaqsb.f dlaqsp.f dlaqsy.f dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f dlarf.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f diff --git a/SRC/Makefile b/SRC/Makefile index 40041b8991..33cec713e4 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -321,7 +321,7 @@ DLASRC = \ dgebrd.o dgecon.o dgeequ.o dgees.o dgeesx.o dgeev.o dgeevx.o \ dgehd2.o dgehrd.o dgelq2.o dgelqf.o \ dgels.o dgelst.o dgelsd.o dgelss.o dgelsy.o dgeql2.o dgeqlf.o \ - dgeqp3.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \ + dgeqp3.o dgeqp3rk.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 \ @@ -336,7 +336,7 @@ DLASRC = \ dlangb.o dlange.o dlangt.o dlanhs.o dlansb.o dlansp.o \ dlansy.o dlantb.o dlantp.o dlantr.o dlanv2.o \ dlapll.o dlapmt.o \ - dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \ + dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqp2rk.o dlaqp3rk.o dlaqsb.o dlaqsp.o dlaqsy.o \ dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \ dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \ dlarf.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \ diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f new file mode 100755 index 0000000000..7ed64bc3c5 --- /dev/null +++ b/SRC/dgeqp3rk.f @@ -0,0 +1,866 @@ +*> \brief \b DGEQP3RK computes a truncated Householder QR factorization with column pivoting of a real m-by-n matrix A by using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, +* $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, +* $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a real +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is a N-by-N permutation matrix; +*> Q(K) is an M-by-M orthogonal matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a real M-by-NRHS +*> matrix B with Q(K)**T * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter MAXK, the maximum number of columns +*> MAXK to factorize, i.e. the factorization rank is limited +*> to MAXK. If MAXK >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) and +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> For full rank factorization use the values MAXK >= min(M,N), +*> ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_approx); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**T * B, the matrix B with the orthogonal +*> transformation Q(K)**T applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= K, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M orthogonal matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**T, +*> +*> where 1 <= j <= K and +*> I is an M-by_M identity matrix, +*> tau is a real scalar, +*> v is a real vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] MAXK +*> \verbatim +*> MAXK is INTEGER +*> +*> The first factorization stopping criterion. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. MAXK >= 0. +*> +*> a) If MAXK >= min(M,N), then this stopping criterion +*> is not used, factorize columns depending +*> on ABSTOL and RELTOL. +*> +*> b) If MAXK = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, factorize columns depending on MAXK and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> If ABSTOL chosen above is >= abs(R(1,1)), then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after R(1,1) is computed to return it in +*> MAXC2NORMK, also RELMAXC2NORMK is returned as 1.0. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> Here, abs(R(1,1)) is the maximum column 2-norm of the +*> original matrix A; SAFMIN = DLAMCH('S'). +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) and the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, factorize columns depending on MAXK and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after R(1,1) is computed to return it in +*> MAXC2NORMK, also RELMAXC2NORMK is returned as 1.0. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M,N)*EPS, sqrt(EPS)) <= RELTOL +*> +*> Here, EPS = DLAMCH('E'). +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,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(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) The subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**T * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were factorized. +*> K is the factorization rank. +*> 0 <= K <= min( M, min(MAXK,N) ). +*> +*> If K = 0, the arrays A, TAU, JPIV were not modified. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix A22(K), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K would equal +*> R(K+1,K+1) in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix A22(K) (when factorization +*> stopped at rank K) and maximum column 2-norm of the +*> original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= K, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= MIN(M,N), only elements TAU(1:K) of +*> the array TAU may be modified. The elements +*> TAU(K+1:min(M,N)) are set to zero. +*> If K = 0, all elements of TAU are set to zero. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 3*N+1. +*> For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB +*> is the optimal block size for DGETRF returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine DLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup heqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> DGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in DGEQP3 routine which uses DGEQRF +*> to perform Householder QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE, USETOL + INTEGER IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP0, LWKOPT, MINMN, NA, NB, NBMIN, + $ NX + DOUBLE PRECISION EPS, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL DLAQP2RK, DLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DISNAN, DLAMCH, DNRM2, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE + IWS = 3*N +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = 2*N + NB*( 1+N+NRHS ) + END IF + WORK( 1 ) = DBLE( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M, N. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Ajust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', M, N, -1, -1 ) ) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease at each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + WORK( J ) = DNRM2( M, A( 1, J ), 1 ) + WORK( N+J ) = WORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole matrix A(1:M,1:N). +* + KP0 = IDAMAX( N, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP0 ) +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* Quick return if A is a zero matrix. +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* + IF( USETOL ) THEN + K = 0 + ELSE + K = JMAX + END IF +* + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) +* +* Factorize JB columns among the columns A(J:N). +* + CALL DLAQP3RK( M, N-J+1, NRHS, J-1, JB, KMAX, ABSTOL, + $ RELTOL, KP0, MAXC2NRM, A( 1, J ), LDA, JBF, + $ DONE, KF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), + $ N+NRHS-J+1, IWORK ) +* + J = J + JBF +* + IF( DONE ) THEN +* +* ABSTOL or RELTOL criterion is satisfied before the +* end of the column block, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* block factorization routine. +* + K = J - 1 +* +* Exit loop +* + EXIT +* + END IF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of columns, +* That is in ELSE clause we nned to compute the MAXC2NORM and +* RELMAXC2NORM to return after we processed the blocks. +* + IF( .NOT.DONE ) THEN +* + IF( J.LE.JMAX ) THEN +* + CALL DLAQP2RK( M, N-J+1, NRHS, J-1, JMAX-J+1, ABSTOL, + $ RELTOL, KP0, MAXC2NRM, A( 1, J ), LDA, KF, + $ MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ) ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + IDAMAX( N-K, WORK( K+1 ), 1 ) + MAXC2NRMK = WORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = ZERO + END DO + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF +* +* END IF( .NOT.DONE ) THEN +* + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) +* + RETURN +* +* End of DGEQP3RK +* + END diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f new file mode 100755 index 0000000000..69671f4a43 --- /dev/null +++ b/SRC/dlaqp2rk.f @@ -0,0 +1,502 @@ +*> \brief \b DLAQP2RK computes truncated QR factorization with column pivoting of the matrix block using Level 2 BLAS and overwrites m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP0, MAXC2NRM, A, LDA, KF, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) +* +* .. Scalar Arguments .. +* INTEGER IOFFSET, KP0, KF, KMAX, LDA, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of the block A(IOFFSET+1:M,1:N). +*> The routine is calling Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. The routine also +*> overwrites the matrix B block stored in A(IOFFSET+1:M,N+1:N+NRHS) +*> with Q(K)**T * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET also represents the number of +*> columns of the original matrix that have been factorized +*> in the previous steps. +*> IOFFSET >= 0. +*> \endverbatim +*> +*> \param[in] MAXK +*> \verbatim +*> MAXK is INTEGER +*> +*> The first factorization stopping criterion. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. MAXK >= 0. +*> +*> a) If MAXK >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If MAXK = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) and the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. +*> +*> Here, abs(R(1,1)) is the maximum column 2-norm of the +*> original matrix A; EPS = DLAMCH('E'). +*> \endverbatim +*> +*> \param[in] KP0 +*> \verbatim +*> KP0 is INTEGER +*> The index of column with the maximum column 2-norm for +*> the whole original matrix A. KP0 > 0. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original matrix. +*> MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KF) below +*> the diagonal,together with the array TAU, represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The block of the matrix A stored in A(IOFFSET+1:M,1:KF) +*> is the triangular factor obtained. +*> 3. The block of the the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but no factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KF+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KF+1:N) of +*> this block contains the residual of the matrix A, and +*> the right part of the block A(IOFFSET+1:M,N+1:N+NRHS) +*> contains the block of the right-hand-side matrix B. Both +*> these blocks have been updated by multiplication from +*> the left by Q**T. +*> \endverbatim +*> +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] KF +*> \verbatim +*> KF is INTEGER +*> The number of columns actually factorized. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix A22, +*> when factorization stopped. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix A22 ( when factorization +*> stopped) and the maximum column 2-norm of the +*> original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= K, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> Used in DLARF subroutine to apply elementary +*> reflector. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP0, MAXC2NRM, A, LDA, KF, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER IOFFSET, KP0, KF, KMAX, LDA, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, MINMNFACT, MINMNUPDT, I, K, KP + DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KMAX = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) +* +* Compute factorization. +* + DO K = 1, KMAX +* + I = IOFFSET + K +* + IF( IOFFSET.EQ.0 .AND. K.EQ.1 ) THEN +* +* If we are at the first column of the original whole matrix A. +* + KP = KP0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + ELSE +* +* Determine the pivot column at K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) at step K. +* + MAXC2NRMK = VN1( KP ) + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + END IF +* +* ================================================================== +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* + + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Exit the loop +* + EXIT + END IF +* +* ================================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL DSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Generate elementary reflector H(K) using the column A(I:M,K), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(K) = ZERO. +* + IF( K.LT.M ) THEN + CALL DLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, + $ TAU( K ) ) + ELSE + TAU( K ) = ZERO + END IF +* +* Apply H(K)**T to A(I:M,K+1:N+NRHS) from the left. +* ( If M >= N, then at K = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B ) +* If M < N, then at K = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(K) = ZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* K < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only K < N+NRHS ) +* + IF( K.LT.MINMNUPDT ) THEN + AIK = A( I, K ) + A( I, K ) = ONE + CALL DLARF( 'Left', M-I+1, N+NRHS-K, A( I, K ), 1, + $ TAU( K ), A( I, K+1 ), LDA, WORK( 1 ) ) + A( I, K ) = AIK + END IF +* + IF( K.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < min(M-IOFFSET, N). +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = DNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* Set the number of factorized columns +* + KF = K - 1 +* + IF( KF.EQ.KMAX ) THEN +* +* All KMAX columns were factorized, no ABSTOL or RELTOL triggered. +* + + IF( KF.LT.MINMNFACT ) THEN + JMAXC2NRM = KF + IDAMAX( N-KF, VN1( KF+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( KF.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* + +* + END IF +* +* Set TAU(KF+1:MINMN) to ZERO. +* + DO J = KF + 1, MINMNFACT + TAU( J ) = ZERO + END DO +* + RETURN +* +* End of DLAQP2RK +* + END diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f new file mode 100755 index 0000000000..c996574bcc --- /dev/null +++ b/SRC/dlaqp3rk.f @@ -0,0 +1,600 @@ +*> \brief \b DLAQP3RK computes a step of truncated QR factorization with column pivoting of a real m-by-n matrix A using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, RELTOL, +* $ KP0, MAXC2NRM, A, LDA, KB, DONE, +* $ KF, MAXC2NRMK, RELMAXC2NRMK, +* $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) +* +* .. Scalar Arguments .. +* LOGICAL DONE +* INTEGER KB, LDA, LDF, M, N, NB, NRHS, IOFFSET +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), +* $ VN1( * ), VN2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQP3RK computes a step of truncated QR factorization with column +*> pivoting of a real M-by-N matrix A by using Level 3 BLAS. The routine +*> tries to factorize NB columns from A starting from the row IOFFSET+1, +*> and updates all of the matrix with BLAS 3 xGEMM, the number of accually +*> factorized columns is returned in KB, KB <= NB. +*> +*> Cases when the number of factorized columns KB < NB: +*> +*> (1) In some cases, due to catastrophic cancellations, it cannot +*> factorize NB columns. Hence, the actual number of factorized +*> columns is returned in KB. +*> +*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, +*> the factorization is stopped, the logical DONE is returned +*> as TRUE. The number of factorized columns which is smaller than NB +*> returned in KB. +*> +*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides B block stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(K)**T * B. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but no factorized. IOFFSET >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The number of columns to factorize. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) and the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. +*> +*> Here, abs(R(1,1)) is the maximum column 2-norm of the +*> original matrix A; EPS = DLAMCH('E'). +*> \endverbatim +*> +*> \param[in] KP0 +*> \verbatim +*> KP0 is INTEGER +*> The index of column with the maximum column 2-norm for +*> the whole original matrix A. KP0 > 0. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original matrix. +*> MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KB) below +*> the diagonal,together with the array TAU, represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The block of the matrix A stored in A(IOFFSET+1:M,1:KB) +*> is the triangular factor obtained. +*> 3. The block of the the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but no factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KB+1:N) of +*> this block contains the residual of the matrix A, and +*> the right part of the block A(IOFFSET+1:M,N+1:N+NRHS) +*> contains the block of the right-hand-side matrix B. Both +*> these blocks have been updated by multiplication from +*> the left by Q**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns actually factorized. +*> \endverbatim +*> +*> \param[out] +*> +*> \verbatim +*> DONE is LOGICAL +*> TRUE, if the factorization completed, +*> FALSE, otherwise. +*> \endverbatim +*> +*> \param[out] KF +*> \verbatim +*> KF is INTEGER +*> The number of columns of the original whole matrix A +*> factorized. +*> \endverbatim +* +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix A22(K), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> ( Rank K is with respect to the original matrix A ) +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix A22, +*> when factorization stopped. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix A22 ( when factorization +*> stopped) and the maximum column 2-norm of the +*> original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (NB) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] AUXV +*> \verbatim +*> AUXV is DOUBLE PRECISION array, dimension (NB) +*> Auxiliary vector. +*> \endverbatim +*> +*> \param[out] F +*> \verbatim +*> F is DOUBLE PRECISION array, dimension (LDF,NB) +*> Matrix F**T = L*Y**T*A. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1,N+NRHS). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp3rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A, LDA, KB, DONE, + $ KF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) +* +* -- LAPACK auxiliary 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 DONE + INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, N, NB, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, MINMNFACT, MINMNNRHSFACT, + $ LSTICC, KP, I + DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) +* +* Compute factorization in a while loop over NB columns, +* K is the column index in the block A(1:M,1:N). +* + K = 0 + LSTICC = 0 + DONE = .FALSE. +* + DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) + K = K + 1 + I = IOFFSET + K +* + IF( IOFFSET.EQ.0 .AND. K.EQ.1 ) THEN +* +* If we are at the first column of the original whole matrix A. +* + KP = KP1 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + ELSE +* +* Determine the pivot column at K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) at step K. +* + MAXC2NRMK = VN1( KP ) + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + END IF +* +* ================================================================== +* +* Test for the second and third tolerance stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* + K = K - 1 +* + DONE = .TRUE. +* +* Exit the loop +* + EXIT +* + END IF +* +* ================================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) +* 3) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. (Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 4) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL DSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + CALL DSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Apply previous Householder reflectors to column K: +* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T. +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'No transpose', M-I+1, K-1, -ONE, A( I, 1 ), + $ LDA, F( K, 1 ), LDF, ONE, A( I, K ), 1 ) + END IF +* +* Generate elementary reflector H(k) using the column A(I:M,K). +* + IF( I.LT.M ) THEN + CALL DLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) ) + ELSE + TAU( K ) = ZERO + END IF +* + AIK = A( I, K ) + A( I, K ) = ONE +* =============================================================== +* +* Compute the current K-th column of F: +* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K). +* + IF( K.LT.N+NRHS ) THEN + CALL DGEMV( 'Transpose', M-I+1, N+NRHS-K, TAU( K ), + $ A( I, K+1 ), LDA, A( I, K ), 1, ZERO, + $ F( K+1, K ), 1 ) + END IF +* +* 2) Zero out elements above and on the diagonal of the +* column K in matrix F, i.e elements F(1:K,K). +* + DO J = 1, K + F( J, K ) = ZERO + END DO +* +* 3) Incremental updating of the K-th column of F: +* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T +* * A(I:M,K). +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'Transpose', M-I+1, K-1, -TAU( K ), A( I, 1 ), + $ LDA, A( I, K ), 1, ZERO, AUXV( 1 ), 1 ) +* + CALL DGEMV( 'No transpose', N+NRHS, K-1, ONE, + $ F( 1, 1 ), LDF, AUXV( 1 ), 1, ONE, + $ F( 1, K ), 1 ) + END IF +* +* =============================================================== +* +* Update the current I-th row of A: +* A(I,K+1:N) := A(I,K+1:N) - A(I,1:K)*F(K+1:N,1:K)**T. +* + IF( K.LT.N+NRHS ) THEN + CALL DGEMV( 'No transpose', N+NRHS-K, K, -ONE, + $ F( K+1, 1 ), LDF, A( I, 1 ), LDA, ONE, + $ A( I, K+1 ), LDA ) + END IF +* + A( I, K ) = AIK +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < MINMNFACT = min( M-IOFFSET, N ). +* + IF( K.LT.MINMNFACT ) THEN +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* At J-index, we have a difficult column for the +* update of the 2-norm. Save the index of the previous +* difficult column in IWORK(J-1). +* NOTE: ILSTCC > 1, threfore we can use IWORK only +* with N-1 elements, where the elements are +* shifted by 1 to the left. +* + IWORK( J-1 ) = LSTICC +* +* Set the index of the last difficult column LSTICC. +* + LSTICC = J +* + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + END DO +* + END IF +* +* End of while loop. +* + END DO +* +* Now, afler the loop, KB=K is the number of factorized columns, +* I is the number or processed rows. +* + KB = K + I = IOFFSET + KB + KF = IOFFSET + KB +* +* Apply the block reflector to the rest of the matrix, +* if the residual matrix A(I+1:M,KB+1:N+NRHS) exists, +* i.e. when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* A(I+1:M,K+1:N+NRHS) := A(I+1:M,KB+1:N+NRHS) - +* A(I+1:M,1:KB) * F(KB+1:N,1:KB)**T. +* + IF( KB.LT.MINMNUPDT ) THEN +* + CALL DGEMM( 'No transpose', 'Transpose', M-I, N+NRHS-KB, KB, + $ -ONE, A( I+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, + $ A( I+1, KB+1 ), LDA ) + END IF +* +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. +* + DO WHILE( LSTICC.GT.0 ) +* +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. +* + ITEMP = IWORK( LSTICC-1 ) +* +* Compute the 2-norm explicilty for the last difficult column and +* save it in the partial and exact 2-norm vectors VN1 and VN2. +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* DNRM2 does not fail on vectors with norm below the value of +* SQRT(DLAMCH('S')) +* + VN1( LSTICC ) = DNRM2( M-I, A( I+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) +* +* Downdate the index of the last difficult column to +* the index of the previous difficult column. +* + LSTICC = ITEMP + END DO +* +* If done, set TAU(KB+1:MINMNFACT) to ZERO. +* + IF( DONE ) THEN + DO J = KB + 1, MINMNFACT + TAU( J ) = ZERO + END DO + END IF +* + RETURN +* +* End of DLAQP3RK +* + END From 30b43ed625d03f7b895b3fe83f6667643233db99 Mon Sep 17 00:00:00 2001 From: scr2016 Date: Fri, 11 Aug 2023 14:43:09 -0700 Subject: [PATCH 003/106] fixes to implicit declarations --- SRC/dgeqp3rk.f | 4 ++-- SRC/dlaqp2rk.f | 3 ++- SRC/dlaqp3rk.f | 13 ++++++++----- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 7ed64bc3c5..53e18b9197 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -539,9 +539,9 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * .. * .. External Functions .. LOGICAL DISNAN - INTEGER ILAENV + INTEGER IDAMAX, ILAENV DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL DISNAN, DLAMCH, DNRM2, ILAENV + EXTERNAL DISNAN, DLAMCH, DNRM2, IDAMAX, ILAENV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 69671f4a43..9dda39de9c 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -293,7 +293,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - INTEGER ITEMP, J, MINMNFACT, MINMNUPDT, I, K, KP + INTEGER I, ITEMP, J, JMAXC2NRM, K, KP, MINMNFACT, + $ MINMNUPDT DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index c996574bcc..2260a95313 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -19,9 +19,11 @@ * =========== * * SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, RELTOL, -* $ KP0, MAXC2NRM, A, LDA, KB, DONE, -* $ KF, MAXC2NRMK, RELMAXC2NRMK, -* $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) +* LOGICAL DONE +* INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, MAXK, N, +* $ NB, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL * * .. Scalar Arguments .. * LOGICAL DONE @@ -313,7 +315,8 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, * * .. Scalar Arguments .. LOGICAL DONE - INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, N, NB, NRHS + INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, MAXK, N, + $ NB, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL * .. @@ -330,7 +333,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - INTEGER ITEMP, J, K, MINMNFACT, MINMNNRHSFACT, + INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, $ LSTICC, KP, I DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z * .. From af1bb9e4b4f5067aa0c929dc7d9b0d991228bd6f Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 004/106] changed comment in dchkq3 --- TESTING/LIN/dchkq3.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/TESTING/LIN/dchkq3.f b/TESTING/LIN/dchkq3.f index 1fdf07252b..494008fa85 100644 --- a/TESTING/LIN/dchkq3.f +++ b/TESTING/LIN/dchkq3.f @@ -30,7 +30,7 @@ *> *> \verbatim *> -*> DCHKQ3 tests DGEQP3. +*> DCHKQ3 tests DGEQP3. *> \endverbatim * * Arguments: From 706fd1a7f5e9c76c855e624d9340e3ddb6019015 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 005/106] added dgeqp3rk.f dlaqp2rk.f dlaqp3rk.f --- SRC/CMakeLists.txt | 4 +- SRC/Makefile | 4 +- SRC/dgeqp3rk.f | 866 +++++++++++++++++++++++++++++++++++++++++++++ SRC/dlaqp2rk.f | 502 ++++++++++++++++++++++++++ SRC/dlaqp3rk.f | 600 +++++++++++++++++++++++++++++++ 5 files changed, 1972 insertions(+), 4 deletions(-) create mode 100755 SRC/dgeqp3rk.f create mode 100755 SRC/dlaqp2rk.f create mode 100755 SRC/dlaqp3rk.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index a84f784182..f047dc4471 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -287,7 +287,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 dgeqr2.f dgeqr2p.f dgeqrf.f dgeqrfp.f dgerfs.f dgerq2.f dgerqf.f + dgeqp3.f dgeqp3rk.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 @@ -302,7 +302,7 @@ set(DLASRC dlangb.f dlange.f dlangt.f dlanhs.f dlansb.f dlansp.f dlansy.f dlantb.f dlantp.f dlantr.f dlanv2.f dlapll.f dlapmt.f - dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqsb.f dlaqsp.f dlaqsy.f + dlaqgb.f dlaqge.f dlaqp2.f dlaqps.f dlaqp2rk.f dlaqp3rk.f dlaqsb.f dlaqsp.f dlaqsy.f dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f dlarf.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f diff --git a/SRC/Makefile b/SRC/Makefile index 40041b8991..33cec713e4 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -321,7 +321,7 @@ DLASRC = \ dgebrd.o dgecon.o dgeequ.o dgees.o dgeesx.o dgeev.o dgeevx.o \ dgehd2.o dgehrd.o dgelq2.o dgelqf.o \ dgels.o dgelst.o dgelsd.o dgelss.o dgelsy.o dgeql2.o dgeqlf.o \ - dgeqp3.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \ + dgeqp3.o dgeqp3rk.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 \ @@ -336,7 +336,7 @@ DLASRC = \ dlangb.o dlange.o dlangt.o dlanhs.o dlansb.o dlansp.o \ dlansy.o dlantb.o dlantp.o dlantr.o dlanv2.o \ dlapll.o dlapmt.o \ - dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \ + dlaqgb.o dlaqge.o dlaqp2.o dlaqps.o dlaqp2rk.o dlaqp3rk.o dlaqsb.o dlaqsp.o dlaqsy.o \ dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \ dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \ dlarf.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \ diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f new file mode 100755 index 0000000000..7ed64bc3c5 --- /dev/null +++ b/SRC/dgeqp3rk.f @@ -0,0 +1,866 @@ +*> \brief \b DGEQP3RK computes a truncated Householder QR factorization with column pivoting of a real m-by-n matrix A by using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, +* $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, +* $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a real +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is a N-by-N permutation matrix; +*> Q(K) is an M-by-M orthogonal matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a real M-by-NRHS +*> matrix B with Q(K)**T * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter MAXK, the maximum number of columns +*> MAXK to factorize, i.e. the factorization rank is limited +*> to MAXK. If MAXK >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) and +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> For full rank factorization use the values MAXK >= min(M,N), +*> ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_approx); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**T * B, the matrix B with the orthogonal +*> transformation Q(K)**T applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= K, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M orthogonal matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**T, +*> +*> where 1 <= j <= K and +*> I is an M-by_M identity matrix, +*> tau is a real scalar, +*> v is a real vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] MAXK +*> \verbatim +*> MAXK is INTEGER +*> +*> The first factorization stopping criterion. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. MAXK >= 0. +*> +*> a) If MAXK >= min(M,N), then this stopping criterion +*> is not used, factorize columns depending +*> on ABSTOL and RELTOL. +*> +*> b) If MAXK = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, factorize columns depending on MAXK and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> If ABSTOL chosen above is >= abs(R(1,1)), then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after R(1,1) is computed to return it in +*> MAXC2NORMK, also RELMAXC2NORMK is returned as 1.0. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> Here, abs(R(1,1)) is the maximum column 2-norm of the +*> original matrix A; SAFMIN = DLAMCH('S'). +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) and the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, factorize columns depending on MAXK and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after R(1,1) is computed to return it in +*> MAXC2NORMK, also RELMAXC2NORMK is returned as 1.0. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M,N)*EPS, sqrt(EPS)) <= RELTOL +*> +*> Here, EPS = DLAMCH('E'). +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,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(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) The subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**T * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were factorized. +*> K is the factorization rank. +*> 0 <= K <= min( M, min(MAXK,N) ). +*> +*> If K = 0, the arrays A, TAU, JPIV were not modified. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix A22(K), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K would equal +*> R(K+1,K+1) in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix A22(K) (when factorization +*> stopped at rank K) and maximum column 2-norm of the +*> original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= K, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= MIN(M,N), only elements TAU(1:K) of +*> the array TAU may be modified. The elements +*> TAU(K+1:min(M,N)) are set to zero. +*> If K = 0, all elements of TAU are set to zero. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= 3*N+1. +*> For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB +*> is the optimal block size for DGETRF returned by ILAENV. +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine DLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup heqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> DGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in DGEQP3 routine which uses DGEQRF +*> to perform Householder QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE, USETOL + INTEGER IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP0, LWKOPT, MINMN, NA, NB, NBMIN, + $ NX + DOUBLE PRECISION EPS, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL DLAQP2RK, DLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DISNAN, DLAMCH, DNRM2, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE + IWS = 3*N +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) + LWKOPT = 2*N + NB*( 1+N+NRHS ) + END IF + WORK( 1 ) = DBLE( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M, N. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Ajust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', M, N, -1, -1 ) ) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease at each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + WORK( J ) = DNRM2( M, A( 1, J ), 1 ) + WORK( N+J ) = WORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole matrix A(1:M,1:N). +* + KP0 = IDAMAX( N, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP0 ) +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* Quick return if A is a zero matrix. +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* + IF( USETOL ) THEN + K = 0 + ELSE + K = JMAX + END IF +* + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) +* +* Factorize JB columns among the columns A(J:N). +* + CALL DLAQP3RK( M, N-J+1, NRHS, J-1, JB, KMAX, ABSTOL, + $ RELTOL, KP0, MAXC2NRM, A( 1, J ), LDA, JBF, + $ DONE, KF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), + $ N+NRHS-J+1, IWORK ) +* + J = J + JBF +* + IF( DONE ) THEN +* +* ABSTOL or RELTOL criterion is satisfied before the +* end of the column block, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* block factorization routine. +* + K = J - 1 +* +* Exit loop +* + EXIT +* + END IF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of columns, +* That is in ELSE clause we nned to compute the MAXC2NORM and +* RELMAXC2NORM to return after we processed the blocks. +* + IF( .NOT.DONE ) THEN +* + IF( J.LE.JMAX ) THEN +* + CALL DLAQP2RK( M, N-J+1, NRHS, J-1, JMAX-J+1, ABSTOL, + $ RELTOL, KP0, MAXC2NRM, A( 1, J ), LDA, KF, + $ MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ) ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + IDAMAX( N-K, WORK( K+1 ), 1 ) + MAXC2NRMK = WORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = ZERO + END DO + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF +* +* END IF( .NOT.DONE ) THEN +* + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) +* + RETURN +* +* End of DGEQP3RK +* + END diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f new file mode 100755 index 0000000000..69671f4a43 --- /dev/null +++ b/SRC/dlaqp2rk.f @@ -0,0 +1,502 @@ +*> \brief \b DLAQP2RK computes truncated QR factorization with column pivoting of the matrix block using Level 2 BLAS and overwrites m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP0, MAXC2NRM, A, LDA, KF, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) +* +* .. Scalar Arguments .. +* INTEGER IOFFSET, KP0, KF, KMAX, LDA, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of the block A(IOFFSET+1:M,1:N). +*> The routine is calling Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. The routine also +*> overwrites the matrix B block stored in A(IOFFSET+1:M,N+1:N+NRHS) +*> with Q(K)**T * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET also represents the number of +*> columns of the original matrix that have been factorized +*> in the previous steps. +*> IOFFSET >= 0. +*> \endverbatim +*> +*> \param[in] MAXK +*> \verbatim +*> MAXK is INTEGER +*> +*> The first factorization stopping criterion. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. MAXK >= 0. +*> +*> a) If MAXK >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If MAXK = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) and the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. +*> +*> Here, abs(R(1,1)) is the maximum column 2-norm of the +*> original matrix A; EPS = DLAMCH('E'). +*> \endverbatim +*> +*> \param[in] KP0 +*> \verbatim +*> KP0 is INTEGER +*> The index of column with the maximum column 2-norm for +*> the whole original matrix A. KP0 > 0. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original matrix. +*> MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KF) below +*> the diagonal,together with the array TAU, represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The block of the matrix A stored in A(IOFFSET+1:M,1:KF) +*> is the triangular factor obtained. +*> 3. The block of the the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but no factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KF+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KF+1:N) of +*> this block contains the residual of the matrix A, and +*> the right part of the block A(IOFFSET+1:M,N+1:N+NRHS) +*> contains the block of the right-hand-side matrix B. Both +*> these blocks have been updated by multiplication from +*> the left by Q**T. +*> \endverbatim +*> +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] KF +*> \verbatim +*> KF is INTEGER +*> The number of columns actually factorized. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix A22, +*> when factorization stopped. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix A22 ( when factorization +*> stopped) and the maximum column 2-norm of the +*> original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= K, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> Used in DLARF subroutine to apply elementary +*> reflector. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP0, MAXC2NRM, A, LDA, KF, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER IOFFSET, KP0, KF, KMAX, LDA, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, MINMNFACT, MINMNUPDT, I, K, KP + DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KMAX = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) +* +* Compute factorization. +* + DO K = 1, KMAX +* + I = IOFFSET + K +* + IF( IOFFSET.EQ.0 .AND. K.EQ.1 ) THEN +* +* If we are at the first column of the original whole matrix A. +* + KP = KP0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + ELSE +* +* Determine the pivot column at K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) at step K. +* + MAXC2NRMK = VN1( KP ) + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + END IF +* +* ================================================================== +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* + + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Exit the loop +* + EXIT + END IF +* +* ================================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL DSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Generate elementary reflector H(K) using the column A(I:M,K), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(K) = ZERO. +* + IF( K.LT.M ) THEN + CALL DLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, + $ TAU( K ) ) + ELSE + TAU( K ) = ZERO + END IF +* +* Apply H(K)**T to A(I:M,K+1:N+NRHS) from the left. +* ( If M >= N, then at K = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B ) +* If M < N, then at K = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(K) = ZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* K < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only K < N+NRHS ) +* + IF( K.LT.MINMNUPDT ) THEN + AIK = A( I, K ) + A( I, K ) = ONE + CALL DLARF( 'Left', M-I+1, N+NRHS-K, A( I, K ), 1, + $ TAU( K ), A( I, K+1 ), LDA, WORK( 1 ) ) + A( I, K ) = AIK + END IF +* + IF( K.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < min(M-IOFFSET, N). +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = DNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* Set the number of factorized columns +* + KF = K - 1 +* + IF( KF.EQ.KMAX ) THEN +* +* All KMAX columns were factorized, no ABSTOL or RELTOL triggered. +* + + IF( KF.LT.MINMNFACT ) THEN + JMAXC2NRM = KF + IDAMAX( N-KF, VN1( KF+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( KF.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* + +* + END IF +* +* Set TAU(KF+1:MINMN) to ZERO. +* + DO J = KF + 1, MINMNFACT + TAU( J ) = ZERO + END DO +* + RETURN +* +* End of DLAQP2RK +* + END diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f new file mode 100755 index 0000000000..c996574bcc --- /dev/null +++ b/SRC/dlaqp3rk.f @@ -0,0 +1,600 @@ +*> \brief \b DLAQP3RK computes a step of truncated QR factorization with column pivoting of a real m-by-n matrix A using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DLAQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, RELTOL, +* $ KP0, MAXC2NRM, A, LDA, KB, DONE, +* $ KF, MAXC2NRMK, RELMAXC2NRMK, +* $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) +* +* .. Scalar Arguments .. +* LOGICAL DONE +* INTEGER KB, LDA, LDF, M, N, NB, NRHS, IOFFSET +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), +* $ VN1( * ), VN2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQP3RK computes a step of truncated QR factorization with column +*> pivoting of a real M-by-N matrix A by using Level 3 BLAS. The routine +*> tries to factorize NB columns from A starting from the row IOFFSET+1, +*> and updates all of the matrix with BLAS 3 xGEMM, the number of accually +*> factorized columns is returned in KB, KB <= NB. +*> +*> Cases when the number of factorized columns KB < NB: +*> +*> (1) In some cases, due to catastrophic cancellations, it cannot +*> factorize NB columns. Hence, the actual number of factorized +*> columns is returned in KB. +*> +*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, +*> the factorization is stopped, the logical DONE is returned +*> as TRUE. The number of factorized columns which is smaller than NB +*> returned in KB. +*> +*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides B block stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(K)**T * B. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but no factorized. IOFFSET >= 0. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> The number of columns to factorize. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) and the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. +*> +*> Here, abs(R(1,1)) is the maximum column 2-norm of the +*> original matrix A; EPS = DLAMCH('E'). +*> \endverbatim +*> +*> \param[in] KP0 +*> \verbatim +*> KP0 is INTEGER +*> The index of column with the maximum column 2-norm for +*> the whole original matrix A. KP0 > 0. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original matrix. +*> MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KB) below +*> the diagonal,together with the array TAU, represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The block of the matrix A stored in A(IOFFSET+1:M,1:KB) +*> is the triangular factor obtained. +*> 3. The block of the the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but no factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KB+1:N) of +*> this block contains the residual of the matrix A, and +*> the right part of the block A(IOFFSET+1:M,N+1:N+NRHS) +*> contains the block of the right-hand-side matrix B. Both +*> these blocks have been updated by multiplication from +*> the left by Q**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns actually factorized. +*> \endverbatim +*> +*> \param[out] +*> +*> \verbatim +*> DONE is LOGICAL +*> TRUE, if the factorization completed, +*> FALSE, otherwise. +*> \endverbatim +*> +*> \param[out] KF +*> \verbatim +*> KF is INTEGER +*> The number of columns of the original whole matrix A +*> factorized. +*> \endverbatim +* +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix A22(K), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> ( Rank K is with respect to the original matrix A ) +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix A22, +*> when factorization stopped. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix A22 ( when factorization +*> stopped) and the maximum column 2-norm of the +*> original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (NB) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] AUXV +*> \verbatim +*> AUXV is DOUBLE PRECISION array, dimension (NB) +*> Auxiliary vector. +*> \endverbatim +*> +*> \param[out] F +*> \verbatim +*> F is DOUBLE PRECISION array, dimension (LDF,NB) +*> Matrix F**T = L*Y**T*A. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1,N+NRHS). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp3rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A, LDA, KB, DONE, + $ KF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) +* +* -- LAPACK auxiliary 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 DONE + INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, N, NB, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, MINMNFACT, MINMNNRHSFACT, + $ LSTICC, KP, I + DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) +* +* Compute factorization in a while loop over NB columns, +* K is the column index in the block A(1:M,1:N). +* + K = 0 + LSTICC = 0 + DONE = .FALSE. +* + DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) + K = K + 1 + I = IOFFSET + K +* + IF( IOFFSET.EQ.0 .AND. K.EQ.1 ) THEN +* +* If we are at the first column of the original whole matrix A. +* + KP = KP1 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + ELSE +* +* Determine the pivot column at K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) at step K. +* + MAXC2NRMK = VN1( KP ) + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + END IF +* +* ================================================================== +* +* Test for the second and third tolerance stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* + K = K - 1 +* + DONE = .TRUE. +* +* Exit the loop +* + EXIT +* + END IF +* +* ================================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) +* 3) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. (Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 4) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL DSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + CALL DSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Apply previous Householder reflectors to column K: +* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T. +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'No transpose', M-I+1, K-1, -ONE, A( I, 1 ), + $ LDA, F( K, 1 ), LDF, ONE, A( I, K ), 1 ) + END IF +* +* Generate elementary reflector H(k) using the column A(I:M,K). +* + IF( I.LT.M ) THEN + CALL DLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) ) + ELSE + TAU( K ) = ZERO + END IF +* + AIK = A( I, K ) + A( I, K ) = ONE +* =============================================================== +* +* Compute the current K-th column of F: +* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K). +* + IF( K.LT.N+NRHS ) THEN + CALL DGEMV( 'Transpose', M-I+1, N+NRHS-K, TAU( K ), + $ A( I, K+1 ), LDA, A( I, K ), 1, ZERO, + $ F( K+1, K ), 1 ) + END IF +* +* 2) Zero out elements above and on the diagonal of the +* column K in matrix F, i.e elements F(1:K,K). +* + DO J = 1, K + F( J, K ) = ZERO + END DO +* +* 3) Incremental updating of the K-th column of F: +* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T +* * A(I:M,K). +* + IF( K.GT.1 ) THEN + CALL DGEMV( 'Transpose', M-I+1, K-1, -TAU( K ), A( I, 1 ), + $ LDA, A( I, K ), 1, ZERO, AUXV( 1 ), 1 ) +* + CALL DGEMV( 'No transpose', N+NRHS, K-1, ONE, + $ F( 1, 1 ), LDF, AUXV( 1 ), 1, ONE, + $ F( 1, K ), 1 ) + END IF +* +* =============================================================== +* +* Update the current I-th row of A: +* A(I,K+1:N) := A(I,K+1:N) - A(I,1:K)*F(K+1:N,1:K)**T. +* + IF( K.LT.N+NRHS ) THEN + CALL DGEMV( 'No transpose', N+NRHS-K, K, -ONE, + $ F( K+1, 1 ), LDF, A( I, 1 ), LDA, ONE, + $ A( I, K+1 ), LDA ) + END IF +* + A( I, K ) = AIK +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < MINMNFACT = min( M-IOFFSET, N ). +* + IF( K.LT.MINMNFACT ) THEN +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* At J-index, we have a difficult column for the +* update of the 2-norm. Save the index of the previous +* difficult column in IWORK(J-1). +* NOTE: ILSTCC > 1, threfore we can use IWORK only +* with N-1 elements, where the elements are +* shifted by 1 to the left. +* + IWORK( J-1 ) = LSTICC +* +* Set the index of the last difficult column LSTICC. +* + LSTICC = J +* + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + END DO +* + END IF +* +* End of while loop. +* + END DO +* +* Now, afler the loop, KB=K is the number of factorized columns, +* I is the number or processed rows. +* + KB = K + I = IOFFSET + KB + KF = IOFFSET + KB +* +* Apply the block reflector to the rest of the matrix, +* if the residual matrix A(I+1:M,KB+1:N+NRHS) exists, +* i.e. when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* A(I+1:M,K+1:N+NRHS) := A(I+1:M,KB+1:N+NRHS) - +* A(I+1:M,1:KB) * F(KB+1:N,1:KB)**T. +* + IF( KB.LT.MINMNUPDT ) THEN +* + CALL DGEMM( 'No transpose', 'Transpose', M-I, N+NRHS-KB, KB, + $ -ONE, A( I+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, + $ A( I+1, KB+1 ), LDA ) + END IF +* +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. +* + DO WHILE( LSTICC.GT.0 ) +* +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. +* + ITEMP = IWORK( LSTICC-1 ) +* +* Compute the 2-norm explicilty for the last difficult column and +* save it in the partial and exact 2-norm vectors VN1 and VN2. +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* DNRM2 does not fail on vectors with norm below the value of +* SQRT(DLAMCH('S')) +* + VN1( LSTICC ) = DNRM2( M-I, A( I+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) +* +* Downdate the index of the last difficult column to +* the index of the previous difficult column. +* + LSTICC = ITEMP + END DO +* +* If done, set TAU(KB+1:MINMNFACT) to ZERO. +* + IF( DONE ) THEN + DO J = KB + 1, MINMNFACT + TAU( J ) = ZERO + END DO + END IF +* + RETURN +* +* End of DLAQP3RK +* + END From f238faeafb27a691a2cd35729eafb8408c5b2105 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 006/106] fixes to implicit declarations --- SRC/dgeqp3rk.f | 4 ++-- SRC/dlaqp2rk.f | 3 ++- SRC/dlaqp3rk.f | 13 ++++++++----- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 7ed64bc3c5..53e18b9197 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -539,9 +539,9 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * .. * .. External Functions .. LOGICAL DISNAN - INTEGER ILAENV + INTEGER IDAMAX, ILAENV DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL DISNAN, DLAMCH, DNRM2, ILAENV + EXTERNAL DISNAN, DLAMCH, DNRM2, IDAMAX, ILAENV * .. * .. Intrinsic Functions .. INTRINSIC DBLE, MAX, MIN diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 69671f4a43..9dda39de9c 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -293,7 +293,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - INTEGER ITEMP, J, MINMNFACT, MINMNUPDT, I, K, KP + INTEGER I, ITEMP, J, JMAXC2NRM, K, KP, MINMNFACT, + $ MINMNUPDT DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index c996574bcc..2260a95313 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -19,9 +19,11 @@ * =========== * * SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, RELTOL, -* $ KP0, MAXC2NRM, A, LDA, KB, DONE, -* $ KF, MAXC2NRMK, RELMAXC2NRMK, -* $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) +* LOGICAL DONE +* INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, MAXK, N, +* $ NB, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL * * .. Scalar Arguments .. * LOGICAL DONE @@ -313,7 +315,8 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, * * .. Scalar Arguments .. LOGICAL DONE - INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, N, NB, NRHS + INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, MAXK, N, + $ NB, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL * .. @@ -330,7 +333,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - INTEGER ITEMP, J, K, MINMNFACT, MINMNNRHSFACT, + INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, $ LSTICC, KP, I DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z * .. From ba5afcdadb7b1c2eb8cab4d005155cd5005f0cc5 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 007/106] modified comments in TESTING/LIN/alareq.f TESTING/EIG/alareq.f TESTING/EIG/alarqg.f --- TESTING/EIG/alareq.f | 6 +++--- TESTING/EIG/alarqg.f | 6 +++--- TESTING/LIN/alareq.f | 6 +++--- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/TESTING/EIG/alareq.f b/TESTING/EIG/alareq.f index 2585a686a0..2cbe6db382 100644 --- a/TESTING/EIG/alareq.f +++ b/TESTING/EIG/alareq.f @@ -28,12 +28,12 @@ *> to evaluate the input line which requested NMATS matrix types for *> PATH. The flow of control is as follows: *> -*> If NMATS = NTYPES then +*> IF NMATS = NTYPES THEN *> DOTYPE(1:NTYPES) = .TRUE. -*> else +*> ELSE *> Read the next input line for NMATS matrix types *> Set DOTYPE(I) = .TRUE. for each valid type I -*> endif +*> END IF *> \endverbatim * * Arguments: diff --git a/TESTING/EIG/alarqg.f b/TESTING/EIG/alarqg.f index 6e2e6e7ecf..b9fb88c651 100644 --- a/TESTING/EIG/alarqg.f +++ b/TESTING/EIG/alarqg.f @@ -28,12 +28,12 @@ *> to evaluate the input line which requested NMATS matrix types for *> PATH. The flow of control is as follows: *> -*> If NMATS = NTYPES then +*> IF NMATS = NTYPES THEN *> DOTYPE(1:NTYPES) = .TRUE. -*> else +*> ELSE *> Read the next input line for NMATS matrix types *> Set DOTYPE(I) = .TRUE. for each valid type I -*> endif +*> END IF *> \endverbatim * * Arguments: diff --git a/TESTING/LIN/alareq.f b/TESTING/LIN/alareq.f index db18775ebc..3f057fa486 100644 --- a/TESTING/LIN/alareq.f +++ b/TESTING/LIN/alareq.f @@ -28,12 +28,12 @@ *> to evaluate the input line which requested NMATS matrix types for *> PATH. The flow of control is as follows: *> -*> If NMATS = NTYPES then +*> IF NMATS = NTYPES THEN *> DOTYPE(1:NTYPES) = .TRUE. -*> else +*> ELSE *> Read the next input line for NMATS matrix types *> Set DOTYPE(I) = .TRUE. for each valid type I -*> endif +*> END IF *> \endverbatim * * Arguments: From dd4c896894f8180b4cf229bba93b2cb7e1369d5c Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 008/106] added IMPLCIT NONE to dgeqp3rk.f dlaqp2rk.f dlaqp3rk.f and fixed comments in dlaqp3rk.f --- SRC/dgeqp3rk.f | 2 ++ SRC/dlaqp2rk.f | 2 ++ SRC/dlaqp3rk.f | 7 ++++++- 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 53e18b9197..140f25a096 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -21,6 +21,7 @@ * SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, * $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, * $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) +* IMPLICIT NONE * * .. Scalar Arguments .. * INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS @@ -505,6 +506,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 9dda39de9c..89a444a80f 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -21,6 +21,7 @@ * SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * $ KP0, MAXC2NRM, A, LDA, KF, MAXC2NRMK, * $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) +* IMPLICIT NONE * * .. Scalar Arguments .. * INTEGER IOFFSET, KP0, KF, KMAX, LDA, M, N, NRHS @@ -270,6 +271,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, $ KP0, MAXC2NRM, A, LDA, KF, MAXC2NRMK, $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 2260a95313..eeddc21b9a 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -18,7 +18,11 @@ * Definition: * =========== * -* SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, RELTOL, +* SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, +* $ RELTOL, KP1, MAXC2NRM, A, LDA, KB, DONE, +* $ KF, MAXC2NRMK, RELMAXC2NRMK, +* $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) +* IMPLICIT NONE * LOGICAL DONE * INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, MAXK, N, * $ NB, NRHS @@ -308,6 +312,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A, LDA, KB, DONE, $ KF, MAXC2NRMK, RELMAXC2NRMK, $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- From 6e9d74860c8464a204b88c87a795e3d4e05df743 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 009/106] Changed KP0 to KP1 in dgeqp3rk.f dlaqp2rk.f dlaqp3rk.f --- SRC/dgeqp3rk.f | 12 ++++++------ SRC/dlaqp2rk.f | 18 +++++++++--------- SRC/dlaqp3rk.f | 8 ++++---- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 140f25a096..23909c3ea9 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -532,7 +532,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * .. Local Scalars .. LOGICAL LQUERY, DONE, USETOL INTEGER IWS, J, JB, JBF, JMAXB, JMAX, - $ JMAXC2NRM, KP0, LWKOPT, MINMN, NA, NB, NBMIN, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, NA, NB, NBMIN, $ NX DOUBLE PRECISION EPS, MAXC2NRM, SAFMIN * .. @@ -700,10 +700,10 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * ================================================================== * * Compute the pivot column index and the maximum column 2-norm -* for the whole matrix A(1:M,1:N). +* for the whole original matrix stored in A(1:M,1:N). * - KP0 = IDAMAX( N, WORK( 1 ), 1 ) - MAXC2NRM = WORK( KP0 ) + KP1 = IDAMAX( N, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP1 ) * * JMAX is the maximum index of the column to be factorized, * which is also limited by the first stopping criterion KMAX. @@ -764,7 +764,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * Factorize JB columns among the columns A(J:N). * CALL DLAQP3RK( M, N-J+1, NRHS, J-1, JB, KMAX, ABSTOL, - $ RELTOL, KP0, MAXC2NRM, A( 1, J ), LDA, JBF, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, JBF, $ DONE, KF, MAXC2NRMK, RELMAXC2NRMK, $ JPIV( J ), TAU( J ), $ WORK( J ), WORK( N+J ), @@ -804,7 +804,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, IF( J.LE.JMAX ) THEN * CALL DLAQP2RK( M, N-J+1, NRHS, J-1, JMAX-J+1, ABSTOL, - $ RELTOL, KP0, MAXC2NRM, A( 1, J ), LDA, KF, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, KF, $ MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), $ TAU( J ), WORK( J ), WORK( N+J ), $ WORK( 2*N+1 ) ) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 89a444a80f..b51d95ae60 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -19,12 +19,12 @@ * =========== * * SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, -* $ KP0, MAXC2NRM, A, LDA, KF, MAXC2NRMK, +* $ KP1, MAXC2NRM, A, LDA, KF, MAXC2NRMK, * $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) * IMPLICIT NONE * * .. Scalar Arguments .. -* INTEGER IOFFSET, KP0, KF, KMAX, LDA, M, N, NRHS +* INTEGER IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, * $ RELTOL * .. @@ -130,11 +130,11 @@ *> original matrix A; EPS = DLAMCH('E'). *> \endverbatim *> -*> \param[in] KP0 +*> \param[in] KP1 *> \verbatim -*> KP0 is INTEGER -*> The index of column with the maximum column 2-norm for -*> the whole original matrix A. KP0 > 0. +*> KP1 is INTEGER +*> The index of the column with the maximum column 2-norm in +*> the whole original matrix A. KP1 > 0. *> \endverbatim *> *> \param[in] MAXC2NRM @@ -269,7 +269,7 @@ * * ===================================================================== SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, - $ KP0, MAXC2NRM, A, LDA, KF, MAXC2NRMK, + $ KP1, MAXC2NRM, A, LDA, KF, MAXC2NRMK, $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) IMPLICIT NONE * @@ -278,7 +278,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. - INTEGER IOFFSET, KP0, KF, KMAX, LDA, M, N, NRHS + INTEGER IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL * .. @@ -330,7 +330,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * If we are at the first column of the original whole matrix A. * - KP = KP0 + KP = KP1 MAXC2NRMK = MAXC2NRM RELMAXC2NRMK = ONE * diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index eeddc21b9a..94186c5cfe 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -136,11 +136,11 @@ *> original matrix A; EPS = DLAMCH('E'). *> \endverbatim *> -*> \param[in] KP0 +*> \param[in] KP1 *> \verbatim -*> KP0 is INTEGER -*> The index of column with the maximum column 2-norm for -*> the whole original matrix A. KP0 > 0. +*> KP1 is INTEGER +*> The index of the column with the maximum column 2-norm in +*> the whole original matrix A. KP1 > 0. *> \endverbatim *> *> \param[in] MAXC2NRM From e8517680f9b35750395219c325e57ba5d94e7de2 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 010/106] changed order of code blocks at the beginning in dgeqp3rk.f and added comments at the end of dlaqp2rk.f about setting MAXC2NRMK, RELMAXC2NRMK and TAU --- SRC/dgeqp3rk.f | 84 ++++++++++++++++++++++++++------------------------ SRC/dlaqp2rk.f | 18 ++++++----- 2 files changed, 53 insertions(+), 49 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 23909c3ea9..0c4e80d3e8 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -622,6 +622,14 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, END IF * * ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* +* ================================================================== * EPS = DLAMCH('Epsilon') * @@ -635,7 +643,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, USETOL = .TRUE. END IF * -* Ajust RELTOL +* Adjust RELTOL * IF( RELTOL.GE.ZERO ) THEN RELTOL = MAX( RELTOL, EPS ) @@ -643,46 +651,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, END IF * * ================================================================== -* Factorize columns -* ================================================================== -* -* Determine the block size. -* - NBMIN = 2 - NX = 0 -* - IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* (for N less than NX, unblocked code should be used). -* - NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', M, N, -1, -1 ) ) -* - IF( NX.LT.MINMN ) THEN -* -* Determine if workspace is large enough for blocked code. -* - IF( LWORK.LT.LWKOPT ) THEN -* -* Not enough workspace to use optimal block size that -* is currently stored in NB. -* Reduce NB and determine the minimum value of NB. -* - NB = ( LWORK-2*N ) / ( N+1 ) - NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', M, N, - $ -1, -1 ) ) -* - END IF - END IF - END IF -* ================================================================== -* -* Initialize column pivot array JPIV. -* - DO J = 1, N - JPIV( J ) = J - END DO -* ================================================================== * * Initialize storage for partial and exact column 2-norms. * a) The elements WORK(1:N) are used to store partial column @@ -732,6 +700,40 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, END IF * * ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', M, N, -1, -1 ) ) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* +* ================================================================== * DONE = .FALSE. * diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index b51d95ae60..c9815b953d 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -353,15 +353,15 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * ================================================================== * * Test for the second and third stopping criteria. -* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* NOTE: There is no need to test for ABSTOL >= ZERO, since * MAXC2NRMK is non-negative. Similarly, there is no need -* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is * non-negative. * IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN * -* Exit the loop +* Exit the loop. * EXIT END IF @@ -470,10 +470,11 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * IF( KF.EQ.KMAX ) THEN * -* All KMAX columns were factorized, no ABSTOL or RELTOL triggered. +* All KMAX columns were factorized, no ABSTOL or RELTOL triggered, +* we need to set MAXC2NRMK and RELMAXC2NRMK before we return. * - IF( KF.LT.MINMNFACT ) THEN +* JMAXC2NRM = KF + IDAMAX( N-KF, VN1( KF+1 ), 1 ) MAXC2NRMK = VN1( JMAXC2NRM ) * @@ -487,12 +488,13 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO END IF -* - * END IF * -* Set TAU(KF+1:MINMN) to ZERO. +* Before we return because either we reached the end of the +* loop KMAX, or ABSTOL or RELTOL was triggered, we need to: +* set TAUs corresponding to the columns that were not factorized +* to ZERO, i.e. TAU(KF+1:MINMN) set to ZERO. * DO J = KF + 1, MINMNFACT TAU( J ) = ZERO From f5a907d796b57c5bb036160845315ee3c919cf47 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 011/106] changed comments for JPIV in dgeqp3rk.f dlaqp2rk.f dlaqp3rk.f --- SRC/dgeqp3rk.f | 4 ++-- SRC/dlaqp2rk.f | 2 +- SRC/dlaqp3rk.f | 7 +++++++ 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 0c4e80d3e8..b6e9c7db75 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -122,7 +122,7 @@ *> transformation Q(K)**T applied on the left. *> *> The N-by-N permutation matrix P(K) is stored in a compact form in -*> the integer array JPIV. For 1 <= j <= K, column j +*> the integer array JPIV. For 1 <= j <= N, column j *> of the matrix A was interchanged with column JPIV(j). *> *> The M-by-M orthogonal matrix Q is represented as a product @@ -375,7 +375,7 @@ *> \param[out] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N) -*> Column pivot indices, for 1 <= j <= K, column j +*> Column pivot indices. For 1 <= j <= N, column j *> of the matrix A was interchanged with column JPIV(j). *> \endverbatim *> diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index c9815b953d..4850c46998 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -203,7 +203,7 @@ *> \param[out] JPIV *> \verbatim *> JPIV is INTEGER array, dimension (N) -*> Column pivot indices, for 1 <= j <= K, column j +*> Column pivot indices, for 1 <= j <= N, column j *> of the matrix A was interchanged with column JPIV(j). *> \endverbatim *> diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 94186c5cfe..b9c17415e9 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -228,6 +228,13 @@ *> original matrix A. RELMAXC2NRMK >= 0. *> \endverbatim *> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> *> \param[out] TAU *> \verbatim *> TAU is DOUBLE PRECISION array, dimension (NB) From 614452f28e803463877fe28e81afa63c362c0420 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 012/106] changed KMAX into MAXK in dlaqp2rk.f, dgeqp3rk.f --- SRC/dgeqp3rk.f | 22 +++++++++++----------- SRC/dlaqp2rk.f | 18 +++++++++--------- 2 files changed, 20 insertions(+), 20 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index b6e9c7db75..acfd44d9d9 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -24,7 +24,7 @@ * IMPLICIT NONE * * .. Scalar Arguments .. -* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* INTEGER INFO, K, MAXK, LDA, LWORK, M, N, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL * .. * .. Array Arguments .. @@ -503,7 +503,7 @@ *> \endhtmlonly * * ===================================================================== - SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) IMPLICIT NONE @@ -513,7 +513,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. - INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS + INTEGER INFO, K, KF, MAXK, LDA, LWORK, M, N, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL * .. * .. Array Arguments .. @@ -561,7 +561,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 - ELSE IF( KMAX.LT.0 ) THEN + ELSE IF( MAXK.LT.0 ) THEN INFO = -4 ELSE IF( DISNAN( ABSTOL ) ) THEN INFO = -5 @@ -571,7 +571,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, INFO = -8 END IF * -* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* If the input parameters M, N, NRHS, MAXK, LDA are valid: * a) Test the input workspace size LWORK for the minimum * size requirement IWS. * b) Determine the optimal block size NB and optimal @@ -602,7 +602,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, END IF * * NOTE: The optimal workspace size is returned in WORK(1), if -* the input parameters M, N, NRHS, KMAX, LDA are valid. +* the input parameters M, N, NRHS, MAXK, LDA are valid. * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQP3RK', -INFO ) @@ -674,9 +674,9 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, MAXC2NRM = WORK( KP1 ) * * JMAX is the maximum index of the column to be factorized, -* which is also limited by the first stopping criterion KMAX. +* which is also limited by the first stopping criterion MAXK. * - JMAX = MIN( KMAX, MINMN ) + JMAX = MIN( MAXK, MINMN ) * * Quick return if A is a zero matrix. * @@ -745,9 +745,9 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * * JMAXB is the maximum column index of the block, when the * blocked code is used, is also limited by the first stopping -* criterion KMAX. +* criterion MAXK. * - JMAXB = MIN( KMAX, MINMN - NX ) + JMAXB = MIN( MAXK, MINMN - NX ) * IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN * @@ -765,7 +765,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * * Factorize JB columns among the columns A(J:N). * - CALL DLAQP3RK( M, N-J+1, NRHS, J-1, JB, KMAX, ABSTOL, + CALL DLAQP3RK( M, N-J+1, NRHS, J-1, JB, MAXK, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, JBF, $ DONE, KF, MAXC2NRMK, RELMAXC2NRMK, $ JPIV( J ), TAU( J ), diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 4850c46998..b715a7276b 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -18,13 +18,13 @@ * Definition: * =========== * -* SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, * $ KP1, MAXC2NRM, A, LDA, KF, MAXC2NRMK, * $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) * IMPLICIT NONE * * .. Scalar Arguments .. -* INTEGER IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS +* INTEGER IOFFSET, KP1, KF, MAXK, LDA, M, N, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, * $ RELTOL * .. @@ -268,7 +268,7 @@ *> \endhtmlonly * * ===================================================================== - SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, $ KP1, MAXC2NRM, A, LDA, KF, MAXC2NRMK, $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) IMPLICIT NONE @@ -278,7 +278,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. - INTEGER IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS + INTEGER IOFFSET, KP1, KF, MAXK, LDA, M, N, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL * .. @@ -317,12 +317,12 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * MINMNFACT = MIN( M-IOFFSET, N ) MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) - KMAX = MIN( KMAX, MINMNFACT ) + MAXK = MIN( MAXK, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) * * Compute factorization. * - DO K = 1, KMAX + DO K = 1, MAXK * I = IOFFSET + K * @@ -468,9 +468,9 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * KF = K - 1 * - IF( KF.EQ.KMAX ) THEN + IF( KF.EQ.MAXK ) THEN * -* All KMAX columns were factorized, no ABSTOL or RELTOL triggered, +* All MAXK columns were factorized, no ABSTOL or RELTOL triggered, * we need to set MAXC2NRMK and RELMAXC2NRMK before we return. * IF( KF.LT.MINMNFACT ) THEN @@ -492,7 +492,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, END IF * * Before we return because either we reached the end of the -* loop KMAX, or ABSTOL or RELTOL was triggered, we need to: +* loop MAXK, or ABSTOL or RELTOL was triggered, we need to: * set TAUs corresponding to the columns that were not factorized * to ZERO, i.e. TAU(KF+1:MINMN) set to ZERO. * From 1287f67c9e9a059ea4f2a6f11ecc83e23f993aae Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 013/106] added quick return if possible for MAXK = 0 in dgeqp3rk.f --- SRC/dgeqp3rk.f | 59 +++++++++++++++++++++++++++++++++----------------- 1 file changed, 39 insertions(+), 20 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index acfd44d9d9..52526029a5 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -630,6 +630,42 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, END DO * * ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease at each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + WORK( J ) = DNRM2( M, A( 1, J ), 1 ) + WORK( N+J ) = WORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole original matrix stored in A(1:M,1:N). +* + KP1 = IDAMAX( N, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP1 ) +* +* Quick return, if MAXK = 0. +* + IF( MAXK.EQ.0 ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = ZERO + END DO + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== * EPS = DLAMCH('Epsilon') * @@ -650,35 +686,18 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, USETOL = .TRUE. END IF * -* ================================================================== +* =================================================================== * -* Initialize storage for partial and exact column 2-norms. -* a) The elements WORK(1:N) are used to store partial column -* 2-norms of the matrix A, and may decrease at each computation -* step; initialize to the values of complete columns 2-norms. -* b) The elements WORK(N+1:2*N) are used to store complete column -* 2-norms of the matrix A, they are not changed during the -* computation; initialize the values of complete columns 2-norms. -* - DO J = 1, N - WORK( J ) = DNRM2( M, A( 1, J ), 1 ) - WORK( N+J ) = WORK( J ) - END DO * -* ================================================================== -* -* Compute the pivot column index and the maximum column 2-norm -* for the whole original matrix stored in A(1:M,1:N). * - KP1 = IDAMAX( N, WORK( 1 ), 1 ) - MAXC2NRM = WORK( KP1 ) +* =================================================================== * * JMAX is the maximum index of the column to be factorized, * which is also limited by the first stopping criterion MAXK. * JMAX = MIN( MAXK, MINMN ) * -* Quick return if A is a zero matrix. +* Quick return, if A is a zero matrix. * IF( MAXC2NRM.EQ.ZERO ) THEN * From f8edd871896b7cbeee9b87f191da1877c5809c02 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 014/106] added quick return if possible at the beginning for 1) MAXK = 0; 2) ABSTOL and RELTOL criteria satisfaction for the whole original matrix A --- SRC/dgeqp3rk.f | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 52526029a5..90c14c0ad0 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -611,7 +611,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, RETURN END IF * -* Quick return if possible for M, N. +* Quick return if possible for M=0 or N=0. * IF( MINMN.EQ.0 ) THEN K = 0 @@ -652,7 +652,8 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, KP1 = IDAMAX( N, WORK( 1 ), 1 ) MAXC2NRM = WORK( KP1 ) * -* Quick return, if MAXK = 0. +* Quick return if possible for the case when the first +* stopping criterion is satisfied, i.e. MAXK = 0. * IF( MAXK.EQ.0 ) THEN K = 0 @@ -688,10 +689,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, * * =================================================================== * -* -* -* =================================================================== -* * JMAX is the maximum index of the column to be factorized, * which is also limited by the first stopping criterion MAXK. * @@ -718,6 +715,23 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, RETURN END IF * +* =================================================================== +* +* Quick return if possible for the case when the second or third +* stopping criterion is satified, i.e. MAXC2NRMK <= ABSTOL OR +* RELMAXC2NRMK <= RELTOL. +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = ZERO + END DO + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* * ================================================================== * Factorize columns * ================================================================== From 8d5c716a6403a21b7f670b6a119816cdc108ed8e Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 015/106] fixe the comment in dgeqp3rk.f and changed design in dlaqp2rk.f to return from the loop instead of exiting the loop when ABSTOL or RELTOL criterion is satisfied --- SRC/dgeqp3rk.f | 2 ++ SRC/dlaqp2rk.f | 60 +++++++++++++++++++++++++++++--------------------- 2 files changed, 37 insertions(+), 25 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 90c14c0ad0..e615866c7d 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -693,6 +693,8 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, * which is also limited by the first stopping criterion MAXK. * JMAX = MIN( MAXK, MINMN ) + +* =================================================================== * * Quick return, if A is a zero matrix. * diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index b715a7276b..4ec5c590c2 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -171,7 +171,6 @@ *> the left by Q**T. *> \endverbatim *> -*> *> \param[in] LDA *> \verbatim *> LDA is INTEGER @@ -314,13 +313,18 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, * * MINMNFACT in the smallest dimension of the submatrix * A(IOFFSET+1:M,1:N) to be factorized. +* +* MINMNUPDT is the smallest dimension +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which contains +* the submatrices A(IOFFSET+1:M,1:N) and B(IOFFSET+1:M,1:NRHS) as column +* blocks. * MINMNFACT = MIN( M-IOFFSET, N ) MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) MAXK = MIN( MAXK, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) * -* Compute factorization. +* Compute the factorization. * DO K = 1, MAXK * @@ -358,12 +362,22 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, * to test for RELTOL >= ZERO, since RELMAXC2NRMK is * non-negative. * - IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN * -* Exit the loop. +* Set the number of factorized columns. +* + KF = K - 1 +* +* Set TAUs corresponding to the columns that were not factorized +* to ZERO, i.e. TAU(KF+1:MINMNFACT)=TAU(K:MINMNFACT) set to ZERO. +* + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. * - EXIT + RETURN END IF * * ================================================================== @@ -466,35 +480,31 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, * * Set the number of factorized columns * - KF = K - 1 -* - IF( KF.EQ.MAXK ) THEN + KF = MAXK * -* All MAXK columns were factorized, no ABSTOL or RELTOL triggered, -* we need to set MAXC2NRMK and RELMAXC2NRMK before we return. +* We reached the end of the loop, i.e. all MAXK columns were +* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before +* we return. * - IF( KF.LT.MINMNFACT ) THEN + IF( KF.LT.MINMNFACT ) THEN * - JMAXC2NRM = KF + IDAMAX( N-KF, VN1( KF+1 ), 1 ) - MAXC2NRMK = VN1( JMAXC2NRM ) -* - IF( KF.EQ.0 ) THEN - RELMAXC2NRMK = ONE - ELSE - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM - END IF + JMAXC2NRM = KF + IDAMAX( N-KF, VN1( KF+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) * + IF( KF.EQ.0 ) THEN + RELMAXC2NRMK = ONE ELSE - MAXC2NRMK = ZERO - RELMAXC2NRMK = ZERO + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM END IF * + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO END IF * -* Before we return because either we reached the end of the -* loop MAXK, or ABSTOL or RELTOL was triggered, we need to: -* set TAUs corresponding to the columns that were not factorized -* to ZERO, i.e. TAU(KF+1:MINMN) set to ZERO. +* We reached the end of the loop, i.e. all MAXK columns were +* factorized, set TAUs corresponding to the columns that were +* not factorized to ZERO, i.e. TAU(KF+1:MINMNFACT) set to ZERO. * DO J = KF + 1, MINMNFACT TAU( J ) = ZERO From f0b12a21934f8e518bb54cac4594d67bcb2c55cb Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:05 -0800 Subject: [PATCH 016/106] fixed a bug in dgeqp3rk.f in quick return if possible for the whole original matrix when MAXC2NRM<= ABSTOL and ONE <=RELTOL --- SRC/dgeqp3rk.f | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index e615866c7d..fcde7a8cd0 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -720,16 +720,20 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, * =================================================================== * * Quick return if possible for the case when the second or third -* stopping criterion is satified, i.e. MAXC2NRMK <= ABSTOL OR -* RELMAXC2NRMK <= RELTOL. +* stopping criterion for the whole original matrix is satified, +* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL +* (which is ONE <= RELTOL). +* + IF( MAXC2NRM.LE.ABSTOL .OR. ONE.LE.RELTOL ) THEN * - IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN K = 0 MAXC2NRMK = MAXC2NRM RELMAXC2NRMK = ONE +* DO J = 1, MINMN TAU( J ) = ZERO END DO +* WORK( 1 ) = DBLE( LWKOPT ) RETURN END IF From e965983eb96b860f389818f881ca4728438eaf9d Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 017/106] Added zero submatrix optimization and changed MAXK into KMAX in dlaqp2k.f --- SRC/dlaqp2rk.f | 58 ++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 44 insertions(+), 14 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 4ec5c590c2..d5a7814b7c 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -18,13 +18,13 @@ * Definition: * =========== * -* SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, +* SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * $ KP1, MAXC2NRM, A, LDA, KF, MAXC2NRMK, * $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) * IMPLICIT NONE * * .. Scalar Arguments .. -* INTEGER IOFFSET, KP1, KF, MAXK, LDA, M, N, NRHS +* INTEGER IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, * $ RELTOL * .. @@ -80,20 +80,20 @@ *> IOFFSET >= 0. *> \endverbatim *> -*> \param[in] MAXK +*> \param[in] KMAX *> \verbatim -*> MAXK is INTEGER +*> KMAX is INTEGER *> *> The first factorization stopping criterion. *> *> The maximum number of columns of the matrix A to factorize, -*> i.e. the maximum factorization rank. MAXK >= 0. +*> i.e. the maximum factorization rank. KMAX >= 0. *> -*> a) If MAXK >= min(M-IOFFSET,N), then this stopping +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping *> criterion is not used, factorize columns *> depending on ABSTOL and RELTOL. *> -*> b) If MAXK = 0, then this stopping criterion is +*> b) If KMAX = 0, then this stopping criterion is *> satisfied on input and the routine exits immediately. *> This means that the factorization is not performed, *> the matrices A and B are not modified, and @@ -267,7 +267,7 @@ *> \endhtmlonly * * ===================================================================== - SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, + SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, $ KP1, MAXC2NRM, A, LDA, KF, MAXC2NRMK, $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) IMPLICIT NONE @@ -277,7 +277,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. - INTEGER IOFFSET, KP1, KF, MAXK, LDA, M, N, NRHS + INTEGER IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL * .. @@ -321,12 +321,12 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, * MINMNFACT = MIN( M-IOFFSET, N ) MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) - MAXK = MIN( MAXK, MINMNFACT ) + KMAX = MIN( KMAX, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) * * Compute the factorization. * - DO K = 1, MAXK + DO K = 1, KMAX * I = IOFFSET + K * @@ -356,6 +356,35 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, * * ================================================================== * +* Quick return, if the submatrix A(IOFFSET+K:M,K:N) is +* a zero matrix. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* +* Set the number of factorized columns. +* TODO: fix USETOL + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN + KF = K - 1 + ELSE + KF = KMAX + END IF +* +* Set TAUs corresponding to ZERO columns in the submatrix +* A(IOFFSET+K:M,K:N) to ZERO, i.e. TAU(K:MINMNFACT) +* set to ZERO. +* + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ================================================================== +* * Test for the second and third stopping criteria. * NOTE: There is no need to test for ABSTOL >= ZERO, since * MAXC2NRMK is non-negative. Similarly, there is no need @@ -378,6 +407,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, * Return from the routine. * RETURN +* END IF * * ================================================================== @@ -480,9 +510,9 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, * * Set the number of factorized columns * - KF = MAXK + KF = KMAX * -* We reached the end of the loop, i.e. all MAXK columns were +* We reached the end of the loop, i.e. all KMAX columns were * factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before * we return. * @@ -502,7 +532,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, MAXK, ABSTOL, RELTOL, RELMAXC2NRMK = ZERO END IF * -* We reached the end of the loop, i.e. all MAXK columns were +* We reached the end of the loop, i.e. all KMAX columns were * factorized, set TAUs corresponding to the columns that were * not factorized to ZERO, i.e. TAU(KF+1:MINMNFACT) set to ZERO. * From 4c09d8efbf5bb5c43422371859f02284226f89fc Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 018/106] changed comments in SRC/dlaqp2rk.f --- SRC/dlaqp2rk.f | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index d5a7814b7c..479196f553 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -311,13 +311,13 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * .. * .. Executable Statements .. * -* MINMNFACT in the smallest dimension of the submatrix +* MINMN_FACT in the smallest dimension of the submatrix * A(IOFFSET+1:M,1:N) to be factorized. * * MINMNUPDT is the smallest dimension -* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which contains -* the submatrices A(IOFFSET+1:M,1:N) and B(IOFFSET+1:M,1:NRHS) as column -* blocks. +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which +* contains the submatrices A(IOFFSET+1:M,1:N) and +* B(IOFFSET+1:M,1:NRHS) as column blocks. * MINMNFACT = MIN( M-IOFFSET, N ) MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) @@ -332,7 +332,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * IF( IOFFSET.EQ.0 .AND. K.EQ.1 ) THEN * -* If we are at the first column of the original whole matrix A. +* We are at the first column of the original whole matrix A. * KP = KP1 MAXC2NRMK = MAXC2NRM @@ -397,8 +397,9 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * KF = K - 1 * -* Set TAUs corresponding to the columns that were not factorized -* to ZERO, i.e. TAU(KF+1:MINMNFACT)=TAU(K:MINMNFACT) set to ZERO. +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, +* TAU(KF+1:MINMNFACT)=TAU(K:MINMNFACT) set to ZERO. * DO J = K, MINMNFACT TAU( J ) = ZERO From 8da81bc473df46e04476d6ce553f4ca8039a8162 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 019/106] replaced MAXK with KMAX in glaqp3rk.f --- SRC/dlaqp3rk.f | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index b9c17415e9..79c5f70237 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -18,13 +18,13 @@ * Definition: * =========== * -* SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, +* SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * $ RELTOL, KP1, MAXC2NRM, A, LDA, KB, DONE, * $ KF, MAXC2NRMK, RELMAXC2NRMK, * $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) * IMPLICIT NONE * LOGICAL DONE -* INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, MAXK, N, +* INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, KMAX, N, * $ NB, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, * $ RELTOL @@ -315,7 +315,7 @@ *> \endhtmlonly * * ===================================================================== - SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, + SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A, LDA, KB, DONE, $ KF, MAXC2NRMK, RELMAXC2NRMK, $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) @@ -327,7 +327,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, MAXK, ABSTOL, * * .. Scalar Arguments .. LOGICAL DONE - INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, MAXK, N, + INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, KMAX, N, $ NB, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL From 73bfa95e71f10cef8d96df6b68602849cf9cb651 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 020/106] replaced MAXK with KMAX in dgeqp3rk.f --- SRC/dgeqp3rk.f | 52 +++++++++++++++++++++++++------------------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index fcde7a8cd0..647097ed6e 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -18,13 +18,13 @@ * Definition: * =========== * -* SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, +* SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, * $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) * IMPLICIT NONE * * .. Scalar Arguments .. -* INTEGER INFO, K, MAXK, LDA, LWORK, M, N, NRHS +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL * .. * .. Array Arguments .. @@ -81,9 +81,9 @@ *> The truncation criteria (i.e. when to stop the factorization) *> can be any of the following: *> -*> 1) The input parameter MAXK, the maximum number of columns -*> MAXK to factorize, i.e. the factorization rank is limited -*> to MAXK. If MAXK >= min(M,N), the criterion is not used. +*> 1) The input parameter KMAX, the maximum number of columns +*> KMAX to factorize, i.e. the factorization rank is limited +*> to KMAX. If KMAX >= min(M,N), the criterion is not used. *> *> 2) The input parameter ABSTOL, the absolute tolerance for *> the maximum column 2-norm of the residual matrix R22(K). This @@ -101,7 +101,7 @@ *> The algorithm stops when any of these conditions is first *> satisfied, otherwise the whole matrix A is factorized. *> -*> For full rank factorization use the values MAXK >= min(M,N), +*> For full rank factorization use the values KMAX >= min(M,N), *> ABSTOL < 0.0 and RELTOL < 0.0. *> *> The routine returns: @@ -168,20 +168,20 @@ *> columns of the matrix B. NRHS >= 0. *> \endverbatim *> -*> \param[in] MAXK +*> \param[in] KMAX *> \verbatim -*> MAXK is INTEGER +*> KMAX is INTEGER *> *> The first factorization stopping criterion. *> *> The maximum number of columns of the matrix A to factorize, -*> i.e. the maximum factorization rank. MAXK >= 0. +*> i.e. the maximum factorization rank. KMAX >= 0. *> -*> a) If MAXK >= min(M,N), then this stopping criterion +*> a) If KMAX >= min(M,N), then this stopping criterion *> is not used, factorize columns depending *> on ABSTOL and RELTOL. *> -*> b) If MAXK = 0, then this stopping criterion is +*> b) If KMAX = 0, then this stopping criterion is *> satisfied on input and the routine exits immediately. *> This means that the factorization is not performed, *> the matrices A and B are not modified, and @@ -205,7 +205,7 @@ *> by XERBLA. *> *> b) If ABSTOL < 0.0, then this stopping criterion is not -*> used, factorize columns depending on MAXK and RELTOL. +*> used, factorize columns depending on KMAX and RELTOL. *> This includes the case ABSTOL = -Inf. *> *> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN @@ -244,7 +244,7 @@ *> by XERBLA. *> *> b) If RELTOL < 0.0, then this stopping criterion is not -*> used, factorize columns depending on MAXK and ABSTOL. +*> used, factorize columns depending on KMAX and ABSTOL. *> This includes the case RELTOL = -Inf. *> *> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. @@ -322,7 +322,7 @@ *> K is INTEGER *> The number of columns that were factorized. *> K is the factorization rank. -*> 0 <= K <= min( M, min(MAXK,N) ). +*> 0 <= K <= min( M, min(KMAX,N) ). *> *> If K = 0, the arrays A, TAU, JPIV were not modified. *> \endverbatim @@ -503,7 +503,7 @@ *> \endhtmlonly * * ===================================================================== - SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, + SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) IMPLICIT NONE @@ -513,7 +513,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. - INTEGER INFO, K, KF, MAXK, LDA, LWORK, M, N, NRHS + INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL * .. * .. Array Arguments .. @@ -561,7 +561,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, INFO = -2 ELSE IF( NRHS.LT.0 ) THEN INFO = -3 - ELSE IF( MAXK.LT.0 ) THEN + ELSE IF( KMAX.LT.0 ) THEN INFO = -4 ELSE IF( DISNAN( ABSTOL ) ) THEN INFO = -5 @@ -571,7 +571,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, INFO = -8 END IF * -* If the input parameters M, N, NRHS, MAXK, LDA are valid: +* If the input parameters M, N, NRHS, KMAX, LDA are valid: * a) Test the input workspace size LWORK for the minimum * size requirement IWS. * b) Determine the optimal block size NB and optimal @@ -602,7 +602,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, END IF * * NOTE: The optimal workspace size is returned in WORK(1), if -* the input parameters M, N, NRHS, MAXK, LDA are valid. +* the input parameters M, N, NRHS, KMAX, LDA are valid. * IF( INFO.NE.0 ) THEN CALL XERBLA( 'DGEQP3RK', -INFO ) @@ -653,9 +653,9 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, MAXC2NRM = WORK( KP1 ) * * Quick return if possible for the case when the first -* stopping criterion is satisfied, i.e. MAXK = 0. +* stopping criterion is satisfied, i.e. KMAX = 0. * - IF( MAXK.EQ.0 ) THEN + IF( KMAX.EQ.0 ) THEN K = 0 MAXC2NRMK = MAXC2NRM RELMAXC2NRMK = ONE @@ -690,9 +690,9 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, * =================================================================== * * JMAX is the maximum index of the column to be factorized, -* which is also limited by the first stopping criterion MAXK. +* which is also limited by the first stopping criterion KMAX. * - JMAX = MIN( MAXK, MINMN ) + JMAX = MIN( KMAX, MINMN ) * =================================================================== * @@ -784,9 +784,9 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, * * JMAXB is the maximum column index of the block, when the * blocked code is used, is also limited by the first stopping -* criterion MAXK. +* criterion KMAX. * - JMAXB = MIN( MAXK, MINMN - NX ) + JMAXB = MIN( KMAX, MINMN - NX ) * IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN * @@ -804,7 +804,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, MAXK, ABSTOL, RELTOL, * * Factorize JB columns among the columns A(J:N). * - CALL DLAQP3RK( M, N-J+1, NRHS, J-1, JB, MAXK, ABSTOL, + CALL DLAQP3RK( M, N-J+1, NRHS, J-1, JB, KMAX, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, JBF, $ DONE, KF, MAXC2NRMK, RELMAXC2NRMK, $ JPIV( J ), TAU( J ), From 3fc469a5dd974cf6941ec1e50eaf3df6ac4edfaf Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 021/106] changes in dlaqp2rk.f IF( IOFFSET.EQ.0 .AND. K.EQ.1 ) THEN into IF( I.QE.1 ) THEN and F( MAXC2NRMK.EQ.ZERO ) THEN into IF( I.NE.1 .AND. MAXC2NRMK.EQ.ZERO ) THEN --- SRC/dlaqp2rk.f | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 479196f553..6ed256b433 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -311,7 +311,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * .. * .. Executable Statements .. * -* MINMN_FACT in the smallest dimension of the submatrix +* MINMNFACT in the smallest dimension of the submatrix * A(IOFFSET+1:M,1:N) to be factorized. * * MINMNUPDT is the smallest dimension @@ -330,9 +330,11 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * I = IOFFSET + K * - IF( IOFFSET.EQ.0 .AND. K.EQ.1 ) THEN + IF( I.QE.1 ) THEN * -* We are at the first column of the original whole matrix A. +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. * KP = KP1 MAXC2NRMK = MAXC2NRM @@ -356,10 +358,12 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * ================================================================== * -* Quick return, if the submatrix A(IOFFSET+K:M,K:N) is -* a zero matrix. +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check it only if the column index +* (same as row index) is larger than 2, since the condition for +* whole original matris is checked in the main routine. * - IF( MAXC2NRMK.EQ.ZERO ) THEN + IF( I.NE.1 .AND. MAXC2NRMK.EQ.ZERO ) THEN * * Set the number of factorized columns. * TODO: fix USETOL @@ -398,8 +402,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, KF = K - 1 * * Set TAUs corresponding to the columns that were not -* factorized to ZERO, -* TAU(KF+1:MINMNFACT)=TAU(K:MINMNFACT) set to ZERO. +* factorized to ZERO, (note that: KF = K - 1), i.e. +* Set TAU(KF+1:MINMNFACT)=TAU(K:MINMNFACT) to ZERO. * DO J = K, MINMNFACT TAU( J ) = ZERO From 46f90f6f87a3d5ad6e93f7790c636a315a186859 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 022/106] in dlaqp2rk.f moved ZERO submatrix condition check under if statement, when I!=1 --- SRC/dlaqp2rk.f | 61 +++++++++++++++++++++++++++++--------------------- 1 file changed, 35 insertions(+), 26 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 6ed256b433..04004389a8 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -330,7 +330,9 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * I = IOFFSET + K * - IF( I.QE.1 ) THEN + IF( I.EQ.1 ) THEN +* +* ============================================================ * * We are at the first column of the original whole matrix A, * therefore we use the computed KP1 and MAXC2NRM from the @@ -339,9 +341,13 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, KP = KP1 MAXC2NRMK = MAXC2NRM RELMAXC2NRMK = ONE +* +* ============================================================ * ELSE * +* ============================================================ +* * Determine the pivot column at K-th step, i.e. the index * of the column with the maximum 2-norm in the * submatrix A(I:M,K:N). @@ -354,36 +360,40 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, MAXC2NRMK = VN1( KP ) RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM * - END IF +* ============================================================ * -* ================================================================== +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 2, since the condition for whole +* original matrix is checked in the main routine. * -* Quick return, if the submatrix A(I:M,K:N) is -* a zero matrix. We need to check it only if the column index -* (same as row index) is larger than 2, since the condition for -* whole original matris is checked in the main routine. + IF( MAXC2NRMK.EQ.ZERO ) THEN * - IF( I.NE.1 .AND. MAXC2NRMK.EQ.ZERO ) THEN +* Set KF, the number of factorized columns. +* TODO: fix USETOL + IF( MAXC2NRMK.LE.ABSTOL + $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN * -* Set the number of factorized columns. -* TODO: fix USETOL - IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN - KF = K - 1 - ELSE - KF = KMAX - END IF + KF = K - 1 + ELSE + KF = KMAX + END IF * -* Set TAUs corresponding to ZERO columns in the submatrix -* A(IOFFSET+K:M,K:N) to ZERO, i.e. TAU(K:MINMNFACT) -* set to ZERO. +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. * - DO J = K, MINMNFACT - TAU( J ) = ZERO - END DO + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO * -* Return from the routine. +* Return from the routine. * - RETURN + RETURN +* + END IF +* +* ============================================================ * END IF * @@ -397,13 +407,12 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN * -* Set the number of factorized columns. +* Set KF, the number of factorized columns. * KF = K - 1 * * Set TAUs corresponding to the columns that were not -* factorized to ZERO, (note that: KF = K - 1), i.e. -* Set TAU(KF+1:MINMNFACT)=TAU(K:MINMNFACT) to ZERO. +* factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. * DO J = K, MINMNFACT TAU( J ) = ZERO From b943dee7c7805db0b48cee29c3d67a17b403fdb9 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 023/106] in dlaqp3rk.f added comments TODO --- SRC/dlaqp2rk.f | 1 + 1 file changed, 1 insertion(+) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 04004389a8..6f792b43ae 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -358,6 +358,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * column 2-norm of the submatrix A(I:M,K:N) at step K. * MAXC2NRMK = VN1( KP ) +* TODO: optimize RELMAXC2NRMK RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM * * ============================================================ From d1527055789f33fe448e8e8e1d3bc1db274eeb27 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 024/106] added zero submatrix check to DLAQP3RK and changed the position of DONE parameter in the calling sequence --- SRC/dgeqp3rk.f | 67 ++++++++++++++++++----- SRC/dlaqp3rk.f | 141 +++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 174 insertions(+), 34 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 647097ed6e..4480536530 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -643,6 +643,13 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, WORK( J ) = DNRM2( M, A( 1, J ), 1 ) WORK( N+J ) = WORK( J ) END DO + + WRITE(*,*) + WRITE(*,*) "===== DGEQP3RK 2NORM =" + WRITE(*,*) + $ WORK( 1 ), WORK( 2 ), WORK( 3 ), WORK( 4 ), + $ WORK( 5 ), WORK( 6 ), WORK( 7 ), WORK( 8 ) + WRITE(*,*) * * ================================================================== * @@ -700,6 +707,9 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * IF( MAXC2NRM.EQ.ZERO ) THEN * + + WRITE(*,*) "======= DGEQP3RK ((( ZERO MATRIX ))) ====" + IF( USETOL ) THEN K = 0 ELSE @@ -773,6 +783,10 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, END IF * * ================================================================== +* +* DONE is the boolean flag to rerpresent the case when the +* factorization completed in the block factorization routine, +* before the end of the block. * DONE = .FALSE. * @@ -804,30 +818,43 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * * Factorize JB columns among the columns A(J:N). * + WRITE(*,*) + WRITE(*,*) "===== DGEQP3RK loop before block(IOFFSET, JB)=", + $ J-1, JB + CALL DLAQP3RK( M, N-J+1, NRHS, J-1, JB, KMAX, ABSTOL, - $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, JBF, - $ DONE, KF, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ DONE, JBF, KF, MAXC2NRMK, RELMAXC2NRMK, $ JPIV( J ), TAU( J ), $ WORK( J ), WORK( N+J ), $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), $ N+NRHS-J+1, IWORK ) * J = J + JBF + + WRITE(*,*) "======= DGEQP3RK loop after block (JBF)=", + $ JBF * IF( DONE ) THEN * -* ABSTOL or RELTOL criterion is satisfied before the -* end of the column block, we can return from -* the routine. Perform the following before returning: +* Either the submatrix is zero before the end of the +* column block, or ABSTOL or RELTOL criterion is +* satisfied before the end of the column block, we can +* return from the routine. Perform the following before +* returning: * a) Set the number of factorized columns K, -* b) MAXC2NRMK and RELMAXC2NRMK are returned by the -* block factorization routine. +* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned +* by the block factorization routine; +* 2) The remaining TAUs are set to ZERO by the +* block factorization routine. * - K = J - 1 + K = KF * -* Exit loop +* Return from the routine. * - EXIT + WORK( 1 ) = DBLE( LWKOPT ) +* + RETURN * END IF * @@ -836,9 +863,10 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, END IF * * Use unblocked code to factor the last or only block. -* J = JMAX+1 means we factorized the maximum possible number of columns, -* That is in ELSE clause we nned to compute the MAXC2NORM and -* RELMAXC2NORM to return after we processed the blocks. +* J = JMAX+1 means we factorized the maximum possible number of +* columns, that is in ELSE clause we need to compute +* the MAXC2NORM and RELMAXC2NORM to return after we processed +* the blocks. * IF( .NOT.DONE ) THEN * @@ -887,9 +915,22 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, DO J = K + 1, MINMN TAU( J ) = ZERO END DO + + + WRITE(*,*) + WRITE(*,*) "===== END DGEQP3RK compute low rank ", + $ "(MAXC2NRMK, RELMAXC2NRMK)=", + $ MAXC2NRMK, RELMAXC2NRMK + ELSE MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO + + WRITE(*,*) + WRITE(*,*) "===== END DGEQP3RK compute full rank ", + $ "(MAXC2NRMK, RELMAXC2NRMK)=", + $ MAXC2NRMK, RELMAXC2NRMK + END IF * * END IF( J.LE.JMAX ) THEN diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 79c5f70237..20e0ccae07 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -183,12 +183,6 @@ *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> -*> \param[out] KB -*> \verbatim -*> KB is INTEGER -*> The number of columns actually factorized. -*> \endverbatim -*> *> \param[out] *> *> \verbatim @@ -196,6 +190,12 @@ *> TRUE, if the factorization completed, *> FALSE, otherwise. *> \endverbatim +* +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> The number of columns actually factorized. +*> \endverbatim *> *> \param[out] KF *> \verbatim @@ -316,7 +316,7 @@ * * ===================================================================== SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, - $ RELTOL, KP1, MAXC2NRM, A, LDA, KB, DONE, + $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, $ KF, MAXC2NRMK, RELMAXC2NRMK, $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) IMPLICIT NONE @@ -346,7 +346,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * .. * .. Local Scalars .. INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, - $ LSTICC, KP, I + $ LSTICC, KP, I, IF DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. @@ -380,9 +380,11 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, K = K + 1 I = IOFFSET + K * - IF( IOFFSET.EQ.0 .AND. K.EQ.1 ) THEN + IF( I.EQ.1 ) THEN * -* If we are at the first column of the original whole matrix A. +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. * KP = KP1 MAXC2NRMK = MAXC2NRM @@ -400,12 +402,94 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * column 2-norm of the submatrix A(I:M,K:N) at step K. * MAXC2NRMK = VN1( KP ) +* TODO: optimize RELMAXC2NRMK RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM * END IF * * ================================================================== * +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check it only if the column index +* (same as row index) is larger than 2, since the condition for +* the whole original matrix is checked in the main routine. +* + IF( I.NE.1 .AND. MAXC2NRMK.EQ.ZERO ) THEN + + + WRITE(*,*) "$$$$$$ DLAQP3RK zero submatrix, IOFFSET, K= ", + $ IOFFSET, K +* + DONE = .TRUE. +* +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which is +* the same as the number of rows in the original whole +* matrix A; +* Set KF, the number of factorized columns in the original +* whole matrix A. +* TODO: fix USETOL + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN + + + WRITE(*,*) + $ "$$$$$$$$ DLAQP3RK zero submatrix (ABSTOL, K)= ", + $ ABSTOL, K +* + KB = K - 1 + IF = I - 1 + KF = IOFFSET + KB +* + ELSE +* + KB = K - 1 + IF = I - 1 + KF = KMAX +* + END IF +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), since +* the submatrix is zero and we stop the computation. But, +* we need to apply the block reflector to the residual right +* hand sides stored in A(KB+1:M,N+1:N+NRHS), if the residual +* right hand sides exist. This happens +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + + + WRITE(*,*) "$$$$$$$$$$ DLAQP3RK block reflector ", + $ "(M-IF, NRHS, KB)", M-IF, NRHS, KB + +* + CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, + $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), + $ LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) to ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) to ZERO. +* + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ================================================================== +* * Test for the second and third tolerance stopping criteria. * NOTE: There is no need to test for ABSTOL.GE.ZERO, since * MAXC2NRMK is non-negative. Similarly, there is no need @@ -413,13 +497,20 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * non-negative. * IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN -* - K = K - 1 * DONE = .TRUE. * -* Exit the loop +* Set the number of factorized columns in the block. * + K = K - 1 +* +* Exit the loop. +* After the loop, there is a code: +* 1) to apply the block reflector via GEMM to the residual +* of the matrix A and to the right hand sides B; +* 2) to recompute the 2-norm of the difficult columns; +* 3) to zero out the remaining TAUs. +* TODO: change exit?? EXIT * END IF @@ -525,7 +616,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, TEMP = ABS( A( I, J ) ) / VN1( J ) TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 - IF( TEMP2 .LE. TOL3Z ) THEN + IF( TEMP2.LE.TOL3Z ) THEN * * At J-index, we have a difficult column for the * update of the 2-norm. Save the index of the previous @@ -552,18 +643,26 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * END DO * -* Now, afler the loop, KB=K is the number of factorized columns, -* I is the number or processed rows. +* Now, afler the loop: +* KB is the number of factorized columns in the block, +* KF is the number or factorized columns in the original +* whole matrix A, +* I is the number of processed rows in the block which is +* the same as the the numerb of processed rows in +* the original whole matrix A. * KB = K - I = IOFFSET + KB KF = IOFFSET + KB + I = IOFFSET + KB + +* Apply the block reflector to the residual of the matrix A +* and right hand sides B, if the residual matrix and +* and/or the residual right hand sides exist, i.e. +* if the submatrix A(I+1:M,KB+1:N+NRHS) exists. This happens +* when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): * -* Apply the block reflector to the rest of the matrix, -* if the residual matrix A(I+1:M,KB+1:N+NRHS) exists, -* i.e. when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): * A(I+1:M,K+1:N+NRHS) := A(I+1:M,KB+1:N+NRHS) - -* A(I+1:M,1:KB) * F(KB+1:N,1:KB)**T. +* A(I+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. * IF( KB.LT.MINMNUPDT ) THEN * From 9de1ee7775b0ad6d78d51c66a4292c3b37cd1266 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 025/106] changed indent in in one line in SRC/dlaqp2rk.f --- SRC/dlaqp2rk.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 6f792b43ae..806550b56b 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -374,7 +374,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * Set KF, the number of factorized columns. * TODO: fix USETOL IF( MAXC2NRMK.LE.ABSTOL - $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN + $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN * KF = K - 1 ELSE From 762496f6fcf5da12abfbd0f8a5eff4bdade416cd Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 026/106] moved zero submatrix check in (if(ioffset ==0) else) clause into else part in DLAQP3RK --- SRC/dlaqp3rk.f | 120 +++++++++++++++++++++++++------------------------ 1 file changed, 62 insertions(+), 58 deletions(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 20e0ccae07..c741af2432 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -405,86 +405,90 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * TODO: optimize RELMAXC2NRMK RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM * - END IF -* -* ================================================================== +* ============================================================ * -* Quick return, if the submatrix A(I:M,K:N) is -* a zero matrix. We need to check it only if the column index -* (same as row index) is larger than 2, since the condition for -* the whole original matrix is checked in the main routine. +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check it only if the column index +* (same as row index) is larger than 2, since the condition +* for the whole original matrix is checked in the main +* routine. * - IF( I.NE.1 .AND. MAXC2NRMK.EQ.ZERO ) THEN + IF( MAXC2NRMK.EQ.ZERO ) THEN - WRITE(*,*) "$$$$$$ DLAQP3RK zero submatrix, IOFFSET, K= ", - $ IOFFSET, K -* - DONE = .TRUE. -* -* Set KB, the number of factorized columns in the block; -* Set IF, the number of processed rows in the block, which is -* the same as the number of rows in the original whole -* matrix A; -* Set KF, the number of factorized columns in the original -* whole matrix A. -* TODO: fix USETOL - IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN + WRITE(*,*) "$$$$$$ DLAQP3RK zero submatrix, IOFFSET, K= ", + $ IOFFSET, K +* + DONE = .TRUE. +* +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which +* is the same as the number of rows in the original whole +* matrix A; +* Set KF, the number of factorized columns in the original +* whole matrix A. +* TODO: fix USETOL + IF( MAXC2NRMK.LE.ABSTOL + $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN - WRITE(*,*) - $ "$$$$$$$$ DLAQP3RK zero submatrix (ABSTOL, K)= ", - $ ABSTOL, K + WRITE(*,*) + $ "$$$$$$$$ DLAQP3RK zero submatrix (ABSTOL, K)= ", + $ ABSTOL, K * - KB = K - 1 - IF = I - 1 - KF = IOFFSET + KB + KB = K - 1 + IF = I - 1 + KF = IOFFSET + KB * - ELSE + ELSE * - KB = K - 1 - IF = I - 1 - KF = KMAX + KB = K - 1 + IF = I - 1 + KF = KMAX * - END IF + END IF * -* There is no need to apply the block reflector to the -* residual of the matrix A stored in A(KB+1:M,KB+1:N), since -* the submatrix is zero and we stop the computation. But, -* we need to apply the block reflector to the residual right -* hand sides stored in A(KB+1:M,N+1:N+NRHS), if the residual -* right hand sides exist. This happens -* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix is zero and we stop the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): * -* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - -* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. * - IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN - WRITE(*,*) "$$$$$$$$$$ DLAQP3RK block reflector ", - $ "(M-IF, NRHS, KB)", M-IF, NRHS, KB + WRITE(*,*) "$$$$$$$$$$ DLAQP3RK block reflector ", + $ "(M-IF, NRHS, KB)", M-IF, NRHS, KB * - CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, - $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), - $ LDF, ONE, A( IF+1, N+1 ), LDA ) - END IF + CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, + $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), + $ LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF * -* There is no need to recompute the 2-norm of the -* difficult columns, since we stop the factorization. +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. * -* Set TAUs corresponding to the columns that were not -* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) to ZERO, -* which is equivalent to seting TAU(K:MINMNFACT) to ZERO. +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) to ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) to ZERO. * - DO J = K, MINMNFACT - TAU( J ) = ZERO - END DO + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO * -* Return from the routine. +* Return from the routine. +* + RETURN +* + END IF * - RETURN +* ============================================================ * END IF * From 7bc3615d7941f269483c384e2e4d60e19ed20f7d Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 027/106] removed redundant IF(.NOT.DONE.) statement at the end of the DGEQP3RK routine --- SRC/dgeqp3rk.f | 70 +++++++++++++++++++++++--------------------------- 1 file changed, 32 insertions(+), 38 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 4480536530..ce7c20f23b 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -868,28 +868,26 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * the MAXC2NORM and RELMAXC2NORM to return after we processed * the blocks. * - IF( .NOT.DONE ) THEN + IF( J.LE.JMAX ) THEN * - IF( J.LE.JMAX ) THEN + CALL DLAQP2RK( M, N-J+1, NRHS, J-1, JMAX-J+1, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, KF, + $ MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ) ) * - CALL DLAQP2RK( M, N-J+1, NRHS, J-1, JMAX-J+1, ABSTOL, - $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, KF, - $ MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), - $ TAU( J ), WORK( J ), WORK( N+J ), - $ WORK( 2*N+1 ) ) +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. * -* ABSTOL or RELTOL criterion is satisfied when the number of -* the factorized columns KF is smaller then the number -* of columns JMAX-J+1 supplied to be factorized by the -* unblocked routine, we can return from -* the routine. Perform the following before returning: -* a) Set the number of factorized columns K, -* b) MAXC2NRMK and RELMAXC2NRMK are returned by the -* unblocked factorization routine above. + K = J - 1 + KF * - K = J - 1 + KF -* - ELSE + ELSE * * Compute the return values for blocked code. * @@ -903,18 +901,18 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * residual matrix, otherwise set them to ZERO; * 2) Set TAU(K+1:MINMN) to ZERO. * - IF( K.LT.MINMN ) THEN - JMAXC2NRM = K + IDAMAX( N-K, WORK( K+1 ), 1 ) - MAXC2NRMK = WORK( JMAXC2NRM ) - IF( K.EQ.0 ) THEN - RELMAXC2NRMK = ONE - ELSE - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM - END IF -* - DO J = K + 1, MINMN - TAU( J ) = ZERO - END DO + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + IDAMAX( N-K, WORK( K+1 ), 1 ) + MAXC2NRMK = WORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = ZERO + END DO WRITE(*,*) @@ -922,22 +920,18 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, $ "(MAXC2NRMK, RELMAXC2NRMK)=", $ MAXC2NRMK, RELMAXC2NRMK - ELSE - MAXC2NRMK = ZERO - RELMAXC2NRMK = ZERO + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO WRITE(*,*) WRITE(*,*) "===== END DGEQP3RK compute full rank ", $ "(MAXC2NRMK, RELMAXC2NRMK)=", $ MAXC2NRMK, RELMAXC2NRMK - END IF -* -* END IF( J.LE.JMAX ) THEN -* END IF * -* END IF( .NOT.DONE ) THEN +* END IF( J.LE.JMAX ) THEN * END IF * From 9c0a21ebd32a801782464c874afff56bbb898973 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 028/106] changed comments and variable names and assigment for KB, IF, KF in DLAQP3RK --- SRC/dlaqp3rk.f | 104 ++++++++++++++++++++++++++----------------------- 1 file changed, 56 insertions(+), 48 deletions(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index c741af2432..f996943fc6 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -423,10 +423,10 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * * Set KB, the number of factorized columns in the block; * Set IF, the number of processed rows in the block, which -* is the same as the number of rows in the original whole -* matrix A; +* is the same as the number of processed rows in +* the original whole matrix A; * Set KF, the number of factorized columns in the original -* whole matrix A. +* whole matrix A. * TODO: fix USETOL IF( MAXC2NRMK.LE.ABSTOL $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN @@ -489,6 +489,8 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, END IF * * ============================================================ +* +* End ELSE for IF(I.EQ.1) * END IF * @@ -511,10 +513,10 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * Exit the loop. * After the loop, there is a code: * 1) to apply the block reflector via GEMM to the residual -* of the matrix A and to the right hand sides B; -* 2) to recompute the 2-norm of the difficult columns; -* 3) to zero out the remaining TAUs. -* TODO: change exit?? +* of the matrix A and the residual of the right hand +* sides B. +* 2) to zero out the remaining TAUs. +* EXIT * END IF @@ -561,6 +563,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * AIK = A( I, K ) A( I, K ) = ONE +* * =============================================================== * * Compute the current K-th column of F: @@ -648,67 +651,72 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, END DO * * Now, afler the loop: -* KB is the number of factorized columns in the block, -* KF is the number or factorized columns in the original -* whole matrix A, -* I is the number of processed rows in the block which is -* the same as the the numerb of processed rows in -* the original whole matrix A. +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A; +* Set KF, the number of factorized columns in the original +* whole matrix A, KF = IOFFSET+KB = IF. * KB = K - KF = IOFFSET + KB - I = IOFFSET + KB - + IF = IOFFSET + KB + KF = IF +* * Apply the block reflector to the residual of the matrix A -* and right hand sides B, if the residual matrix and -* and/or the residual right hand sides exist, i.e. -* if the submatrix A(I+1:M,KB+1:N+NRHS) exists. This happens -* when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* and the residual of the right hand sides B, if the residual +* matrix and and/or the residual of the right hand sides +* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. +* This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): * -* A(I+1:M,K+1:N+NRHS) := A(I+1:M,KB+1:N+NRHS) - -* A(I+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. * IF( KB.LT.MINMNUPDT ) THEN * - CALL DGEMM( 'No transpose', 'Transpose', M-I, N+NRHS-KB, KB, - $ -ONE, A( I+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, - $ A( I+1, KB+1 ), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', M-IF, N+NRHS-KB, KB, + $ -ONE, A( IF+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, + $ A( IF+1, KB+1 ), LDA ) END IF * -* Recompute the 2-norm of the difficult columns. -* Loop over the index of the difficult columns from the largest -* to the smallest index. + IF( DONE ) THEN +* +* If DONE, set TAU(KB+1:MINMNFACT) to ZERO. +* + DO J = KB + 1, MINMNFACT + TAU( J ) = ZERO + END DO * - DO WHILE( LSTICC.GT.0 ) + ELSE * -* LSTICC is the index of the last difficult column is greater -* than 1. -* ITEMP is the index of the previous difficult column. +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. * - ITEMP = IWORK( LSTICC-1 ) + DO WHILE( LSTICC.GT.0 ) * -* Compute the 2-norm explicilty for the last difficult column and -* save it in the partial and exact 2-norm vectors VN1 and VN2. +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. * -* NOTE: The computation of VN1( LSTICC ) relies on the fact that -* DNRM2 does not fail on vectors with norm below the value of -* SQRT(DLAMCH('S')) + ITEMP = IWORK( LSTICC-1 ) * - VN1( LSTICC ) = DNRM2( M-I, A( I+1, LSTICC ), 1 ) - VN2( LSTICC ) = VN1( LSTICC ) +* Compute the 2-norm explicilty for the last difficult column +* and save it in the partial and exact 2-norm vectors VN1 +* and VN2. * -* Downdate the index of the last difficult column to -* the index of the previous difficult column. +* NOTE: The computation of VN1( LSTICC ) relies on the fact +* that DNRM2 does not fail on vectors with norm below the +* value of SQRT(DLAMCH('S')) * - LSTICC = ITEMP - END DO + VN1( LSTICC ) = DNRM2( M-IF, A( IF+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) * -* If done, set TAU(KB+1:MINMNFACT) to ZERO. +* Downdate the index of the last difficult column to +* the index of the previous difficult column. * - IF( DONE ) THEN - DO J = KB + 1, MINMNFACT - TAU( J ) = ZERO + LSTICC = ITEMP END DO +* END IF * RETURN From 43eb003a740e98510c635b0bd4f4b1fd19a44ffa Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 029/106] Moved ABSTOL and RELTOL verification in DLAQP3RK in ELSE clause of IF(I.EQ.1) --- SRC/dlaqp3rk.f | 41 +++++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index f996943fc6..4caf88475a 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -374,6 +374,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * K = 0 LSTICC = 0 +* TODO: describe DONE in main or in a subroutine DONE = .FALSE. * DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) @@ -387,6 +388,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * main routine. * KP = KP1 +* TODO: optimize MAXC2NRMK and RELMAXC2NRMK MAXC2NRMK = MAXC2NRM RELMAXC2NRMK = ONE * @@ -465,7 +467,6 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, WRITE(*,*) "$$$$$$$$$$ DLAQP3RK block reflector ", $ "(M-IF, NRHS, KB)", M-IF, NRHS, KB -* CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), $ LDF, ONE, A( IF+1, N+1 ), LDA ) @@ -490,34 +491,34 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * * ============================================================ * -* End ELSE for IF(I.EQ.1) +* Test for the second and third tolerance stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. * - END IF + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN * -* ================================================================== + DONE = .TRUE. * -* Test for the second and third tolerance stopping criteria. -* NOTE: There is no need to test for ABSTOL.GE.ZERO, since -* MAXC2NRMK is non-negative. Similarly, there is no need -* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is -* non-negative. +* Set the number of factorized columns in the block. * - IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN + K = K - 1 * - DONE = .TRUE. +* Exit the loop. +* After the loop, there is a code: +* 1) to apply the block reflector via GEMM to the residual +* of the matrix A and the residual of the right hand +* sides B. +* 2) to zero out the remaining TAUs. * -* Set the number of factorized columns in the block. + EXIT * - K = K - 1 + END IF * -* Exit the loop. -* After the loop, there is a code: -* 1) to apply the block reflector via GEMM to the residual -* of the matrix A and the residual of the right hand -* sides B. -* 2) to zero out the remaining TAUs. +* ============================================================ * - EXIT +* End ELSE of IF(I.EQ.1) * END IF * From 39828c7f672d3278ca574467aa05cff45399de4e Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 030/106] Changed bar length in the comments in DLAQP3RK --- SRC/dlaqp3rk.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 4caf88475a..413489b332 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -522,7 +522,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * END IF * -* ================================================================== +* =============================================================== * * If the pivot column is not the first column of the * subblock A(1:M,K:N): From 115d5a4c4678bfa36cc04ffe53304042c5213e5b Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 031/106] in DLAQP3RK chahged ABSTOL and RELTOL condition to return from the look rather then exit from the loop and return at the end of the routine --- SRC/dlaqp3rk.f | 119 ++++++++++++++++++++++++++++++------------------- 1 file changed, 74 insertions(+), 45 deletions(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 413489b332..8563de9194 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -464,8 +464,9 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN - WRITE(*,*) "$$$$$$$$$$ DLAQP3RK block reflector ", - $ "(M-IF, NRHS, KB)", M-IF, NRHS, KB + WRITE(*,*) "$$$$$$$$$$ DLAQP3RK zero submatrix", + $ " block reflector (M-IF, NRHS, KB)", + $ M-IF, NRHS, KB CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), @@ -501,18 +502,59 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * DONE = .TRUE. * -* Set the number of factorized columns in the block. +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A; +* Set KF, the number of factorized columns in the original +* whole matrix A, KF = IOFFSET+KB = IF. * - K = K - 1 + KB = K - 1 + IF = I - 1 + KF = IF + + WRITE(*,*) "$$$$$$$$$$ DLAQP3RK condition for", + $ " ABSTOL or RELTOL (ABSTOL, RELTOL),", + $ " (MAXC2NRMK, RELMAXC2NRMK)", + $ ABSTOL, RELTOL, MAXC2NRMK, RELMAXC2NRMK + + +* Apply the block reflector to the residual of the +* matrix A and the residual of the right hand sides B, if +* the residual matrix and and/or the residual of the right +* hand sides exist, i.e. if the submatrix +* A(I+1:M,KB+1:N+NRHS) exists. This occurs when +* KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): * -* Exit the loop. -* After the loop, there is a code: -* 1) to apply the block reflector via GEMM to the residual -* of the matrix A and the residual of the right hand -* sides B. -* 2) to zero out the remaining TAUs. +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. * - EXIT + IF( KB.LT.MINMNUPDT ) THEN + + WRITE(*,*) "$$$$$$$$$$ DLAQP3RK ABSTOL or RELTOL", + $ " block reflector (M-IF, N+NRHS-KB, KB)", + $ M-IF, N+NRHS-KB, KB + + CALL DGEMM( 'No transpose', 'Transpose', M-IF, + $ N+NRHS-KB, KB,-ONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, ONE, + $ A( IF+1, KB+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) to ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) to ZERO. +* + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN * END IF * @@ -655,12 +697,12 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * Set KB, the number of factorized columns in the block; * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in -* the original whole matrix A; +* the original whole matrix A, IF = IOFFSET + KB; * Set KF, the number of factorized columns in the original * whole matrix A, KF = IOFFSET+KB = IF. * KB = K - IF = IOFFSET + KB + IF = I KF = IF * * Apply the block reflector to the residual of the matrix A @@ -673,52 +715,39 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. * IF( KB.LT.MINMNUPDT ) THEN -* CALL DGEMM( 'No transpose', 'Transpose', M-IF, N+NRHS-KB, KB, $ -ONE, A( IF+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, $ A( IF+1, KB+1 ), LDA ) END IF * - IF( DONE ) THEN -* -* If DONE, set TAU(KB+1:MINMNFACT) to ZERO. -* - DO J = KB + 1, MINMNFACT - TAU( J ) = ZERO - END DO -* - ELSE +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. * -* Recompute the 2-norm of the difficult columns. -* Loop over the index of the difficult columns from the largest -* to the smallest index. + DO WHILE( LSTICC.GT.0 ) * - DO WHILE( LSTICC.GT.0 ) +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. * -* LSTICC is the index of the last difficult column is greater -* than 1. -* ITEMP is the index of the previous difficult column. + ITEMP = IWORK( LSTICC-1 ) * - ITEMP = IWORK( LSTICC-1 ) +* Compute the 2-norm explicilty for the last difficult column and +* save it in the partial and exact 2-norm vectors VN1 and VN2. * -* Compute the 2-norm explicilty for the last difficult column -* and save it in the partial and exact 2-norm vectors VN1 -* and VN2. +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* DNRM2 does not fail on vectors with norm below the value of +* SQRT(DLAMCH('S')) * -* NOTE: The computation of VN1( LSTICC ) relies on the fact -* that DNRM2 does not fail on vectors with norm below the -* value of SQRT(DLAMCH('S')) + VN1( LSTICC ) = DNRM2( M-IF, A( IF+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) * - VN1( LSTICC ) = DNRM2( M-IF, A( IF+1, LSTICC ), 1 ) - VN2( LSTICC ) = VN1( LSTICC ) +* Downdate the index of the last difficult column to +* the index of the previous difficult column. * -* Downdate the index of the last difficult column to -* the index of the previous difficult column. + LSTICC = ITEMP * - LSTICC = ITEMP - END DO -* - END IF + END DO * RETURN * From 9ea14cddadb078306a45f5146ac57a7278d3387a Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:06 -0800 Subject: [PATCH 032/106] in DLAQP2RK moved ABSTOL condition into ELSE clause of IF(I.EQ.1) --- SRC/dlaqp2rk.f | 43 +++++++++++++++++++++++-------------------- 1 file changed, 23 insertions(+), 20 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 806550b56b..19f0d18bbb 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -339,6 +339,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * main routine. * KP = KP1 +* TODO: optimize MAXC2NRMK and RELMAXC2NRMK MAXC2NRMK = MAXC2NRM RELMAXC2NRMK = ONE * @@ -396,36 +397,38 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * ============================================================ * - END IF +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL >= ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is +* non-negative. * -* ================================================================== + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN * -* Test for the second and third stopping criteria. -* NOTE: There is no need to test for ABSTOL >= ZERO, since -* MAXC2NRMK is non-negative. Similarly, there is no need -* to test for RELTOL >= ZERO, since RELMAXC2NRMK is -* non-negative. +* Set KF, the number of factorized columns. * - IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN + KF = K - 1 * -* Set KF, the number of factorized columns. +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. * - KF = K - 1 + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO * -* Set TAUs corresponding to the columns that were not -* factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. +* Return from the routine. * - DO J = K, MINMNFACT - TAU( J ) = ZERO - END DO + RETURN * -* Return from the routine. + END IF +* +* ============================================================ * - RETURN +* End ELSE of IF(I.EQ.1) * END IF * -* ================================================================== +* =============================================================== * * If the pivot column is not the first column of the * subblock A(1:M,K:N): @@ -459,8 +462,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, TAU( K ) = ZERO END IF * -* Apply H(K)**T to A(I:M,K+1:N+NRHS) from the left. -* ( If M >= N, then at K = N there is no residual matrix, +* Apply H(K)**T to A(I:M,K+1:N+NRHS) from the left. +* ( If M >= N, then at K = N there is no residual matrix, * i.e. no columns of A to update, only columns of B ) * If M < N, then at K = M-IOFFSET, I = M and we have a * one-row residual matrix in A and the elementary From 8391371122e70ecfc0b7c68fc58ddb44e64b3ec4 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 033/106] added to the description of DGEQP3Rk, DLAQP2RK and DLAQP3RK references to Zlatko Drmac paper in ACM Trans. Math. Softw. --- SRC/dgeqp3rk.f | 5 +++++ SRC/dlaqp2rk.f | 5 +++++ SRC/dlaqp3rk.f | 5 +++++ 3 files changed, 15 insertions(+) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index ce7c20f23b..5f47c2d4d2 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -501,6 +501,11 @@ *> \htmlonly *> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf *> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly * * ===================================================================== SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 19f0d18bbb..29476133ed 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -265,6 +265,11 @@ *> \htmlonly *> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf *> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly * * ===================================================================== SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 8563de9194..be803219d8 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -313,6 +313,11 @@ *> \htmlonly *> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf *> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly * * ===================================================================== SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, From 214842c9bd6189152adf1543ffcd1acfc3ca8f15 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 034/106] changed the meaing of K to mean the rank of R instead of the number of fctorizaed colums --- SRC/dgeqp3rk.f | 23 +++++-------- SRC/dlaqp2rk.f | 25 +++++++------- SRC/dlaqp3rk.f | 89 +++++++++++++++++++++++++++----------------------- 3 files changed, 70 insertions(+), 67 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 5f47c2d4d2..8994ee5cce 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -320,11 +320,14 @@ *> \param[out] K *> \verbatim *> K is INTEGER -*> The number of columns that were factorized. -*> K is the factorization rank. +*> The rank of the factor R, which is the same as +*> the number of factorized columns that were non-zero. *> 0 <= K <= min( M, min(KMAX,N) ). *> -*> If K = 0, the arrays A, TAU, JPIV were not modified. +*> NOTE: If K = 0, the arrays A and B are not modified; +*> the array TAU(1:min(M,N)) is set to ZERO; +*> the elements of the array JPIV are set as +*> follows: for j = 1:N, JPIV(j) = j. *> \endverbatim *> *> \param[out] MAXC2NRMK @@ -384,7 +387,7 @@ *> TAU is DOUBLE PRECISION array, dimension (min(M,N)) *> The scalar factors of the elementary reflectors. *> -*> If 0 < K <= MIN(M,N), only elements TAU(1:K) of +*> If 0 < K <= min(M,N), only the elements TAU(1:K) of *> the array TAU may be modified. The elements *> TAU(K+1:min(M,N)) are set to zero. *> If K = 0, all elements of TAU are set to zero. @@ -535,7 +538,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. - LOGICAL LQUERY, DONE, USETOL + LOGICAL LQUERY, DONE INTEGER IWS, J, JB, JBF, JMAXB, JMAX, $ JMAXC2NRM, KP1, LWKOPT, MINMN, NA, NB, NBMIN, $ NX @@ -681,22 +684,18 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * ================================================================== * EPS = DLAMCH('Epsilon') -* - USETOL = .FALSE. * * Adjust ABSTOL * IF( ABSTOL.GE.ZERO ) THEN SAFMIN = DLAMCH('Safe minimum') ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) - USETOL = .TRUE. END IF * * Adjust RELTOL * IF( RELTOL.GE.ZERO ) THEN RELTOL = MAX( RELTOL, EPS ) - USETOL = .TRUE. END IF * * =================================================================== @@ -715,11 +714,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, WRITE(*,*) "======= DGEQP3RK ((( ZERO MATRIX ))) ====" - IF( USETOL ) THEN - K = 0 - ELSE - K = JMAX - END IF + K = 0 * MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 29476133ed..0b6fa1f396 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -87,9 +87,10 @@ *> The first factorization stopping criterion. *> *> The maximum number of columns of the matrix A to factorize, -*> i.e. the maximum factorization rank. KMAX >= 0. +*> i.e. the maximum factorization rank. +*> 0 <= KMAX <= min(M-IOFFSET,N). *> -*> a) If KMAX >= min(M-IOFFSET,N), then this stopping +*> a) If KMAX = min(M-IOFFSET,N), then this stopping *> criterion is not used, factorize columns *> depending on ABSTOL and RELTOL. *> @@ -134,7 +135,8 @@ *> \verbatim *> KP1 is INTEGER *> The index of the column with the maximum column 2-norm in -*> the whole original matrix A. KP1 > 0. +*> the whole original matrix A_orig in original matrix A_orig +*> indexing scheme. 0 < KP1 <= N_orig_mat. *> \endverbatim *> *> \param[in] MAXC2NRM @@ -180,7 +182,10 @@ *> \param[out] KF *> \verbatim *> KF is INTEGER -*> The number of columns actually factorized. +*> Factorization rank of the matrix A, +*> i.e. the rank of the factor R, i.e. +*> the number of factorized partial columns that are non-zero +*> at each step. 0 <= KF <= min(M-IOFFSET,N). *> \endverbatim *> *> \param[out] MAXC2NRMK @@ -377,15 +382,11 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * IF( MAXC2NRMK.EQ.ZERO ) THEN * -* Set KF, the number of factorized columns. -* TODO: fix USETOL - IF( MAXC2NRMK.LE.ABSTOL - $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* Set KF, the number of factorized columns +* that are not zero relative to the original +* whole matrix A, i.e. the rank of the factor R. * - KF = K - 1 - ELSE - KF = KMAX - END IF + KF = K - 1 * * Set TAUs corresponding to the columns that were not * factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index be803219d8..c456bf2dd4 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -103,7 +103,11 @@ *> \param[in] NB *> \verbatim *> NB is INTEGER -*> The number of columns to factorize. +*> Factorization block size, i.e the number of columns +*> to factorize in the matrix A. 0 <= NB <= min(M-IOFFSET,N). +*> +*> If NB = 0, then the routine exits immediately. +*> This means that the factorization is not performed. *> \endverbatim *> *> \param[in] ABSTOL @@ -128,25 +132,27 @@ *> The tolerance (stopping threshold) for the ratio *> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of *> the residual matrix R22(K) and the maximum column 2-norm of -*> the original matrix A. The algorithm converges (stops the -*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less -*> than or equal to RELTOL. +*> the original matrix A_orig. The algorithm converges (stops +*> the factorization), when abs(R(K+1,K+1))/abs(R(1,1)) is +*> less than or equal to RELTOL. *> *> Here, abs(R(1,1)) is the maximum column 2-norm of the -*> original matrix A; EPS = DLAMCH('E'). +*> original matrix A_orig; EPS = DLAMCH('E'). *> \endverbatim *> *> \param[in] KP1 *> \verbatim *> KP1 is INTEGER *> The index of the column with the maximum column 2-norm in -*> the whole original matrix A. KP1 > 0. +*> the whole original matrix A_orig in original matrix A_orig +*> indexing scheme. 0 < KP1 <= N_orig_mat. *> \endverbatim *> *> \param[in] MAXC2NRM *> \verbatim *> MAXC2NRM is DOUBLE PRECISION -*> The maximum column 2-norm of the whole original matrix. +*> The maximum column 2-norm of the whole original +*> matrix A_orig. *> MAXC2NRMK >= 0. *> \endverbatim *> @@ -194,14 +200,19 @@ *> \param[out] KB *> \verbatim *> KB is INTEGER -*> The number of columns actually factorized. +*> Factorization rank of the matrix A, +*> i.e. the rank of the factor R, i.e. +*> the number of actually factorized partial columns that are +*> non-zero at each step. 0 <= KB <= min(M-IOFFSET,N). *> \endverbatim *> *> \param[out] KF *> \verbatim *> KF is INTEGER -*> The number of columns of the original whole matrix A -*> factorized. +*> Factorization rank of the original whole matrix A_orig, +*> i.e. the rank of the factor R_orig, i.e. +*> the number of actually factorized partial columns that are +*> non-zero at each step. 0 <= KF <= min(M,N+IOFFSET). *> \endverbatim * *> \param[out] MAXC2NRMK @@ -209,7 +220,7 @@ *> MAXC2NRMK is DOUBLE PRECISION *> The maximum column 2-norm of the residual matrix A22(K), *> when factorization stopped at rank K. MAXC2NRMK >= 0. -*> ( Rank K is with respect to the original matrix A ) +*> ( Rank K is with respect to the original matrix A_orig ) *> \endverbatim *> *> \param[out] MAXC2NRMK @@ -225,7 +236,7 @@ *> The ratio MAXC2NRMK / MAXC2NRM of the maximum column *> 2-norm of the residual matrix A22 ( when factorization *> stopped) and the maximum column 2-norm of the -*> original matrix A. RELMAXC2NRMK >= 0. +*> original matrix A_orig. RELMAXC2NRMK >= 0. *> \endverbatim *> *> \param[out] JPIV @@ -388,7 +399,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * IF( I.EQ.1 ) THEN * -* We are at the first column of the original whole matrix A, +* We are at the first column of the original whole matrix A_orig, * therefore we use the computed KP1 and MAXC2NRM from the * main routine. * @@ -417,7 +428,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * Quick return, if the submatrix A(I:M,K:N) is * a zero matrix. We need to check it only if the column index * (same as row index) is larger than 2, since the condition -* for the whole original matrix is checked in the main +* for the whole original matrix A_orig is checked in the main * routine. * IF( MAXC2NRMK.EQ.ZERO ) THEN @@ -428,32 +439,24 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * DONE = .TRUE. * -* Set KB, the number of factorized columns in the block; +* Set KB, the number of factorized partial columns +* that are non-zero at each step in the block, +* i.e. the rank of the factor R. * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in -* the original whole matrix A; -* Set KF, the number of factorized columns in the original -* whole matrix A. -* TODO: fix USETOL - IF( MAXC2NRMK.LE.ABSTOL - $ .OR. RELMAXC2NRMK.LE.RELTOL ) THEN - - +* the original whole matrix A_orig; +* Set KF, the number of factorized partial columns that +* are non zero at each step in the whole original +* whole matrix A_orig, i.e. the rank of the +* factor R_orig. KF = IOFFSET+KB = IF. +* WRITE(*,*) $ "$$$$$$$$ DLAQP3RK zero submatrix (ABSTOL, K)= ", $ ABSTOL, K * - KB = K - 1 - IF = I - 1 - KF = IOFFSET + KB -* - ELSE -* - KB = K - 1 - IF = I - 1 - KF = KMAX -* - END IF + KB = K - 1 + IF = I - 1 + KF = IF * * There is no need to apply the block reflector to the * residual of the matrix A stored in A(KB+1:M,KB+1:N), @@ -507,12 +510,16 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * DONE = .TRUE. * -* Set KB, the number of factorized columns in the block; +* Set KB, the number of factorized partial columns +* that are non-zero at each step in the block, +* i.e. the rank of the factor R. * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in -* the original whole matrix A; -* Set KF, the number of factorized columns in the original -* whole matrix A, KF = IOFFSET+KB = IF. +* the original whole matrix A_orig; +* Set KF, the number of factorized partial columns that +* are non zero at each step in the whole original +* whole matrix A_orig, i.e. the rank of the +* factor R_orig. KF = IOFFSET+KB = IF. * KB = K - 1 IF = I - 1 @@ -581,7 +588,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * for VN1 and VN2 since we use the element with the index * larger than K in the next loop step.) * 4) Save the pivot interchange with the indices relative to the -* the original matrix A, not the block A(1:M,1:N). +* the original matrix A_orig, not the block A(1:M,1:N). * IF( KP.NE.K ) THEN CALL DSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) @@ -702,9 +709,9 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * Set KB, the number of factorized columns in the block; * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in -* the original whole matrix A, IF = IOFFSET + KB; +* the original whole matrix A_orig, IF = IOFFSET + KB; * Set KF, the number of factorized columns in the original -* whole matrix A, KF = IOFFSET+KB = IF. +* whole matrix A_orig, KF = IOFFSET+KB = IF. * KB = K IF = I From ecaf99b88ce5fc6e877dc9b558de2cfb70cdeb2c Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 035/106] removed KF argument in DLAQP3RK, KF is the number of factorized partial columns in the whole original matrix indexing --- SRC/dgeqp3rk.f | 6 ++++-- SRC/dlaqp3rk.f | 34 ++++++---------------------------- 2 files changed, 10 insertions(+), 30 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 8994ee5cce..37d7b76c57 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -824,7 +824,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, CALL DLAQP3RK( M, N-J+1, NRHS, J-1, JB, KMAX, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, - $ DONE, JBF, KF, MAXC2NRMK, RELMAXC2NRMK, + $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, $ JPIV( J ), TAU( J ), $ WORK( J ), WORK( N+J ), $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), @@ -843,12 +843,14 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * return from the routine. Perform the following before * returning: * a) Set the number of factorized columns K, +* K = OFFSET + JBF from the last call of blocked +* routine. * NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned * by the block factorization routine; * 2) The remaining TAUs are set to ZERO by the * block factorization routine. * - K = KF + K = J - 1 * * Return from the routine. * diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index c456bf2dd4..1b20c0a218 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -20,11 +20,11 @@ * * SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * $ RELTOL, KP1, MAXC2NRM, A, LDA, KB, DONE, -* $ KF, MAXC2NRMK, RELMAXC2NRMK, +* $ MAXC2NRMK, RELMAXC2NRMK, * $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) * IMPLICIT NONE * LOGICAL DONE -* INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, KMAX, N, +* INTEGER IOFFSET, KB, KP1, LDA, LDF, M, KMAX, N, * $ NB, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, * $ RELTOL @@ -206,15 +206,6 @@ *> non-zero at each step. 0 <= KB <= min(M-IOFFSET,N). *> \endverbatim *> -*> \param[out] KF -*> \verbatim -*> KF is INTEGER -*> Factorization rank of the original whole matrix A_orig, -*> i.e. the rank of the factor R_orig, i.e. -*> the number of actually factorized partial columns that are -*> non-zero at each step. 0 <= KF <= min(M,N+IOFFSET). -*> \endverbatim -* *> \param[out] MAXC2NRMK *> \verbatim *> MAXC2NRMK is DOUBLE PRECISION @@ -333,7 +324,7 @@ * ===================================================================== SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, - $ KF, MAXC2NRMK, RELMAXC2NRMK, + $ MAXC2NRMK, RELMAXC2NRMK, $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) IMPLICIT NONE * @@ -343,7 +334,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * * .. Scalar Arguments .. LOGICAL DONE - INTEGER IOFFSET, KB, KF, KP1, LDA, LDF, M, KMAX, N, + INTEGER IOFFSET, KB, KP1, LDA, LDF, M, KMAX, N, $ NB, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL @@ -444,11 +435,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * i.e. the rank of the factor R. * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in -* the original whole matrix A_orig; -* Set KF, the number of factorized partial columns that -* are non zero at each step in the whole original -* whole matrix A_orig, i.e. the rank of the -* factor R_orig. KF = IOFFSET+KB = IF. +* the original whole matrix A_orig. * WRITE(*,*) $ "$$$$$$$$ DLAQP3RK zero submatrix (ABSTOL, K)= ", @@ -456,7 +443,6 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * KB = K - 1 IF = I - 1 - KF = IF * * There is no need to apply the block reflector to the * residual of the matrix A stored in A(KB+1:M,KB+1:N), @@ -516,14 +502,9 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in * the original whole matrix A_orig; -* Set KF, the number of factorized partial columns that -* are non zero at each step in the whole original -* whole matrix A_orig, i.e. the rank of the -* factor R_orig. KF = IOFFSET+KB = IF. * KB = K - 1 IF = I - 1 - KF = IF WRITE(*,*) "$$$$$$$$$$ DLAQP3RK condition for", $ " ABSTOL or RELTOL (ABSTOL, RELTOL),", @@ -709,13 +690,10 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * Set KB, the number of factorized columns in the block; * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in -* the original whole matrix A_orig, IF = IOFFSET + KB; -* Set KF, the number of factorized columns in the original -* whole matrix A_orig, KF = IOFFSET+KB = IF. +* the original whole matrix A_orig, IF = IOFFSET + KB. * KB = K IF = I - KF = IF * * Apply the block reflector to the residual of the matrix A * and the residual of the right hand sides B, if the residual From 6aac08032d96c39b9504696bbf67e0db143f7904 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 036/106] added NaN and INf checks to dgeqp3rk.f dlaqp2rk.f dlaqp3rk.f --- SRC/dgeqp3rk.f | 179 +++++++++++++++++++++++++++++++++--------- SRC/dlaqp2rk.f | 151 +++++++++++++++++++++++++++++++---- SRC/dlaqp3rk.f | 209 +++++++++++++++++++++++++++++++++++++++++++++---- 3 files changed, 472 insertions(+), 67 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 37d7b76c57..233ff3ccfb 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -424,8 +424,39 @@ *> \param[out] INFO *> \verbatim *> INFO is INTEGER -*> = 0: successful exit. -*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) INFO > 0: exception occured, i.e. +*> +*> NaN, +Inf (or -Inf) element was detected in the +*> matrix A, either on input or during the computation. +*> or NaN element was detected in the array TAU +*> during the computation. +*> +*> 3a) If INFO = j1, where 1 <= j1 <= N, then NaN was +*> detected and routine stops the computation. +*> The j1-th column of the matrix A or in the j1-th +*> element of array TAU contains the first occurence +*> of NaN at K+1 factorization step ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRM is set to NaN. +*> RELMAXC2NRM is set to NaN. +*> TAU(K+1:MINMNFACT) is not set and contains undefined +*> elements. If j=K+1, TAU(K+1) may +*> contain NaN. +*> 3b) If INFO = j2, where N+1 <= j2 <= 2N, then +*> no NaN element was detected, but +Inf (or -Inf) +*> was detected and routine continued the computation +*> until completion. +*> The j2-th column of the matrix A contains the first +*> occurence of +Inf (or -Inf) at K+1 factorization +*> step K+1 ( when K columns have been factorized ). *> \endverbatim * * Authors: @@ -539,10 +570,10 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * .. * .. Local Scalars .. LOGICAL LQUERY, DONE - INTEGER IWS, J, JB, JBF, JMAXB, JMAX, - $ JMAXC2NRM, KP1, LWKOPT, MINMN, NA, NB, NBMIN, - $ NX - DOUBLE PRECISION EPS, MAXC2NRM, SAFMIN + INTEGER IINFO, IOFFSET, IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, N_SUB, NB, + $ NBMIN, NX + DOUBLE PRECISION EPS, HUGEVAL, MAXC2NRM, SAFMIN * .. * .. External Subroutines .. EXTERNAL DLAQP2RK, DLAQP3RK, XERBLA @@ -667,6 +698,66 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, KP1 = IDAMAX( N, WORK( 1 ), 1 ) MAXC2NRM = WORK( KP1 ) * +* ==================================================================. +* + IF( DISNAN( MAXC2NRM ) ) THEN +* +* Check if the matrix A contains NaN, set INFO parameter +* to the column number where the first NaN is found and return +* from the routine. +* + K = 0 + INFO = KP1 +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = MAXC2NRM +* +* Array TAU is not set and contains undefined elements. +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* =================================================================== +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* +* Check is the matrix A is a zero matrix, set array TAU and +* return from the routine. +* + WRITE(*,*) "======= DGEQP3RK ((( ZERO MATRIX ))) ====" + + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN +* + END IF +* +* =================================================================== +* + HUGEVAL = DLAMCH( 'Overflow' ) +* + IF( MAXC2NRM.GT.HUGEVAL ) THEN +* +* Check if the matrix A contains +Inf or -Inf, set INFO parameter +* to the column number, where the first +/-Inf is found plus N, +* and continue the computation. +* + INFO = N + KP1 +* + END IF +* +* ================================================================== +* * Quick return if possible for the case when the first * stopping criterion is satisfied, i.e. KMAX = 0. * @@ -704,28 +795,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * which is also limited by the first stopping criterion KMAX. * JMAX = MIN( KMAX, MINMN ) - -* =================================================================== -* -* Quick return, if A is a zero matrix. -* - IF( MAXC2NRM.EQ.ZERO ) THEN -* - - WRITE(*,*) "======= DGEQP3RK ((( ZERO MATRIX ))) ====" - - K = 0 -* - MAXC2NRMK = ZERO - RELMAXC2NRMK = ZERO -* - DO J = 1, MINMN - TAU( J ) = ZERO - END DO -* - WORK( 1 ) = DBLE( LWKOPT ) - RETURN - END IF * * =================================================================== * @@ -810,11 +879,15 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * routine in a loop step; * JBF is the number of columns that were actually factorized * that was returned by the block factorization routine -* in a loop step, JBF <= JB. +* in a loop step, JBF <= JB; +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. * DO WHILE( J.LE.JMAXB ) * JB = MIN( NB, JMAXB-J+1 ) + N_SUB = N-J+1 + IOFFSET = J-1 * * Factorize JB columns among the columns A(J:N). * @@ -822,18 +895,27 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, WRITE(*,*) "===== DGEQP3RK loop before block(IOFFSET, JB)=", $ J-1, JB - CALL DLAQP3RK( M, N-J+1, NRHS, J-1, JB, KMAX, ABSTOL, + CALL DLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, KMAX, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, $ JPIV( J ), TAU( J ), $ WORK( J ), WORK( N+J ), $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), - $ N+NRHS-J+1, IWORK ) + $ N+NRHS-J+1, IWORK, IINFO ) * - J = J + JBF WRITE(*,*) "======= DGEQP3RK loop after block (JBF)=", $ JBF +* +* Set INFO on the first exception occurence. +* + IF( INFO.EQ.0 ) THEN + IF( IINFO.GT.N_SUB ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF + END IF * IF( DONE ) THEN * @@ -843,14 +925,14 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * return from the routine. Perform the following before * returning: * a) Set the number of factorized columns K, -* K = OFFSET + JBF from the last call of blocked +* K = IOFFSET + JBF from the last call of blocked * routine. * NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned * by the block factorization routine; * 2) The remaining TAUs are set to ZERO by the * block factorization routine. * - K = J - 1 + K = IOFFSET + JBF * * Return from the routine. * @@ -859,6 +941,8 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, RETURN * END IF +* + J = J + JBF * END DO * @@ -872,11 +956,18 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * IF( J.LE.JMAX ) THEN * - CALL DLAQP2RK( M, N-J+1, NRHS, J-1, JMAX-J+1, ABSTOL, - $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, KF, - $ MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + N_SUB = N-J+1 + IOFFSET = J-1 +* +* + CALL DLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, + $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ KF, MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), $ TAU( J ), WORK( J ), WORK( N+J ), - $ WORK( 2*N+1 ) ) + $ WORK( 2*N+1 ), IINFO ) * * ABSTOL or RELTOL criterion is satisfied when the number of * the factorized columns KF is smaller then the number @@ -887,7 +978,17 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * b) MAXC2NRMK and RELMAXC2NRMK are returned by the * unblocked factorization routine above. * - K = J - 1 + KF + K = J - 1 + KF +* +* Set INFO on the first exception occurence. +* + IF( INFO.EQ.0 ) THEN + IF( IINFO.GT.N_SUB ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF + END IF * ELSE * diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 0b6fa1f396..0e14ef7cc2 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -20,11 +20,12 @@ * * SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * $ KP1, MAXC2NRM, A, LDA, KF, MAXC2NRMK, -* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, +* $ INFO ) * IMPLICIT NONE * * .. Scalar Arguments .. -* INTEGER IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS +* INTEGER INFO, IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, * $ RELTOL * .. @@ -235,6 +236,44 @@ *> Used in DLARF subroutine to apply elementary *> reflector. *> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) INFO > 0: exception occured, i.e. +*> +*> NaN, +Inf (or -Inf) element was detected in the +*> matrix A, either on input or during the computation. +*> or NaN element was detected in the array TAU +*> during the computation. +*> +*> 3a) If INFO = j1, where 1 <= j1 <= N, then NaN was +*> detected and routine stops the computation. +*> The j1-th column of the matrix A or in the j1-th +*> element of array TAU contains the first occurence +*> of NaN at K+1 factorization step ( when K columns +*> have been factorized ). +*> +*> On exit: +*> KF is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRM is set to NaN. +*> RELMAXC2NRM is set to NaN. +*> TAU(K+1:MINMNFACT) is not set and contains undefined +*> elements. If j=K+1, TAU(K+1) may +*> contain NaN. +*> 3b) If INFO = j2, where N+1 <= j2 <= 2N, then +*> no NaN element was detected, but +Inf (or -Inf) +*> was detected and routine continued the computation +*> until completion. +*> The j2-th column of the matrix A contains the first +*> occurence of +Inf (or -Inf) at K+1 factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim * * Authors: * ======== @@ -279,7 +318,8 @@ * ===================================================================== SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, $ KP1, MAXC2NRM, A, LDA, KF, MAXC2NRMK, - $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK ) + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, + $ INFO ) IMPLICIT NONE * * -- LAPACK auxiliary routine -- @@ -287,7 +327,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. - INTEGER IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS + INTEGER INFO, IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL * .. @@ -306,7 +346,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * .. Local Scalars .. INTEGER I, ITEMP, J, JMAXC2NRM, K, KP, MINMNFACT, $ MINMNUPDT - DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z + DOUBLE PRECISION AIK, HUGEVAL, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, DSWAP @@ -315,12 +355,17 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. + LOGICAL DISNAN INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL IDAMAX, DLAMCH, DNRM2 + EXTERNAL DISNAN, DLAMCH, IDAMAX, DNRM2 * .. * .. Executable Statements .. * +* Initialize INFO +* + INFO = 0 +* * MINMNFACT in the smallest dimension of the submatrix * A(IOFFSET+1:M,1:N) to be factorized. * @@ -333,6 +378,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) KMAX = MIN( KMAX, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) + HUGEVAL = DLAMCH( 'Overflow' ) * * Compute the factorization. * @@ -367,26 +413,55 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * Determine the maximum column 2-norm and the relative maximum * column 2-norm of the submatrix A(I:M,K:N) at step K. +* RELMAXC2NRMK will be computed later, after somecondition +* checks on MAXC2NRMK. * MAXC2NRMK = VN1( KP ) -* TODO: optimize RELMAXC2NRMK - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains NaN, and set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( DISNAN( MAXC2NRMK ) ) THEN +* +* Set KF, the number of factorized columns. +* that are not zero. +* + KF = K - 1 + INFO = KF + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* + RETURN + END IF * * ============================================================ * * Quick return, if the submatrix A(I:M,K:N) is -* a zero matrix. We need to check the condition only if the +* a zero matrix. +* We need to check the condition only if the * column index (same as row index) of the original whole -* matrix is larger than 2, since the condition for whole +* matrix is larger than 1, since the condition for whole * original matrix is checked in the main routine. * IF( MAXC2NRMK.EQ.ZERO ) THEN * -* Set KF, the number of factorized columns -* that are not zero relative to the original -* whole matrix A, i.e. the rank of the factor R. +* Set KF, the number of factorized columns. +* that are not zero. * KF = K - 1 + RELMAXC2NRMK = ZERO * * Set TAUs corresponding to the columns that were not * factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. @@ -403,11 +478,32 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * ============================================================ * +* Check if the submatrix A(I:M,K:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + K - 1 + KP + END IF +* +* ============================================================ +* * Test for the second and third stopping criteria. * NOTE: There is no need to test for ABSTOL >= ZERO, since * MAXC2NRMK is non-negative. Similarly, there is no need * to test for RELTOL >= ZERO, since RELMAXC2NRMK is * non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. + + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM * IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN * @@ -468,6 +564,31 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, TAU( K ) = ZERO END IF * +* Check if TAU(K) is NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(K) for Inf, +* since *LARFG cannot produce TAU(K) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by *LARFG can contain Inf, which requires +* TAU(K) to be NaN. Therefore, this case of generating Inf by +* *DLARFG is covered by checking TAU(K) for NaN. +* + IF( DISNAN( TAU(K) ) ) THEN + KF = K - 1 + INFO = K +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAU( K ) + RELMAXC2NRMK = TAU( K ) +* +* Array TAU(K:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(K) = NaN. +* + RETURN + END IF +* * Apply H(K)**T to A(I:M,K+1:N+NRHS) from the left. * ( If M >= N, then at K = N there is no residual matrix, * i.e. no columns of A to update, only columns of B ) @@ -532,7 +653,9 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * END DO * -* Set the number of factorized columns +* If we reached this point, all colunms have been factorized, +* i.e. no condition was triggered to exit the routine. +* Set the number of factorized columns. * KF = KMAX * diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 1b20c0a218..2c1ef348c6 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -19,12 +19,12 @@ * =========== * * SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, -* $ RELTOL, KP1, MAXC2NRM, A, LDA, KB, DONE, -* $ MAXC2NRMK, RELMAXC2NRMK, -* $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) +* $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, +* $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) * IMPLICIT NONE * LOGICAL DONE -* INTEGER IOFFSET, KB, KP1, LDA, LDF, M, KMAX, N, +* INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, KMAX, N, * $ NB, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, * $ RELTOL @@ -280,6 +280,44 @@ *> of "bad" columns for norm downdating in the residual *> matrix ). *> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) INFO > 0: exception occured, i.e. +*> +*> NaN, +Inf (or -Inf) element was detected in the +*> matrix A, either on input or during the computation. +*> or NaN element was detected in the array TAU +*> during the computation. +*> +*> 3a) If INFO = j1, where 1 <= j1 <= N, then NaN was +*> detected and routine stops the computation. +*> The j1-th column of the matrix A or in the j1-th +*> element of array TAU contains the first occurence +*> of NaN at K+1 factorization step ( when K columns +*> have been factorized ). +*> +*> On exit: +*> KB is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRM is set to NaN. +*> RELMAXC2NRM is set to NaN. +*> TAU(K+1:MINMNFACT) is not set and contains undefined +*> elements. If j=K+1, TAU(K+1) may +*> contain NaN. +*> 3b) If INFO = j2, where N+1 <= j2 <= 2N, then +*> no NaN element was detected, but +Inf (or -Inf) +*> was detected and routine continued the computation +*> until completion. +*> The j2-th column of the matrix A contains the first +*> occurence of +Inf (or -Inf) at K+1 factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim * * Authors: * ======== @@ -324,8 +362,8 @@ * ===================================================================== SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, - $ MAXC2NRMK, RELMAXC2NRMK, - $ JPIV, TAU, VN1, VN2, AUXV, F, LDF, IWORK ) + $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) IMPLICIT NONE * * -- LAPACK auxiliary routine -- @@ -334,7 +372,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * * .. Scalar Arguments .. LOGICAL DONE - INTEGER IOFFSET, KB, KP1, LDA, LDF, M, KMAX, N, + INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, KMAX, N, $ NB, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL @@ -354,7 +392,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * .. Local Scalars .. INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, $ LSTICC, KP, I, IF - DOUBLE PRECISION AIK, TEMP, TEMP2, TOL3Z + DOUBLE PRECISION AIK, HUGEVAL, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP @@ -363,18 +401,24 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, INTRINSIC ABS, DBLE, MAX, MIN, SQRT * .. * .. External Functions .. + LOGICAL DISNAN INTEGER IDAMAX DOUBLE PRECISION DLAMCH, DNRM2 - EXTERNAL IDAMAX, DLAMCH, DNRM2 + EXTERNAL DISNAN, DLAMCH, IDAMAX, DNRM2 * .. * .. Executable Statements .. * +* Initialize INFO +* + INFO = 0 +* * MINMNFACT in the smallest dimension of the submatrix * A(IOFFSET+1:M,1:N) to be factorized. * MINMNFACT = MIN( M-IOFFSET, N ) MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) + HUGEVAL = DLAMCH( 'Overflow' ) * * Compute factorization in a while loop over NB columns, * K is the column index in the block A(1:M,1:N). @@ -411,14 +455,68 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * column 2-norm of the submatrix A(I:M,K:N) at step K. * MAXC2NRMK = VN1( KP ) -* TODO: optimize RELMAXC2NRMK - RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM * * ============================================================ * +* Check if the submatrix A(I:M,K:N) contains NaN, set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( DISNAN( MAXC2NRMK ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero at each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = KB + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. + + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, + $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), + $ LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* * Quick return, if the submatrix A(I:M,K:N) is * a zero matrix. We need to check it only if the column index -* (same as row index) is larger than 2, since the condition +* (same as row index) is larger than 1, since the condition * for the whole original matrix A_orig is checked in the main * routine. * @@ -443,6 +541,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * KB = K - 1 IF = I - 1 + RELMAXC2NRMK = ZERO * * There is no need to apply the block reflector to the * residual of the matrix A stored in A(KB+1:M,KB+1:N), @@ -463,8 +562,8 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, $ M-IF, NRHS, KB CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, - $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), - $ LDF, ONE, A( IF+1, N+1 ), LDA ) + $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), + $ LDF, ONE, A( IF+1, N+1 ), LDA ) END IF * * There is no need to recompute the 2-norm of the @@ -486,11 +585,32 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * * ============================================================ * +* Check if the submatrix A(I:M,K:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + K - 1 + KP + END IF +* +* ============================================================ +* * Test for the second and third tolerance stopping criteria. * NOTE: There is no need to test for ABSTOL.GE.ZERO, since * MAXC2NRMK is non-negative. Similarly, there is no need * to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is * non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM * IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN * @@ -596,6 +716,67 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, ELSE TAU( K ) = ZERO END IF +* +* Check if TAU(K) is NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(K) for Inf, +* since *LARFG cannot produce TAU(K) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by *LARFG can contain Inf, which requires +* TAU(K) to be NaN. Therefore, this case of generating Inf by +* *DLARFG is covered by checking TAU(K) for NaN. +* + IF( DISNAN( TAU(K) ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero at each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = K +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAU( K ) + RELMAXC2NRMK = TAU( K ) +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, + $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), + $ LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* =============================================================== * AIK = A( I, K ) A( I, K ) = ONE From 352ffe958f974e9f9b1d61a5cfa28bfcfecd6179 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 037/106] fixed grammatical error in the description of INFO in dgeqp3rk.f dlaqp2rk.f dlaqp3rk.f --- SRC/dgeqp3rk.f | 4 ++-- SRC/dlaqp2rk.f | 4 ++-- SRC/dlaqp3rk.f | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 233ff3ccfb..f145b7f1c6 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -452,8 +452,8 @@ *> contain NaN. *> 3b) If INFO = j2, where N+1 <= j2 <= 2N, then *> no NaN element was detected, but +Inf (or -Inf) -*> was detected and routine continued the computation -*> until completion. +*> was detected and the routine continues +*> the computation until completion. *> The j2-th column of the matrix A contains the first *> occurence of +Inf (or -Inf) at K+1 factorization *> step K+1 ( when K columns have been factorized ). diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 0e14ef7cc2..45295bcd3d 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -268,8 +268,8 @@ *> contain NaN. *> 3b) If INFO = j2, where N+1 <= j2 <= 2N, then *> no NaN element was detected, but +Inf (or -Inf) -*> was detected and routine continued the computation -*> until completion. +*> was detected and the routine continues +*> the computation until completion. *> The j2-th column of the matrix A contains the first *> occurence of +Inf (or -Inf) at K+1 factorization *> step K+1 ( when K columns have been factorized ). diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 2c1ef348c6..ae5870c018 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -312,8 +312,8 @@ *> contain NaN. *> 3b) If INFO = j2, where N+1 <= j2 <= 2N, then *> no NaN element was detected, but +Inf (or -Inf) -*> was detected and routine continued the computation -*> until completion. +*> was detected and the routine continues +*> the computation until completion. *> The j2-th column of the matrix A contains the first *> occurence of +Inf (or -Inf) at K+1 factorization *> step K+1 ( when K columns have been factorized ). From 785b734760e8919b4942c57ce22ad1d7dbbd359f Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 038/106] modified descriptions and corrected grammatical errors in dgeqp3rk.f dlaqp2rk.f dlaqp3rk.f --- SRC/dgeqp3rk.f | 80 +++++++++++++++++++++++++++++--------------------- SRC/dlaqp2rk.f | 61 ++++++++++++++++++++------------------ SRC/dlaqp3rk.f | 61 ++++++++++++++++++++++---------------- 3 files changed, 114 insertions(+), 88 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index f145b7f1c6..0322a5d8bf 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -43,7 +43,8 @@ *> Task 1: The routine computes a truncated (rank K) or full rank *> Householder QR factorization with column pivoting of a real *> M-by-N matrix A using Level 3 BLAS. K is the number of columns -*> that were factorized, i.e. factorization rank, K <= min(M,N). +*> that were factorized, i.e. factorization rank of the +*> factor R, K <= min(M,N). *> *> A * P(K) = Q(K) * R(K) = *> @@ -101,8 +102,8 @@ *> The algorithm stops when any of these conditions is first *> satisfied, otherwise the whole matrix A is factorized. *> -*> For full rank factorization use the values KMAX >= min(M,N), -*> ABSTOL < 0.0 and RELTOL < 0.0. +*> To factorize the whole matrix A, use the values +*> KMAX >= min(M,N), ABSTOL < 0.0 and RELTOL < 0.0. *> *> The routine returns: *> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), @@ -137,7 +138,7 @@ *> H(j) = I - tau * v * v**T, *> *> where 1 <= j <= K and -*> I is an M-by_M identity matrix, +*> I is an M-by-M identity matrix, *> tau is a real scalar, *> v is a real vector with v(1:j-1) = 0 and v(j) = 1. *> @@ -164,7 +165,7 @@ *> \param[in] NRHS *> \verbatim *> NRHS is INTEGER -*> The number of right hand sides, i.e., the number of +*> The number of right hand sides, i.e. the number of *> columns of the matrix B. NRHS >= 0. *> \endverbatim *> @@ -178,8 +179,8 @@ *> i.e. the maximum factorization rank. KMAX >= 0. *> *> a) If KMAX >= min(M,N), then this stopping criterion -*> is not used, factorize columns depending -*> on ABSTOL and RELTOL. +*> is not used, the routine factorizes columns +*> depending on ABSTOL and RELTOL. *> *> b) If KMAX = 0, then this stopping criterion is *> satisfied on input and the routine exits immediately. @@ -198,14 +199,15 @@ *> maximum column 2-norm of the residual matrix R22(K). *> The algorithm converges (stops the factorization) when *> the maximum column 2-norm of the residual matrix R22(K) -*> is less than or equal to ABSTOL. +*> is less than or equal to ABSTOL. Let SAFMIN = DLAMCH('S'). *> *> a) If ABSTOL is NaN, then no computation is performed *> and an error message ( INFO = -5 ) is issued *> by XERBLA. *> *> b) If ABSTOL < 0.0, then this stopping criterion is not -*> used, factorize columns depending on KMAX and RELTOL. +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. *> This includes the case ABSTOL = -Inf. *> *> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN @@ -214,16 +216,16 @@ *> d) If 2*SAFMIN <= ABSTOL then the input value *> of ABSTOL is used. *> -*> If ABSTOL chosen above is >= abs(R(1,1)), then this stopping -*> criterion is satisfied on input and routine exits -*> immediately after R(1,1) is computed to return it in -*> MAXC2NORMK, also RELMAXC2NORMK is returned as 1.0. +*> Let MAXC2NRM_WHOLE be the maximum column 2-norm of the +*> whole original matrix A. +*> If ABSTOL chosen above is >= MAXC2NRM_WHOLE, then this +*> stopping criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM_WHOLE is computed. The routine +*> returns MAXC2NRM_WHOLE in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. *> This includes the case ABSTOL = +Inf. This means that the *> factorization is not performed, the matrices A and B are not *> modified, and the matrix A is itself the residual. -*> -*> Here, abs(R(1,1)) is the maximum column 2-norm of the -*> original matrix A; SAFMIN = DLAMCH('S'). *> \endverbatim *> *> \param[in] RELTOL @@ -237,14 +239,15 @@ *> the residual matrix R22(K) and the maximum column 2-norm of *> the original matrix A. The algorithm converges (stops the *> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less -*> than or equal to RELTOL. +*> than or equal to RELTOL. Let EPS = DLAMCH('E'). *> *> a) If RELTOL is NaN, then no computation is performed *> and an error message ( INFO = -6 ) is issued *> by XERBLA. *> *> b) If RELTOL < 0.0, then this stopping criterion is not -*> used, factorize columns depending on KMAX and ABSTOL. +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. *> This includes the case RELTOL = -Inf. *> *> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. @@ -253,18 +256,19 @@ *> d) If EPS <= RELTOL then the input value of RELTOL *> is used. *> +*> Let MAXC2NRM_WHOLE be the maximum column 2-norm of the +*> whole original matrix A. *> If RELTOL chosen above is >= 1.0, then this stopping *> criterion is satisfied on input and routine exits -*> immediately after R(1,1) is computed to return it in -*> MAXC2NORMK, also RELMAXC2NORMK is returned as 1.0. +*> immediately after MAXC2NRM_WHOLE is computed. +*> The routine returns MAXC2NRM_WHOLE in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. *> This includes the case RELTOL = +Inf. This means that the *> factorization is not performed, the matrices A and B are not *> modified, and the matrix A is itself the residual. *> *> NOTE: We recommend RELTOL to satisfy *> min(max(M,N)*EPS, sqrt(EPS)) <= RELTOL -*> -*> Here, EPS = DLAMCH('E'). *> \endverbatim *> *> \param[in,out] A @@ -286,7 +290,7 @@ *> of the matrix A: *> *> 1) If K = 0, A(1:M,1:N) contains the original matrix A. -*> 2) If K > 0, A(1:M,1:N) contains parts of +*> 2) If K > 0, A(1:M,1:N) contains parts of the *> factors: *> *> 1. The elements below the diagonal of the subarray @@ -321,9 +325,16 @@ *> \verbatim *> K is INTEGER *> The rank of the factor R, which is the same as -*> the number of factorized columns that were non-zero. +*> the number of non-zero rows of the factor R. *> 0 <= K <= min( M, min(KMAX,N) ). *> +*> K can also be described as the number of factorized +*> partial columns at each factorization step that are +*> non-zero. +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> *> NOTE: If K = 0, the arrays A and B are not modified; *> the array TAU(1:min(M,N)) is set to ZERO; *> the elements of the array JPIV are set as @@ -333,7 +344,7 @@ *> \param[out] MAXC2NRMK *> \verbatim *> MAXC2NRMK is DOUBLE PRECISION -*> The maximum column 2-norm of the residual matrix A22(K), +*> The maximum column 2-norm of the residual matrix R22(K), *> when factorization stopped at rank K. MAXC2NRMK >= 0. *> *> a) If K = 0, i.e. the factorization was not performed, @@ -354,10 +365,10 @@ *> \param[out] RELMAXC2NRMK *> \verbatim *> RELMAXC2NRMK is DOUBLE PRECISION -*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column -*> 2-norm of the residual matrix A22(K) (when factorization +*> The ratio MAXC2NRMK / MAXC2NRM_WHOLE of the maximum column +*> 2-norm of the residual matrix R22(K) (when factorization *> stopped at rank K) and maximum column 2-norm of the -*> original matrix A. RELMAXC2NRMK >= 0. +*> whole original matrix A. RELMAXC2NRMK >= 0. *> *> a) If K = 0, i.e. the factorization was not performed, *> the matrix A was not modified and is itself a residual @@ -427,7 +438,7 @@ *> 1) INFO = 0: successful exit. *> 2) INFO < 0: if INFO = -i, the i-th argument had an *> illegal value. -*> 3) INFO > 0: exception occured, i.e. +*> 3) INFO > 0: exception occurred, i.e. *> *> NaN, +Inf (or -Inf) element was detected in the *> matrix A, either on input or during the computation. @@ -435,9 +446,9 @@ *> during the computation. *> *> 3a) If INFO = j1, where 1 <= j1 <= N, then NaN was -*> detected and routine stops the computation. +*> detected and the routine stops the computation. *> The j1-th column of the matrix A or in the j1-th -*> element of array TAU contains the first occurence +*> element of array TAU contains the first occurrence *> of NaN at K+1 factorization step ( when K columns *> have been factorized ). *> @@ -455,7 +466,7 @@ *> was detected and the routine continues *> the computation until completion. *> The j2-th column of the matrix A contains the first -*> occurence of +Inf (or -Inf) at K+1 factorization +*> occurrence of +Inf (or -Inf) at K+1 factorization *> step K+1 ( when K columns have been factorized ). *> \endverbatim * @@ -474,8 +485,9 @@ * *> \verbatim *> DGEQP3RK is based on the same BLAS3 Householder QR factorization -*> algorithm with column pivoting as in DGEQP3 routine which uses DGEQRF -*> to perform Householder QR factorization. +*> algorithm with column pivoting as in DGEQP3 routine which uses +*> DLARFG routine to generate Householder reflector +*> for QR factorization. *> *> We can also write: *> diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 45295bcd3d..6086dce2e5 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -43,10 +43,11 @@ *> *> DLAQP2RK computes a truncated (rank K) or full rank Householder QR *> factorization with column pivoting of the block A(IOFFSET+1:M,1:N). -*> The routine is calling Level 2 BLAS. The block A(1:IOFFSET,1:N) -*> is accordingly pivoted, but not factorized. The routine also -*> overwrites the matrix B block stored in A(IOFFSET+1:M,N+1:N+NRHS) -*> with Q(K)**T * B. +*> The routine is calling Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the matrix B block stored +*> in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**T * B. *> \endverbatim * * Arguments: @@ -77,8 +78,7 @@ *> The number of rows of the matrix A that must be pivoted *> but not factorized. IOFFSET also represents the number of *> columns of the original matrix that have been factorized -*> in the previous steps. -*> IOFFSET >= 0. +*> in the previous steps. IOFFSET >= 0. *> \endverbatim *> *> \param[in] KMAX @@ -91,15 +91,14 @@ *> i.e. the maximum factorization rank. *> 0 <= KMAX <= min(M-IOFFSET,N). *> -*> a) If KMAX = min(M-IOFFSET,N), then this stopping +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping *> criterion is not used, factorize columns *> depending on ABSTOL and RELTOL. *> *> b) If KMAX = 0, then this stopping criterion is *> satisfied on input and the routine exits immediately. *> This means that the factorization is not performed, -*> the matrices A and B are not modified, and -*> the matrix A is itself the residual. +*> the matrices A and B are not modified. *> \endverbatim *> *> \param[in] ABSTOL @@ -113,6 +112,14 @@ *> The algorithm converges (stops the factorization) when *> the maximum column 2-norm of the residual matrix R22(K) *> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. *> \endverbatim *> *> \param[in] RELTOL @@ -127,9 +134,6 @@ *> the original matrix A. The algorithm converges (stops the *> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less *> than or equal to RELTOL. -*> -*> Here, abs(R(1,1)) is the maximum column 2-norm of the -*> original matrix A; EPS = DLAMCH('E'). *> \endverbatim *> *> \param[in] KP1 @@ -143,8 +147,9 @@ *> \param[in] MAXC2NRM *> \verbatim *> MAXC2NRM is DOUBLE PRECISION -*> The maximum column 2-norm of the whole original matrix. -*> MAXC2NRMK >= 0. +*> The maximum column 2-norm of the whole original +*> matrix A_orig. +*> MAXC2NRM >= 0. *> \endverbatim *> *> \param[in,out] A @@ -158,12 +163,12 @@ *> *> On exit: *> 1. The elements in block A(IOFFSET+1:M,1:KF) below -*> the diagonal,together with the array TAU, represent +*> the diagonal together with the array TAU, represent *> the orthogonal matrix Q(K) as a product of elementary *> reflectors. *> 2. The block of the matrix A stored in A(IOFFSET+1:M,1:KF) *> is the triangular factor obtained. -*> 3. The block of the the matrix A stored in A(1:IOFFSET,1:N) +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) *> has been accordingly pivoted, but no factorized. *> 4. The rest of the array A, block A(IOFFSET+1:M,KF+1:N+NRHS). *> The left part A(IOFFSET+1:M,KF+1:N) of @@ -192,17 +197,17 @@ *> \param[out] MAXC2NRMK *> \verbatim *> MAXC2NRMK is DOUBLE PRECISION -*> The maximum column 2-norm of the residual matrix A22, -*> when factorization stopped. MAXC2NRMK >= 0. +*> The maximum column 2-norm of the residual matrix R22(K), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. *> \endverbatim *> *> \param[out] RELMAXC2NRMK *> \verbatim *> RELMAXC2NRMK is DOUBLE PRECISION -*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column -*> 2-norm of the residual matrix A22 ( when factorization -*> stopped) and the maximum column 2-norm of the -*> original matrix A. RELMAXC2NRMK >= 0. +*> The ratio MAXC2NRMK / MAXC2NRM_WHOLE of the maximum column +*> 2-norm of the residual matrix R22(K) (when factorization +*> stopped at rank K) and maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. *> \endverbatim *> *> \param[out] JPIV @@ -214,7 +219,7 @@ *> *> \param[out] TAU *> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> TAU is DOUBLE PRECISION array, dimension (min(M-IOFFSET,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> @@ -233,7 +238,7 @@ *> \param[out] WORK *> \verbatim *> WORK is DOUBLE PRECISION array, dimension (N) -*> Used in DLARF subroutine to apply elementary +*> Used in DLARF subroutine to apply an elementary *> reflector. *> \endverbatim *> @@ -243,7 +248,7 @@ *> 1) INFO = 0: successful exit. *> 2) INFO < 0: if INFO = -i, the i-th argument had an *> illegal value. -*> 3) INFO > 0: exception occured, i.e. +*> 3) INFO > 0: exception occurred, i.e. *> *> NaN, +Inf (or -Inf) element was detected in the *> matrix A, either on input or during the computation. @@ -251,9 +256,9 @@ *> during the computation. *> *> 3a) If INFO = j1, where 1 <= j1 <= N, then NaN was -*> detected and routine stops the computation. +*> detected and the routine stops the computation. *> The j1-th column of the matrix A or in the j1-th -*> element of array TAU contains the first occurence +*> element of array TAU contains the first occurrence *> of NaN at K+1 factorization step ( when K columns *> have been factorized ). *> @@ -271,7 +276,7 @@ *> was detected and the routine continues *> the computation until completion. *> The j2-th column of the matrix A contains the first -*> occurence of +Inf (or -Inf) at K+1 factorization +*> occurrence of +Inf (or -Inf) at K+1 factorization *> step K+1 ( when K columns have been factorized ). *> \endverbatim * diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index ae5870c018..fcbd505aee 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -48,9 +48,9 @@ *> \verbatim *> *> DLAQP3RK computes a step of truncated QR factorization with column -*> pivoting of a real M-by-N matrix A by using Level 3 BLAS. The routine +*> pivoting of a real M-by-N matrix A by using Level 3 BLAS. The routine *> tries to factorize NB columns from A starting from the row IOFFSET+1, -*> and updates all of the matrix with BLAS 3 xGEMM, the number of accually +*> and updates all of the matrix with BLAS 3 xGEMM, the number of actually *> factorized columns is returned in KB, KB <= NB. *> *> Cases when the number of factorized columns KB < NB: @@ -61,8 +61,14 @@ *> *> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, *> the factorization is stopped, the logical DONE is returned -*> as TRUE. The number of factorized columns which is smaller than NB -*> returned in KB. +*> as TRUE. The number of factorized columns which is smaller than NB +*> is returned in KB. +*> +*> (3) Whenever NaN is detected in the matrix A or in the array TAU, +*> the factorization is stopped, the logical DONE is returned +*> as TRUE. The number of factorized columns which is smaller than NB +*> is returned in KB. The INFO parameter is set to the column index +*> of the first NaN occurrence. *> *> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. *> @@ -97,7 +103,9 @@ *> \verbatim *> IOFFSET is INTEGER *> The number of rows of the matrix A that must be pivoted -*> but no factorized. IOFFSET >= 0. +*> but no factorized. IOFFSET also represents the number of +*> columns of the original matrix that have been factorized +*> in the previous steps. IOFFSET >= 0. *> \endverbatim *> *> \param[in] NB @@ -107,7 +115,8 @@ *> to factorize in the matrix A. 0 <= NB <= min(M-IOFFSET,N). *> *> If NB = 0, then the routine exits immediately. -*> This means that the factorization is not performed. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified. *> \endverbatim *> *> \param[in] ABSTOL @@ -121,6 +130,14 @@ *> The algorithm converges (stops the factorization) when *> the maximum column 2-norm of the residual matrix R22(K) *> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. *> \endverbatim *> *> \param[in] RELTOL @@ -135,9 +152,6 @@ *> the original matrix A_orig. The algorithm converges (stops *> the factorization), when abs(R(K+1,K+1))/abs(R(1,1)) is *> less than or equal to RELTOL. -*> -*> Here, abs(R(1,1)) is the maximum column 2-norm of the -*> original matrix A_orig; EPS = DLAMCH('E'). *> \endverbatim *> *> \param[in] KP1 @@ -167,12 +181,12 @@ *> *> On exit: *> 1. The elements in block A(IOFFSET+1:M,1:KB) below -*> the diagonal,together with the array TAU, represent +*> the diagonal together with the array TAU, represent *> the orthogonal matrix Q(K) as a product of elementary *> reflectors. *> 2. The block of the matrix A stored in A(IOFFSET+1:M,1:KB) *> is the triangular factor obtained. -*> 3. The block of the the matrix A stored in A(1:IOFFSET,1:N) +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) *> has been accordingly pivoted, but no factorized. *> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). *> The left part A(IOFFSET+1:M,KB+1:N) of @@ -190,13 +204,15 @@ *> \endverbatim *> *> \param[out] -*> *> \verbatim *> DONE is LOGICAL -*> TRUE, if the factorization completed, +*> TRUE, if the factorization completed before processing +*> all min(M-IOFFSET,N) columns due to ABSTOL or RELTOL +*> criterion, or when NaN was detected in the matrix A +*> or in the array TAU. *> FALSE, otherwise. *> \endverbatim -* +*> *> \param[out] KB *> \verbatim *> KB is INTEGER @@ -214,13 +230,6 @@ *> ( Rank K is with respect to the original matrix A_orig ) *> \endverbatim *> -*> \param[out] MAXC2NRMK -*> \verbatim -*> MAXC2NRMK is DOUBLE PRECISION -*> The maximum column 2-norm of the residual matrix A22, -*> when factorization stopped. MAXC2NRMK >= 0. -*> \endverbatim -*> *> \param[out] RELMAXC2NRMK *> \verbatim *> RELMAXC2NRMK is DOUBLE PRECISION @@ -239,7 +248,7 @@ *> *> \param[out] TAU *> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (NB) +*> TAU is DOUBLE PRECISION array, dimension (min(M-IOFFSET,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> @@ -287,7 +296,7 @@ *> 1) INFO = 0: successful exit. *> 2) INFO < 0: if INFO = -i, the i-th argument had an *> illegal value. -*> 3) INFO > 0: exception occured, i.e. +*> 3) INFO > 0: exception occurred, i.e. *> *> NaN, +Inf (or -Inf) element was detected in the *> matrix A, either on input or during the computation. @@ -295,9 +304,9 @@ *> during the computation. *> *> 3a) If INFO = j1, where 1 <= j1 <= N, then NaN was -*> detected and routine stops the computation. +*> detected and the routine stops the computation. *> The j1-th column of the matrix A or in the j1-th -*> element of array TAU contains the first occurence +*> element of array TAU contains the first occurrence *> of NaN at K+1 factorization step ( when K columns *> have been factorized ). *> @@ -315,7 +324,7 @@ *> was detected and the routine continues *> the computation until completion. *> The j2-th column of the matrix A contains the first -*> occurence of +Inf (or -Inf) at K+1 factorization +*> occurrence of +Inf (or -Inf) at K+1 factorization *> step K+1 ( when K columns have been factorized ). *> \endverbatim * From 33c8a2a392647136cc18efb6df21d2bf548f4c78 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 039/106] modified descriptions after review number 1 in dgeqp3rk.f dlaqp2rk.f dlaqp3rk.f --- SRC/dgeqp3rk.f | 121 +++++++++++++++++++-------------------- SRC/dlaqp2rk.f | 107 ++++++++++++++++++----------------- SRC/dlaqp3rk.f | 149 +++++++++++++++++++++++++++---------------------- 3 files changed, 201 insertions(+), 176 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 0322a5d8bf..0731f25186 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -53,7 +53,7 @@ *> *> where: *> -*> P(K) is a N-by-N permutation matrix; +*> P(K) is an N-by-N permutation matrix; *> Q(K) is an M-by-M orthogonal matrix; *> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the *> full rank factor R with K-by-K upper-triangular @@ -95,7 +95,7 @@ *> column 2-norm matrix of the residual matrix R22(K) divided *> by the maximum column 2-norm of the original matrix A, which *> is equal to abs(R(1,1)). This means that the factorization stops -*> when the ratio of the maximum column 2-norm of R22(K) and +*> when the ratio of the maximum column 2-norm of R22(K) to *> the maximum column 2-norm of A is less than or equal to RELTOL. *> If RELTOL < 0.0, the criterion is not used. *> @@ -110,7 +110,7 @@ *> R(K)_residual = R22(K), P(K), i.e. the resulting matrices *> of the factorization; P(K) is represented by JPIV, *> ( if K = min(M,N), R(K)_approx is the full factor R, -*> and there is no residual matrix R(K)_approx); +*> and there is no residual matrix R(K)_residual); *> b) K, the number of columns that were factorized, *> i.e. factorization rank; *> c) MAXC2NRMK, the maximum column 2-norm of the residual @@ -173,10 +173,10 @@ *> \verbatim *> KMAX is INTEGER *> -*> The first factorization stopping criterion. +*> The first factorization stopping criterion. KMAX >= 0. *> *> The maximum number of columns of the matrix A to factorize, -*> i.e. the maximum factorization rank. KMAX >= 0. +*> i.e. the maximum factorization rank. *> *> a) If KMAX >= min(M,N), then this stopping criterion *> is not used, the routine factorizes columns @@ -191,9 +191,9 @@ *> *> \param[in] ABSTOL *> \verbatim -*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> ABSTOL is DOUBLE PRECISION *> -*> The second factorization stopping criterion. +*> The second factorization stopping criterion, cannot be NaN. *> *> The absolute tolerance (stopping threshold) for *> maximum column 2-norm of the residual matrix R22(K). @@ -216,12 +216,12 @@ *> d) If 2*SAFMIN <= ABSTOL then the input value *> of ABSTOL is used. *> -*> Let MAXC2NRM_WHOLE be the maximum column 2-norm of the +*> Let MAXC2NRM be the maximum column 2-norm of the *> whole original matrix A. -*> If ABSTOL chosen above is >= MAXC2NRM_WHOLE, then this +*> If ABSTOL chosen above is >= MAXC2NRM, then this *> stopping criterion is satisfied on input and routine exits -*> immediately after MAXC2NRM_WHOLE is computed. The routine -*> returns MAXC2NRM_WHOLE in MAXC2NORMK, +*> immediately after MAXC2NRM is computed. The routine +*> returns MAXC2NRM in MAXC2NORMK, *> and 1.0 in RELMAXC2NORMK. *> This includes the case ABSTOL = +Inf. This means that the *> factorization is not performed, the matrices A and B are not @@ -230,13 +230,13 @@ *> *> \param[in] RELTOL *> \verbatim -*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> RELTOL is DOUBLE PRECISION *> -*> The third factorization stopping criterion. +*> The third factorization stopping criterion, cannot be NaN. *> *> The tolerance (stopping threshold) for the ratio *> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of -*> the residual matrix R22(K) and the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of *> the original matrix A. The algorithm converges (stops the *> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less *> than or equal to RELTOL. Let EPS = DLAMCH('E'). @@ -256,18 +256,18 @@ *> d) If EPS <= RELTOL then the input value of RELTOL *> is used. *> -*> Let MAXC2NRM_WHOLE be the maximum column 2-norm of the +*> Let MAXC2NRM be the maximum column 2-norm of the *> whole original matrix A. *> If RELTOL chosen above is >= 1.0, then this stopping *> criterion is satisfied on input and routine exits -*> immediately after MAXC2NRM_WHOLE is computed. -*> The routine returns MAXC2NRM_WHOLE in MAXC2NORMK, +*> immediately after MAXC2NRM is computed. +*> The routine returns MAXC2NRM in MAXC2NORMK, *> and 1.0 in RELMAXC2NORMK. *> This includes the case RELTOL = +Inf. This means that the *> factorization is not performed, the matrices A and B are not *> modified, and the matrix A is itself the residual. *> -*> NOTE: We recommend RELTOL to satisfy +*> NOTE: We recommend that RELTOL to satisfy *> min(max(M,N)*EPS, sqrt(EPS)) <= RELTOL *> \endverbatim *> @@ -310,7 +310,7 @@ *> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) *> rectangular matrix R(K)_residual = R22(K). *> -*> b) The subarray A(1:M,N+1:N+NRHS) contains +*> b) If NRHS > 0, the subarray A(1:M,N+1:N+NRHS) contains *> the M-by-NRHS product Q(K)**T * B. *> \endverbatim *> @@ -324,28 +324,27 @@ *> \param[out] K *> \verbatim *> K is INTEGER -*> The rank of the factor R, which is the same as -*> the number of non-zero rows of the factor R. -*> 0 <= K <= min( M, min(KMAX,N) ). -*> -*> K can also be described as the number of factorized -*> partial columns at each factorization step that are -*> non-zero. +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M,KMAX,N). *> *> K also represents the number of non-zero Householder *> vectors. *> -*> NOTE: If K = 0, the arrays A and B are not modified; -*> the array TAU(1:min(M,N)) is set to ZERO; -*> the elements of the array JPIV are set as -*> follows: for j = 1:N, JPIV(j) = j. +*> NOTE: If K = 0, a) the arrays A and B are not modified; +*> b) the array TAU(1:min(M,N)) is set to ZERO, +*> if the matrix A does not contain NaN, +*> otherwise the elements TAU(1:min(M,N)) +*> are undefimed; +*> c) the elements of the array JPIV are set +*> as follows: for j = 1:N, JPIV(j) = j. *> \endverbatim *> *> \param[out] MAXC2NRMK *> \verbatim *> MAXC2NRMK is DOUBLE PRECISION *> The maximum column 2-norm of the residual matrix R22(K), -*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. *> *> a) If K = 0, i.e. the factorization was not performed, *> the matrix A was not modified and is itself a residual @@ -358,7 +357,7 @@ *> factorized and there is no residual matrix, *> then MAXC2NRMK = 0.0. *> -*> NOTE: MAXC2NRMK at the factorization step K would equal +*> NOTE: MAXC2NRMK in the factorization step K would equal *> R(K+1,K+1) in the next factorization step K+1. *> \endverbatim *> @@ -366,8 +365,8 @@ *> \verbatim *> RELMAXC2NRMK is DOUBLE PRECISION *> The ratio MAXC2NRMK / MAXC2NRM_WHOLE of the maximum column -*> 2-norm of the residual matrix R22(K) (when factorization -*> stopped at rank K) and maximum column 2-norm of the +*> 2-norm of the residual matrix R22(K) (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the *> whole original matrix A. RELMAXC2NRMK >= 0. *> *> a) If K = 0, i.e. the factorization was not performed, @@ -381,7 +380,7 @@ *> factorized and there is no residual matrix, *> then RELMAXC2NRMK = 0.0. *> -*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> NOTE: RELMAXC2NRMK in the factorization step K would equal *> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization *> step K+1. *> \endverbatim @@ -399,9 +398,13 @@ *> The scalar factors of the elementary reflectors. *> *> If 0 < K <= min(M,N), only the elements TAU(1:K) of -*> the array TAU may be modified. The elements -*> TAU(K+1:min(M,N)) are set to zero. -*> If K = 0, all elements of TAU are set to zero. +*> the array TAU are modified by the factorization. +*> If no NaN was found during the factorization, +*> the remainig elements TAU(K+1:min(M,N)) are set to zero, +*> otherwise the elements TAU(K+1:min(M,N)) are not set +*> and therefore undefined. +*> ( If K = 0, all elements of TAU are set to zero, if +*> the matrix A does not cointain NaN. ) *> \endverbatim *> *> \param[out] WORK @@ -415,7 +418,7 @@ *> LWORK is INTEGER *> The dimension of the array WORK. LWORK >= 3*N+1. *> For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB -*> is the optimal block size for DGETRF returned by ILAENV. +*> is the optimal block size for DGEQP3RK returned by ILAENV. *> *> If LWORK = -1, then a workspace query is assumed; *> the routine only calculates the optimal size of the WORK @@ -437,36 +440,34 @@ *> INFO is INTEGER *> 1) INFO = 0: successful exit. *> 2) INFO < 0: if INFO = -i, the i-th argument had an -*> illegal value. -*> 3) INFO > 0: exception occurred, i.e. -*> -*> NaN, +Inf (or -Inf) element was detected in the -*> matrix A, either on input or during the computation. -*> or NaN element was detected in the array TAU -*> during the computation. -*> -*> 3a) If INFO = j1, where 1 <= j1 <= N, then NaN was -*> detected and the routine stops the computation. -*> The j1-th column of the matrix A or in the j1-th +*> illegal value. +*> 3) INFO > 0: NaN, +Inf (or -Inf) element was detected +*> in the matrix A, either on input or during +*> the computation, or NaN element was detected +*> in the array TAU during the computation. +*> +*> 3a) If INFO = j_1, where 1 <= j_1 <= N, then NaN element +*> was detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th *> element of array TAU contains the first occurrence -*> of NaN at K+1 factorization step ( when K columns +*> of NaN in the factorization step K+1 ( when K columns *> have been factorized ). *> *> On exit: *> K is set to the number of *> factorized columns without *> exception. -*> MAXC2NRM is set to NaN. -*> RELMAXC2NRM is set to NaN. -*> TAU(K+1:MINMNFACT) is not set and contains undefined -*> elements. If j=K+1, TAU(K+1) may +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) may *> contain NaN. -*> 3b) If INFO = j2, where N+1 <= j2 <= 2N, then +*> 3b) If INFO = j_2, where N+1 <= j_2 <= 2N, then *> no NaN element was detected, but +Inf (or -Inf) *> was detected and the routine continues *> the computation until completion. -*> The j2-th column of the matrix A contains the first -*> occurrence of +Inf (or -Inf) at K+1 factorization +*> The j_2-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization *> step K+1 ( when K columns have been factorized ). *> \endverbatim * @@ -486,7 +487,7 @@ *> \verbatim *> DGEQP3RK is based on the same BLAS3 Householder QR factorization *> algorithm with column pivoting as in DGEQP3 routine which uses -*> DLARFG routine to generate Householder reflector +*> DLARFG routine to generate Householder reflectors *> for QR factorization. *> *> We can also write: @@ -684,7 +685,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * * Initialize storage for partial and exact column 2-norms. * a) The elements WORK(1:N) are used to store partial column -* 2-norms of the matrix A, and may decrease at each computation +* 2-norms of the matrix A, and may decrease in each computation * step; initialize to the values of complete columns 2-norms. * b) The elements WORK(N+1:2*N) are used to store complete column * 2-norms of the matrix A, they are not changed during the diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 6086dce2e5..9931ccf1d8 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -85,20 +85,20 @@ *> \verbatim *> KMAX is INTEGER *> -*> The first factorization stopping criterion. +*> The first factorization stopping criterion. KMAX >= 0. *> *> The maximum number of columns of the matrix A to factorize, *> i.e. the maximum factorization rank. -*> 0 <= KMAX <= min(M-IOFFSET,N). *> *> a) If KMAX >= min(M-IOFFSET,N), then this stopping *> criterion is not used, factorize columns *> depending on ABSTOL and RELTOL. *> *> b) If KMAX = 0, then this stopping criterion is -*> satisfied on input and the routine exits immediately. -*> This means that the factorization is not performed, -*> the matrices A and B are not modified. +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. *> \endverbatim *> *> \param[in] ABSTOL @@ -108,9 +108,9 @@ *> The second factorization stopping criterion. *> *> The absolute tolerance (stopping threshold) for -*> maximum column 2-norm of the residual matrix R22(K). +*> maximum column 2-norm of the residual matrix. *> The algorithm converges (stops the factorization) when -*> the maximum column 2-norm of the residual matrix R22(K) +*> the maximum column 2-norm of the residual matrix *> is less than or equal to ABSTOL. *> *> a) If ABSTOL < 0.0, then this stopping criterion is not @@ -130,10 +130,18 @@ *> *> The tolerance (stopping threshold) for the ratio *> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of -*> the residual matrix R22(K) and the maximum column 2-norm of -*> the original matrix A. The algorithm converges (stops the -*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less -*> than or equal to RELTOL. +*> the residual matrix R22(K) to the maximum column 2-norm of +*> the original matrix A_orig. The algorithm converges (stops +*> the factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. *> \endverbatim *> *> \param[in] KP1 @@ -148,8 +156,7 @@ *> \verbatim *> MAXC2NRM is DOUBLE PRECISION *> The maximum column 2-norm of the whole original -*> matrix A_orig. -*> MAXC2NRM >= 0. +*> matrix A_orig. MAXC2NRM >= 0. *> \endverbatim *> *> \param[in,out] A @@ -172,11 +179,11 @@ *> has been accordingly pivoted, but no factorized. *> 4. The rest of the array A, block A(IOFFSET+1:M,KF+1:N+NRHS). *> The left part A(IOFFSET+1:M,KF+1:N) of -*> this block contains the residual of the matrix A, and -*> the right part of the block A(IOFFSET+1:M,N+1:N+NRHS) -*> contains the block of the right-hand-side matrix B. Both -*> these blocks have been updated by multiplication from -*> the left by Q**T. +*> this block contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q**T. *> \endverbatim *> *> \param[in] LDA @@ -188,26 +195,30 @@ *> \param[out] KF *> \verbatim *> KF is INTEGER -*> Factorization rank of the matrix A, -*> i.e. the rank of the factor R, i.e. -*> the number of factorized partial columns that are non-zero -*> at each step. 0 <= KF <= min(M-IOFFSET,N). +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= KF <= min(M-IOFFSET,KMAX,N). +*> +*> KF also represents the number of non-zero Householder +*> vectors. *> \endverbatim *> *> \param[out] MAXC2NRMK *> \verbatim *> MAXC2NRMK is DOUBLE PRECISION -*> The maximum column 2-norm of the residual matrix R22(K), -*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> ( Rank K is with respect to the original matrix A_orig. ) *> \endverbatim *> *> \param[out] RELMAXC2NRMK *> \verbatim *> RELMAXC2NRMK is DOUBLE PRECISION -*> The ratio MAXC2NRMK / MAXC2NRM_WHOLE of the maximum column -*> 2-norm of the residual matrix R22(K) (when factorization -*> stopped at rank K) and maximum column 2-norm of the +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the *> whole original matrix A. RELMAXC2NRMK >= 0. +*> ( Rank K is with respect to the original matrix A_orig. ) *> \endverbatim *> *> \param[out] JPIV @@ -246,37 +257,33 @@ *> \verbatim *> INFO is INTEGER *> 1) INFO = 0: successful exit. -*> 2) INFO < 0: if INFO = -i, the i-th argument had an -*> illegal value. -*> 3) INFO > 0: exception occurred, i.e. -*> -*> NaN, +Inf (or -Inf) element was detected in the -*> matrix A, either on input or during the computation. -*> or NaN element was detected in the array TAU -*> during the computation. -*> -*> 3a) If INFO = j1, where 1 <= j1 <= N, then NaN was -*> detected and the routine stops the computation. -*> The j1-th column of the matrix A or in the j1-th +*> 2) INFO > 0: NaN, +Inf (or -Inf) element was detected +*> in the matrix A, either on input or during +*> the computation, or NaN element was detected +*> in the array TAU during the computation. +*> +*> 2a) If INFO = j_1, where 1 <= j_1 <= N, then NaN element +*> was detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th *> element of array TAU contains the first occurrence -*> of NaN at K+1 factorization step ( when K columns +*> of NaN in the factorization step K+1 ( when K columns *> have been factorized ). *> *> On exit: -*> KF is set to the number of +*> K is set to the number of *> factorized columns without *> exception. -*> MAXC2NRM is set to NaN. -*> RELMAXC2NRM is set to NaN. -*> TAU(K+1:MINMNFACT) is not set and contains undefined -*> elements. If j=K+1, TAU(K+1) may +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) may *> contain NaN. -*> 3b) If INFO = j2, where N+1 <= j2 <= 2N, then +*> 2b) If INFO = j_2, where N+1 <= j_2 <= 2N, then *> no NaN element was detected, but +Inf (or -Inf) *> was detected and the routine continues *> the computation until completion. -*> The j2-th column of the matrix A contains the first -*> occurrence of +Inf (or -Inf) at K+1 factorization +*> The j_2-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization *> step K+1 ( when K columns have been factorized ). *> \endverbatim * @@ -410,14 +417,14 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * ============================================================ * -* Determine the pivot column at K-th step, i.e. the index +* Determine the pivot column in K-th step, i.e. the index * of the column with the maximum 2-norm in the * submatrix A(I:M,K:N). * KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) * * Determine the maximum column 2-norm and the relative maximum -* column 2-norm of the submatrix A(I:M,K:N) at step K. +* column 2-norm of the submatrix A(I:M,K:N) in step K. * RELMAXC2NRMK will be computed later, after somecondition * checks on MAXC2NRMK. * diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index fcbd505aee..4f2b1f73d7 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -50,13 +50,18 @@ *> DLAQP3RK computes a step of truncated QR factorization with column *> pivoting of a real M-by-N matrix A by using Level 3 BLAS. The routine *> tries to factorize NB columns from A starting from the row IOFFSET+1, -*> and updates all of the matrix with BLAS 3 xGEMM, the number of actually -*> factorized columns is returned in KB, KB <= NB. +*> and updates the residual matrix with BLAS 3 xGEMM, the number +*> of actually factorized columns is returned in KB, KB <= NB. +*> +*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides B block stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(K)**T * B. *> *> Cases when the number of factorized columns KB < NB: *> *> (1) In some cases, due to catastrophic cancellations, it cannot -*> factorize NB columns. Hence, the actual number of factorized +*> factorize NB columns. Hence, the actual number of factorized *> columns is returned in KB. *> *> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, @@ -64,17 +69,18 @@ *> as TRUE. The number of factorized columns which is smaller than NB *> is returned in KB. *> -*> (3) Whenever NaN is detected in the matrix A or in the array TAU, +*> (3) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix is a zero matrix in some factorization +*> step KB, the factorization is stopped, the logical DONE is returned +*> as TRUE. The number of factorized columns which is smaller than NB +*> is returned in KB. +*> +*> (4) Whenever NaN is detected in the matrix A or in the array TAU, *> the factorization is stopped, the logical DONE is returned *> as TRUE. The number of factorized columns which is smaller than NB *> is returned in KB. The INFO parameter is set to the column index *> of the first NaN occurrence. *> -*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. -*> -*> The routine also overwrites the right-hand-sides B block stored -*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(K)**T * B. -*> *> \endverbatim * * Arguments: @@ -103,20 +109,23 @@ *> \verbatim *> IOFFSET is INTEGER *> The number of rows of the matrix A that must be pivoted -*> but no factorized. IOFFSET also represents the number of -*> columns of the original matrix that have been factorized -*> in the previous steps. IOFFSET >= 0. +*> but no factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. *> \endverbatim *> *> \param[in] NB *> \verbatim *> NB is INTEGER *> Factorization block size, i.e the number of columns -*> to factorize in the matrix A. 0 <= NB <= min(M-IOFFSET,N). +*> to factorize in the matrix A. 0 <= NB *> *> If NB = 0, then the routine exits immediately. *> This means that the factorization is not performed, -*> the matrices A and B are not modified. +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. *> \endverbatim *> *> \param[in] ABSTOL @@ -126,9 +135,9 @@ *> The second factorization stopping criterion. *> *> The absolute tolerance (stopping threshold) for -*> maximum column 2-norm of the residual matrix R22(K). +*> maximum column 2-norm of the residual matrix. *> The algorithm converges (stops the factorization) when -*> the maximum column 2-norm of the residual matrix R22(K) +*> the maximum column 2-norm of the residual matrix *> is less than or equal to ABSTOL. *> *> a) If ABSTOL < 0.0, then this stopping criterion is not @@ -148,10 +157,18 @@ *> *> The tolerance (stopping threshold) for the ratio *> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of -*> the residual matrix R22(K) and the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of *> the original matrix A_orig. The algorithm converges (stops *> the factorization), when abs(R(K+1,K+1))/abs(R(1,1)) is *> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. *> \endverbatim *> *> \param[in] KP1 @@ -166,8 +183,7 @@ *> \verbatim *> MAXC2NRM is DOUBLE PRECISION *> The maximum column 2-norm of the whole original -*> matrix A_orig. -*> MAXC2NRMK >= 0. +*> matrix A_orig. MAXC2NRMK >= 0. *> \endverbatim *> *> \param[in,out] A @@ -190,11 +206,11 @@ *> has been accordingly pivoted, but no factorized. *> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). *> The left part A(IOFFSET+1:M,KB+1:N) of -*> this block contains the residual of the matrix A, and -*> the right part of the block A(IOFFSET+1:M,N+1:N+NRHS) -*> contains the block of the right-hand-side matrix B. Both -*> these blocks have been updated by multiplication from -*> the left by Q**T. +*> this block contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q**T. *> \endverbatim *> *> \param[in] LDA @@ -206,37 +222,41 @@ *> \param[out] *> \verbatim *> DONE is LOGICAL -*> TRUE, if the factorization completed before processing -*> all min(M-IOFFSET,N) columns due to ABSTOL or RELTOL -*> criterion, or when NaN was detected in the matrix A -*> or in the array TAU. -*> FALSE, otherwise. +*> TRUE: a) if the factorization completed before processing +*> all min(M-IOFFSET,N) columns due to ABSTOL +*> or RELTOL criterion, +*> b) when NaN was detected in the matrix A +*> or in the array TAU. +*> FALSE: otherwise. *> \endverbatim *> *> \param[out] KB *> \verbatim *> KB is INTEGER -*> Factorization rank of the matrix A, -*> i.e. the rank of the factor R, i.e. -*> the number of actually factorized partial columns that are -*> non-zero at each step. 0 <= KB <= min(M-IOFFSET,N). +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= KB <= min(M-IOFFSET,KB,N). +*> +*> KB also represents the number of non-zero Householder +*> vectors. *> \endverbatim *> *> \param[out] MAXC2NRMK *> \verbatim *> MAXC2NRMK is DOUBLE PRECISION -*> The maximum column 2-norm of the residual matrix A22(K), -*> when factorization stopped at rank K. MAXC2NRMK >= 0. -*> ( Rank K is with respect to the original matrix A_orig ) +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> ( Rank K is with respect to the original matrix A_orig. ) *> \endverbatim *> *> \param[out] RELMAXC2NRMK *> \verbatim *> RELMAXC2NRMK is DOUBLE PRECISION *> The ratio MAXC2NRMK / MAXC2NRM of the maximum column -*> 2-norm of the residual matrix A22 ( when factorization -*> stopped) and the maximum column 2-norm of the +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the *> original matrix A_orig. RELMAXC2NRMK >= 0. +*> ( Rank K is with respect to the original matrix A_orig. ) *> \endverbatim *> *> \param[out] JPIV @@ -273,7 +293,7 @@ *> \param[out] F *> \verbatim *> F is DOUBLE PRECISION array, dimension (LDF,NB) -*> Matrix F**T = L*Y**T*A. +*> Matrix F**T = L*(Y**T)*A. *> \endverbatim *> *> \param[in] LDF @@ -294,37 +314,33 @@ *> \verbatim *> INFO is INTEGER *> 1) INFO = 0: successful exit. -*> 2) INFO < 0: if INFO = -i, the i-th argument had an -*> illegal value. -*> 3) INFO > 0: exception occurred, i.e. -*> -*> NaN, +Inf (or -Inf) element was detected in the -*> matrix A, either on input or during the computation. -*> or NaN element was detected in the array TAU -*> during the computation. -*> -*> 3a) If INFO = j1, where 1 <= j1 <= N, then NaN was -*> detected and the routine stops the computation. -*> The j1-th column of the matrix A or in the j1-th +*> 2) INFO > 0: NaN, +Inf (or -Inf) element was detected +*> in the matrix A, either on input or during +*> the computation, or NaN element was detected +*> in the array TAU during the computation. +*> +*> 2a) If INFO = j_1, where 1 <= j_1 <= N, then NaN element +*> was detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th *> element of array TAU contains the first occurrence -*> of NaN at K+1 factorization step ( when K columns +*> of NaN in the factorization step K+1 ( when K columns *> have been factorized ). *> *> On exit: -*> KB is set to the number of +*> K is set to the number of *> factorized columns without *> exception. -*> MAXC2NRM is set to NaN. -*> RELMAXC2NRM is set to NaN. -*> TAU(K+1:MINMNFACT) is not set and contains undefined -*> elements. If j=K+1, TAU(K+1) may +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) may *> contain NaN. -*> 3b) If INFO = j2, where N+1 <= j2 <= 2N, then +*> 2b) If INFO = j_2, where N+1 <= j_2 <= 2N, then *> no NaN element was detected, but +Inf (or -Inf) *> was detected and the routine continues *> the computation until completion. -*> The j2-th column of the matrix A contains the first -*> occurrence of +Inf (or -Inf) at K+1 factorization +*> The j_2-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization *> step K+1 ( when K columns have been factorized ). *> \endverbatim * @@ -426,6 +442,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * MINMNFACT = MIN( M-IOFFSET, N ) MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + NB = MIN( NB, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) HUGEVAL = DLAMCH( 'Overflow' ) * @@ -454,14 +471,14 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * ELSE * -* Determine the pivot column at K-th step, i.e. the index +* Determine the pivot column in K-th step, i.e. the index * of the column with the maximum 2-norm in the * submatrix A(I:M,K:N). * KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) * * Determine the maximum column 2-norm and the relative maximum -* column 2-norm of the submatrix A(I:M,K:N) at step K. +* column 2-norm of the submatrix A(I:M,K:N) in step K. * MAXC2NRMK = VN1( KP ) * @@ -480,7 +497,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, DONE = .TRUE. * * Set KB, the number of factorized partial columns -* that are non-zero at each step in the block, +* that are non-zero in each step in the block, * i.e. the rank of the factor R. * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in @@ -538,7 +555,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, DONE = .TRUE. * * Set KB, the number of factorized partial columns -* that are non-zero at each step in the block, +* that are non-zero in each step in the block, * i.e. the rank of the factor R. * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in @@ -626,7 +643,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, DONE = .TRUE. * * Set KB, the number of factorized partial columns -* that are non-zero at each step in the block, +* that are non-zero in each step in the block, * i.e. the rank of the factor R. * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in @@ -741,7 +758,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, DONE = .TRUE. * * Set KB, the number of factorized partial columns -* that are non-zero at each step in the block, +* that are non-zero in each step in the block, * i.e. the rank of the factor R. * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in From 8ebb7c88fde571fac4d5057ebc833d5eaa541cb7 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 040/106] fixed INFO NaN and Inf reporting bug in DGEQP3RK and added debug code to DLAQP3RK and DLAQP2RK --- SRC/dgeqp3rk.f | 44 ++++++++++++++++++++++++++++++-------------- SRC/dlaqp2rk.f | 7 +++++++ SRC/dlaqp3rk.f | 2 ++ 3 files changed, 39 insertions(+), 14 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 0731f25186..b6bb555b36 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -337,7 +337,7 @@ *> otherwise the elements TAU(1:min(M,N)) *> are undefimed; *> c) the elements of the array JPIV are set -*> as follows: for j = 1:N, JPIV(j) = j. +*> as follows: for j = 1:N, JPIV(j) = j. *> \endverbatim *> *> \param[out] MAXC2NRMK @@ -390,6 +390,11 @@ *> JPIV is INTEGER array, dimension (N) *> Column pivot indices. For 1 <= j <= N, column j *> of the matrix A was interchanged with column JPIV(j). +*> +*> The elements of the array JPIV(1:N) are always set +*> by the routine, for example, even when no columns +*> were factorized, i.e. when K = 0, the elements are +*> set as JPIV(j) = j for j = 1:N. *> \endverbatim *> *> \param[out] TAU @@ -710,6 +715,8 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * KP1 = IDAMAX( N, WORK( 1 ), 1 ) MAXC2NRM = WORK( KP1 ) + WRITE(*,*) "======= DGEQP3RK ((( before NaN in MATRIX ))) KP1=", + $ KP1 * * ==================================================================. * @@ -719,6 +726,8 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * to the column number where the first NaN is found and return * from the routine. * + WRITE(*,*) "======= DGEQP3RK ((( NaN in MATRIX ))) ====" + K = 0 INFO = KP1 * @@ -920,14 +929,10 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, WRITE(*,*) "======= DGEQP3RK loop after block (JBF)=", $ JBF * -* Set INFO on the first exception occurence. +* Set INFO on the first occurence of Inf. * - IF( INFO.EQ.0 ) THEN - IF( IINFO.GT.N_SUB ) THEN - INFO = 2*IOFFSET + IINFO - ELSE IF( IINFO.GT.0 ) THEN - INFO = IOFFSET + IINFO - END IF + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO END IF * IF( DONE ) THEN @@ -947,6 +952,13 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * K = IOFFSET + JBF * +* Set INFO on the first occurrence of NaN, NaN takes +* prcedence over Inf. +* + IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* * Return from the routine. * WORK( 1 ) = DBLE( LWKOPT ) @@ -995,12 +1007,16 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, * * Set INFO on the first exception occurence. * - IF( INFO.EQ.0 ) THEN - IF( IINFO.GT.N_SUB ) THEN - INFO = 2*IOFFSET + IINFO - ELSE IF( IINFO.GT.0 ) THEN - INFO = IOFFSET + IINFO - END IF + WRITE(*,*) "======= DGEQP3RK after call to DLAQP2RK INFO=", + $ INFO +* +* Set INFO on the first exception occurence of Inf or NaN, +* (NaN takes precedence over Inf). +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO END IF * ELSE diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 9931ccf1d8..04ab524108 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -406,7 +406,11 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * therefore we use the computed KP1 and MAXC2NRM from the * main routine. * + KP = KP1 + + WRITE(*,*) "## ## DLAQP2RK IOFFSET=0, first column KP=",KP + * TODO: optimize MAXC2NRMK and RELMAXC2NRMK MAXC2NRMK = MAXC2NRM RELMAXC2NRMK = ONE @@ -575,6 +579,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, ELSE TAU( K ) = ZERO END IF + + WRITE(*,*) "## DLAQP2RK (K, TAU(K) )=", K, TAU(K) * * Check if TAU(K) is NaN, set INFO parameter * to the column number where NaN is found and return from @@ -589,6 +595,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, IF( DISNAN( TAU(K) ) ) THEN KF = K - 1 INFO = K + WRITE(*,*) "## ## DLAQP2RK ((TAU is NaN)) (K, INFO)", K, INFO * * Set MAXC2NRMK and RELMAXC2NRMK to NaN. * diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 4f2b1f73d7..41c67e5355 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -767,6 +767,8 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, KB = K - 1 IF = I - 1 INFO = K + + WRITE(*,*) "$$ $$ DLAQP3RK ((TAU is NaN)) (K, INFO)", K, INFO * * Set MAXC2NRMK and RELMAXC2NRMK to NaN. * From e9e939400f60ba0b50c57e3345756a62a0af0fd6 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 041/106] changed the description of DGEQP3RK, DLAQP3RK, DLAQP2RK and removed the KMAX parameter from DLAQP3RK --- SRC/dgeqp3rk.f | 67 +++++++++++------------ SRC/dlaqp2rk.f | 111 +++++++++++++++++++------------------- SRC/dlaqp3rk.f | 141 ++++++++++++++++++++++++------------------------- 3 files changed, 157 insertions(+), 162 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index b6bb555b36..fec557645f 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -267,7 +267,7 @@ *> factorization is not performed, the matrices A and B are not *> modified, and the matrix A is itself the residual. *> -*> NOTE: We recommend that RELTOL to satisfy +*> NOTE: We recommend that RELTOL satisfy *> min(max(M,N)*EPS, sqrt(EPS)) <= RELTOL *> \endverbatim *> @@ -335,7 +335,7 @@ *> b) the array TAU(1:min(M,N)) is set to ZERO, *> if the matrix A does not contain NaN, *> otherwise the elements TAU(1:min(M,N)) -*> are undefimed; +*> are undefined; *> c) the elements of the array JPIV are set *> as follows: for j = 1:N, JPIV(j) = j. *> \endverbatim @@ -364,7 +364,7 @@ *> \param[out] RELMAXC2NRMK *> \verbatim *> RELMAXC2NRMK is DOUBLE PRECISION -*> The ratio MAXC2NRMK / MAXC2NRM_WHOLE of the maximum column +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column *> 2-norm of the residual matrix R22(K) (when the factorization *> stopped at rank K) to the maximum column 2-norm of the *> whole original matrix A. RELMAXC2NRMK >= 0. @@ -404,12 +404,13 @@ *> *> If 0 < K <= min(M,N), only the elements TAU(1:K) of *> the array TAU are modified by the factorization. -*> If no NaN was found during the factorization, -*> the remainig elements TAU(K+1:min(M,N)) are set to zero, -*> otherwise the elements TAU(K+1:min(M,N)) are not set -*> and therefore undefined. +*> After the factorization complted, if no NaN was found +*> during the factorization, the remaining elements +*> TAU(K+1:min(M,N)) are set to zero, otherwise the +*> elements TAU(K+1:min(M,N)) are not set and therefore +*> undefined. *> ( If K = 0, all elements of TAU are set to zero, if -*> the matrix A does not cointain NaN. ) +*> the matrix A does not contain NaN. ) *> \endverbatim *> *> \param[out] WORK @@ -446,34 +447,30 @@ *> 1) INFO = 0: successful exit. *> 2) INFO < 0: if INFO = -i, the i-th argument had an *> illegal value. -*> 3) INFO > 0: NaN, +Inf (or -Inf) element was detected -*> in the matrix A, either on input or during -*> the computation, or NaN element was detected -*> in the array TAU during the computation. -*> -*> 3a) If INFO = j_1, where 1 <= j_1 <= N, then NaN element -*> was detected and the routine stops the computation. -*> The j_1-th column of the matrix A or the j_1-th -*> element of array TAU contains the first occurrence -*> of NaN in the factorization step K+1 ( when K columns -*> have been factorized ). -*> -*> On exit: -*> K is set to the number of +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN element +*> was detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of *> factorized columns without *> exception. -*> MAXC2NRMK is set to NaN. -*> RELMAXC2NRMK is set to NaN. -*> TAU(K+1:min(M,N)) is not set and contains undefined -*> elements. If j_1=K+1, TAU(K+1) may -*> contain NaN. -*> 3b) If INFO = j_2, where N+1 <= j_2 <= 2N, then -*> no NaN element was detected, but +Inf (or -Inf) -*> was detected and the routine continues -*> the computation until completion. -*> The j_2-th column of the matrix A contains the first -*> occurrence of +Inf (or -Inf) in the factorization -*> step K+1 ( when K columns have been factorized ). +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) may +*> contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then +*> no NaN element was detected, but +Inf (or -Inf) +*> was detected and the routine continues +*> the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the +*> first occurrence of +Inf (or -Inf) in the +*> factorization step K+1 ( when K columns have been +*> factorized ). *> \endverbatim * * Authors: @@ -917,7 +914,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, WRITE(*,*) "===== DGEQP3RK loop before block(IOFFSET, JB)=", $ J-1, JB - CALL DLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, KMAX, ABSTOL, + CALL DLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, $ JPIV( J ), TAU( J ), diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 04ab524108..97dd38da6e 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -41,13 +41,16 @@ *> *> \verbatim *> -*> DLAQP2RK computes a truncated (rank K) or full rank Householder QR -*> factorization with column pivoting of the block A(IOFFSET+1:M,1:N). -*> The routine is calling Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> DLAQP2RK computes a truncated (rank KF) or full rank Householder QR +*> factorization with column pivoting of the block A(IOFFSET+1:M,1:N) +*> +*> A * P(KF) = Q(KF) * R(KF). +*> +*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) *> is accordingly pivoted, but not factorized. *> -*> The routine also overwrites the matrix B block stored -*> in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**T * B. +*> The routine also overwrites the right-hand-sides matrix block B +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(KF)**T * B. *> \endverbatim * * Arguments: @@ -76,9 +79,11 @@ *> \verbatim *> IOFFSET is INTEGER *> The number of rows of the matrix A that must be pivoted -*> but not factorized. IOFFSET also represents the number of -*> columns of the original matrix that have been factorized -*> in the previous steps. IOFFSET >= 0. +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. *> \endverbatim *> *> \param[in] KMAX @@ -128,11 +133,10 @@ *> *> The third factorization stopping criterion. *> -*> The tolerance (stopping threshold) for the ratio -*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of -*> the residual matrix R22(K) to the maximum column 2-norm of -*> the original matrix A_orig. The algorithm converges (stops -*> the factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is *> less than or equal to RELTOL. *> *> a) If RELTOL < 0.0, then this stopping criterion is not @@ -147,16 +151,17 @@ *> \param[in] KP1 *> \verbatim *> KP1 is INTEGER -*> The index of the column with the maximum column 2-norm in -*> the whole original matrix A_orig in original matrix A_orig -*> indexing scheme. 0 < KP1 <= N_orig_mat. +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine DGEQP3RK. 1 <= KP1 <= N_orig_mat. *> \endverbatim *> *> \param[in] MAXC2NRM *> \verbatim *> MAXC2NRM is DOUBLE PRECISION *> The maximum column 2-norm of the whole original -*> matrix A_orig. MAXC2NRM >= 0. +*> matrix A_orig computed in the main routine DGEQP3RK. +*> MAXC2NRM >= 0. *> \endverbatim *> *> \param[in,out] A @@ -170,20 +175,20 @@ *> *> On exit: *> 1. The elements in block A(IOFFSET+1:M,1:KF) below -*> the diagonal together with the array TAU, represent -*> the orthogonal matrix Q(K) as a product of elementary +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(KF) as a product of elementary *> reflectors. -*> 2. The block of the matrix A stored in A(IOFFSET+1:M,1:KF) -*> is the triangular factor obtained. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:KF) is the triangular factor obtained. *> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) -*> has been accordingly pivoted, but no factorized. +*> has been accordingly pivoted, but not factorized. *> 4. The rest of the array A, block A(IOFFSET+1:M,KF+1:N+NRHS). -*> The left part A(IOFFSET+1:M,KF+1:N) of -*> this block contains the residual of the matrix A, and, +*> The left part A(IOFFSET+1:M,KF+1:N) of this block +*> contains the residual of the matrix A, and, *> if NRHS > 0, the right part of the block *> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of *> the right-hand-side matrix B. Both these blocks have been -*> updated by multiplication from the left by Q**T. +*> updated by multiplication from the left by Q(KF)**T. *> \endverbatim *> *> \param[in] LDA @@ -197,7 +202,7 @@ *> KF is INTEGER *> Factorization rank of the matrix A, i.e. the rank of *> the factor R, which is the same as the number of non-zero -*> rows of the factor R. 0 <= KF <= min(M-IOFFSET,KMAX,N). +*> rows of the factor R. 0 <= KF <= min(M-IOFFSET,KMAX,N). *> *> KF also represents the number of non-zero Householder *> vectors. @@ -207,8 +212,7 @@ *> \verbatim *> MAXC2NRMK is DOUBLE PRECISION *> The maximum column 2-norm of the residual matrix, -*> when the factorization stopped at rank K. MAXC2NRMK >= 0. -*> ( Rank K is with respect to the original matrix A_orig. ) +*> when the factorization stopped at rank KF. MAXC2NRMK >= 0. *> \endverbatim *> *> \param[out] RELMAXC2NRMK @@ -216,9 +220,8 @@ *> RELMAXC2NRMK is DOUBLE PRECISION *> The ratio MAXC2NRMK / MAXC2NRM of the maximum column *> 2-norm of the residual matrix (when the factorization -*> stopped at rank K) to the maximum column 2-norm of the +*> stopped at rank KF) to the maximum column 2-norm of the *> whole original matrix A. RELMAXC2NRMK >= 0. -*> ( Rank K is with respect to the original matrix A_orig. ) *> \endverbatim *> *> \param[out] JPIV @@ -257,34 +260,30 @@ *> \verbatim *> INFO is INTEGER *> 1) INFO = 0: successful exit. -*> 2) INFO > 0: NaN, +Inf (or -Inf) element was detected -*> in the matrix A, either on input or during -*> the computation, or NaN element was detected -*> in the array TAU during the computation. -*> -*> 2a) If INFO = j_1, where 1 <= j_1 <= N, then NaN element -*> was detected and the routine stops the computation. -*> The j_1-th column of the matrix A or the j_1-th -*> element of array TAU contains the first occurrence -*> of NaN in the factorization step K+1 ( when K columns -*> have been factorized ). -*> -*> On exit: -*> K is set to the number of +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN element +*> was detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step KF+1 ( when KF columns +*> have been factorized ). +*> +*> On exit: +*> KF is set to the number of *> factorized columns without *> exception. -*> MAXC2NRMK is set to NaN. -*> RELMAXC2NRMK is set to NaN. -*> TAU(K+1:min(M,N)) is not set and contains undefined -*> elements. If j_1=K+1, TAU(K+1) may -*> contain NaN. -*> 2b) If INFO = j_2, where N+1 <= j_2 <= 2N, then -*> no NaN element was detected, but +Inf (or -Inf) -*> was detected and the routine continues -*> the computation until completion. -*> The j_2-th column of the matrix A contains the first -*> occurrence of +Inf (or -Inf) in the factorization -*> step K+1 ( when K columns have been factorized ). +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(KF+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=KF+1, TAU(KF+1) may +*> contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then +*> no NaN element was detected, but +Inf (or -Inf) +*> was detected and the routine continues +*> the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the +*> first occurrence of +Inf (or -Inf) in the +*> factorization step KF+1 ( when KF columns have been +*> factorized ). *> \endverbatim * * Authors: diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 41c67e5355..fb5e6486d1 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -18,13 +18,13 @@ * Definition: * =========== * -* SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, +* SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, * $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, * $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) * IMPLICIT NONE * LOGICAL DONE -* INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, KMAX, N, +* INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, * $ NB, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, * $ RELTOL @@ -48,21 +48,27 @@ *> \verbatim *> *> DLAQP3RK computes a step of truncated QR factorization with column -*> pivoting of a real M-by-N matrix A by using Level 3 BLAS. The routine -*> tries to factorize NB columns from A starting from the row IOFFSET+1, -*> and updates the residual matrix with BLAS 3 xGEMM, the number -*> of actually factorized columns is returned in KB, KB <= NB. +*> pivoting of a real M-by-N matrix A block A(IOFFSET+1:M,1:N) +*> by using Level 3 BLAS as +*> +*> A * P(KB) = Q(KB) * R(KB). +*> +*> The routine tries to factorize NB columns from A starting from +*> the row IOFFSET+1, and updates the residual matrix with BLAS 3 +*> xGEMM. The number of actually factorized columns is returned +*> is smaller than NB. *> *> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. *> -*> The routine also overwrites the right-hand-sides B block stored -*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(K)**T * B. +*> The routine also overwrites the right-hand-sides B matrix stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**T * B. *> *> Cases when the number of factorized columns KB < NB: *> *> (1) In some cases, due to catastrophic cancellations, it cannot -*> factorize NB columns. Hence, the actual number of factorized -*> columns is returned in KB. +*> factorize all NB columns and need to update the panel. Hence, the +*> actual number of factorized columns returned in KB is smaller +*> than NB. *> *> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, *> the factorization is stopped, the logical DONE is returned @@ -109,7 +115,7 @@ *> \verbatim *> IOFFSET is INTEGER *> The number of rows of the matrix A that must be pivoted -*> but no factorized. IOFFSET >= 0. +*> but not factorized. IOFFSET >= 0. *> *> IOFFSET also represents the number of columns of the whole *> original matrix A_orig that have been factorized @@ -132,8 +138,6 @@ *> \verbatim *> ABSTOL is DOUBLE PRECISION, cannot be NaN. *> -*> The second factorization stopping criterion. -*> *> The absolute tolerance (stopping threshold) for *> maximum column 2-norm of the residual matrix. *> The algorithm converges (stops the factorization) when @@ -142,7 +146,7 @@ *> *> a) If ABSTOL < 0.0, then this stopping criterion is not *> used, the routine factorizes columns depending -*> on KMAX and RELTOL. +*> on NB and RELTOL. *> This includes the case ABSTOL = -Inf. *> *> b) If 0.0 <= ABSTOL then the input value @@ -153,18 +157,15 @@ *> \verbatim *> RELTOL is DOUBLE PRECISION, cannot be NaN. *> -*> The third factorization stopping criterion. -*> -*> The tolerance (stopping threshold) for the ratio -*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of -*> the residual matrix R22(K) to the maximum column 2-norm of -*> the original matrix A_orig. The algorithm converges (stops -*> the factorization), when abs(R(K+1,K+1))/abs(R(1,1)) is +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is *> less than or equal to RELTOL. *> *> a) If RELTOL < 0.0, then this stopping criterion is not *> used, the routine factorizes columns depending -*> on KMAX and ABSTOL. +*> on NB and ABSTOL. *> This includes the case RELTOL = -Inf. *> *> d) If 0.0 <= RELTOL then the input value of RELTOL @@ -174,16 +175,17 @@ *> \param[in] KP1 *> \verbatim *> KP1 is INTEGER -*> The index of the column with the maximum column 2-norm in -*> the whole original matrix A_orig in original matrix A_orig -*> indexing scheme. 0 < KP1 <= N_orig_mat. +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine DGEQP3RK. 1 <= KP1 <= N_orig_mat. *> \endverbatim *> *> \param[in] MAXC2NRM *> \verbatim *> MAXC2NRM is DOUBLE PRECISION *> The maximum column 2-norm of the whole original -*> matrix A_orig. MAXC2NRMK >= 0. +*> matrix A_orig computed in the main routine DGEQP3RK. +*> MAXC2NRM >= 0. *> \endverbatim *> *> \param[in,out] A @@ -197,20 +199,20 @@ *> *> On exit: *> 1. The elements in block A(IOFFSET+1:M,1:KB) below -*> the diagonal together with the array TAU, represent -*> the orthogonal matrix Q(K) as a product of elementary +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(KB) as a product of elementary *> reflectors. -*> 2. The block of the matrix A stored in A(IOFFSET+1:M,1:KB) -*> is the triangular factor obtained. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:KB) is the triangular factor obtained. *> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) -*> has been accordingly pivoted, but no factorized. +*> has been accordingly pivoted, but not factorized. *> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). -*> The left part A(IOFFSET+1:M,KB+1:N) of -*> this block contains the residual of the matrix A, and, +*> The left part A(IOFFSET+1:M,KB+1:N) of this block +*> contains the residual of the matrix A, and, *> if NRHS > 0, the right part of the block *> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of *> the right-hand-side matrix B. Both these blocks have been -*> updated by multiplication from the left by Q**T. +*> updated by multiplication from the left by Q(KB)**T. *> \endverbatim *> *> \param[in] LDA @@ -223,9 +225,12 @@ *> \verbatim *> DONE is LOGICAL *> TRUE: a) if the factorization completed before processing -*> all min(M-IOFFSET,N) columns due to ABSTOL +*> all min(M-IOFFSET,NB,N) columns due to ABSTOL *> or RELTOL criterion, -*> b) when NaN was detected in the matrix A +*> b) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to the +*> residual matrix being a ZERO matrix. +*> c) when NaN was detected in the matrix A *> or in the array TAU. *> FALSE: otherwise. *> \endverbatim @@ -235,7 +240,7 @@ *> KB is INTEGER *> Factorization rank of the matrix A, i.e. the rank of *> the factor R, which is the same as the number of non-zero -*> rows of the factor R. 0 <= KB <= min(M-IOFFSET,KB,N). +*> rows of the factor R. 0 <= KB <= min(M-IOFFSET,NB,N). *> *> KB also represents the number of non-zero Householder *> vectors. @@ -245,8 +250,7 @@ *> \verbatim *> MAXC2NRMK is DOUBLE PRECISION *> The maximum column 2-norm of the residual matrix, -*> when the factorization stopped at rank K. MAXC2NRMK >= 0. -*> ( Rank K is with respect to the original matrix A_orig. ) +*> when the factorization stopped at rank KB. MAXC2NRMK >= 0. *> \endverbatim *> *> \param[out] RELMAXC2NRMK @@ -254,9 +258,8 @@ *> RELMAXC2NRMK is DOUBLE PRECISION *> The ratio MAXC2NRMK / MAXC2NRM of the maximum column *> 2-norm of the residual matrix (when the factorization -*> stopped at rank K) to the maximum column 2-norm of the +*> stopped at rank KB) to the maximum column 2-norm of the *> original matrix A_orig. RELMAXC2NRMK >= 0. -*> ( Rank K is with respect to the original matrix A_orig. ) *> \endverbatim *> *> \param[out] JPIV @@ -314,34 +317,30 @@ *> \verbatim *> INFO is INTEGER *> 1) INFO = 0: successful exit. -*> 2) INFO > 0: NaN, +Inf (or -Inf) element was detected -*> in the matrix A, either on input or during -*> the computation, or NaN element was detected -*> in the array TAU during the computation. -*> -*> 2a) If INFO = j_1, where 1 <= j_1 <= N, then NaN element -*> was detected and the routine stops the computation. -*> The j_1-th column of the matrix A or the j_1-th -*> element of array TAU contains the first occurrence -*> of NaN in the factorization step K+1 ( when K columns -*> have been factorized ). -*> -*> On exit: -*> K is set to the number of -*> factorized columns without -*> exception. -*> MAXC2NRMK is set to NaN. -*> RELMAXC2NRMK is set to NaN. -*> TAU(K+1:min(M,N)) is not set and contains undefined -*> elements. If j_1=K+1, TAU(K+1) may -*> contain NaN. -*> 2b) If INFO = j_2, where N+1 <= j_2 <= 2N, then -*> no NaN element was detected, but +Inf (or -Inf) -*> was detected and the routine continues -*> the computation until completion. -*> The j_2-th column of the matrix A contains the first -*> occurrence of +Inf (or -Inf) in the factorization -*> step K+1 ( when K columns have been factorized ). +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN element +*> was detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step KB+1 ( when KB columns +*> have been factorized ). +*> +*> On exit: +*> KB is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(KB+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=KB+1, TAU(KB+1) may +*> contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then +*> no NaN element was detected, but +Inf (or -Inf) +*> was detected and the routine continues +*> the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the +*> first occurrence of +Inf (or -Inf) in the +*> factorization step KB+1 ( when KB columns have been +*> factorized ). *> \endverbatim * * Authors: @@ -385,7 +384,7 @@ *> \endhtmlonly * * ===================================================================== - SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, + SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) @@ -397,7 +396,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, KMAX, ABSTOL, * * .. Scalar Arguments .. LOGICAL DONE - INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, KMAX, N, + INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, $ NB, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL From 46e75194d1a80b6863e68b8bdfafe84fd9836fad Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 042/106] changed the description of DGEQP3RK (added imlicit stopping criterion for the residual zero matrix) and fixed a typo in DLAQP3RK --- SRC/dgeqp3rk.f | 6 +++++- SRC/dlaqp3rk.f | 4 ++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index fec557645f..be6ea6916c 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -99,6 +99,10 @@ *> the maximum column 2-norm of A is less than or equal to RELTOL. *> If RELTOL < 0.0, the criterion is not used. *> +*> 4) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix R22(K) is a zero matrix in some +*> factorization step K. ( This stopping criterion is implicit. ) +*> *> The algorithm stops when any of these conditions is first *> satisfied, otherwise the whole matrix A is factorized. *> @@ -404,7 +408,7 @@ *> *> If 0 < K <= min(M,N), only the elements TAU(1:K) of *> the array TAU are modified by the factorization. -*> After the factorization complted, if no NaN was found +*> After the factorization computed, if no NaN was found *> during the factorization, the remaining elements *> TAU(K+1:min(M,N)) are set to zero, otherwise the *> elements TAU(K+1:min(M,N)) are not set and therefore diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index fb5e6486d1..6113f2cbe9 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -54,7 +54,7 @@ *> A * P(KB) = Q(KB) * R(KB). *> *> The routine tries to factorize NB columns from A starting from -*> the row IOFFSET+1, and updates the residual matrix with BLAS 3 +*> the row IOFFSET+1 and updates the residual matrix with BLAS 3 *> xGEMM. The number of actually factorized columns is returned *> is smaller than NB. *> @@ -68,7 +68,7 @@ *> (1) In some cases, due to catastrophic cancellations, it cannot *> factorize all NB columns and need to update the panel. Hence, the *> actual number of factorized columns returned in KB is smaller -*> than NB. +*> than NB. The logical DONE is returned as FALSE. *> *> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, *> the factorization is stopped, the logical DONE is returned From 4603e69a5f605798e7243196516c3ff1e3a9a217 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 043/106] updated the description of DLAQP3RK --- SRC/dlaqp3rk.f | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 6113f2cbe9..8ca10bc63a 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -66,26 +66,28 @@ *> Cases when the number of factorized columns KB < NB: *> *> (1) In some cases, due to catastrophic cancellations, it cannot -*> factorize all NB columns and need to update the panel. Hence, the -*> actual number of factorized columns returned in KB is smaller -*> than NB. The logical DONE is returned as FALSE. +*> factorize all NB columns and need to update the residual matrix. +*> Hence, the actual number of factorized columns in the block returned +*> in KB is smaller than NB. The logical DONE is returned as FALSE. +*> The factorization of the whole original matrix A_orig must proceed +*> with the next block. *> *> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, -*> the factorization is stopped, the logical DONE is returned -*> as TRUE. The number of factorized columns which is smaller than NB -*> is returned in KB. +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. *> *> (3) In case both stopping criteria ABSTOL or RELTOL are not used, *> and when the residual matrix is a zero matrix in some factorization -*> step KB, the factorization is stopped, the logical DONE is returned -*> as TRUE. The number of factorized columns which is smaller than NB -*> is returned in KB. +*> step KB, the factorization of the whole original matrix A_orig is +*> stopped, the logical DONE is returned as TRUE. The number of +*> factorized columns which is smaller than NB is returned in KB. *> *> (4) Whenever NaN is detected in the matrix A or in the array TAU, -*> the factorization is stopped, the logical DONE is returned -*> as TRUE. The number of factorized columns which is smaller than NB -*> is returned in KB. The INFO parameter is set to the column index -*> of the first NaN occurrence. +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. The INFO +*> parameter is set to the column index of the first NaN occurrence. *> *> \endverbatim * @@ -177,7 +179,7 @@ *> KP1 is INTEGER *> The index of the column with the maximum 2-norm in *> the whole original matrix A_orig determined in the -*> main routine DGEQP3RK. 1 <= KP1 <= N_orig_mat. +*> main routine DGEQP3RK. 1 <= KP1 <= N_orig. *> \endverbatim *> *> \param[in] MAXC2NRM From 1b7bf32c206adba0fbeb30697df56f2d4307ad95 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 044/106] renamed old auxiliary index J into J1 in DLAQP2RK --- SRC/dlaqp2rk.f | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 97dd38da6e..66d7c19966 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -355,7 +355,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - INTEGER I, ITEMP, J, JMAXC2NRM, K, KP, MINMNFACT, + INTEGER I, ITEMP, J1, JMAXC2NRM, K, KP, MINMNFACT, $ MINMNUPDT DOUBLE PRECISION AIK, HUGEVAL, TEMP, TEMP2, TOL3Z * .. @@ -481,8 +481,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * Set TAUs corresponding to the columns that were not * factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. * - DO J = K, MINMNFACT - TAU( J ) = ZERO + DO J1 = K, MINMNFACT + TAU( J1 ) = ZERO END DO * * Return from the routine. @@ -529,8 +529,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * Set TAUs corresponding to the columns that were not * factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. * - DO J = K, MINMNFACT - TAU( J ) = ZERO + DO J1 = K, MINMNFACT + TAU( J1 ) = ZERO END DO * * Return from the routine. @@ -633,33 +633,33 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * only if the residual matrix A(I+1:M,K+1:N) exists, i.e. * when K < min(M-IOFFSET, N). * - DO J = K + 1, N - IF( VN1( J ).NE.ZERO ) THEN + DO J1 = K + 1, N + IF( VN1( J1 ).NE.ZERO ) THEN * * NOTE: The following lines follow from the analysis in * Lapack Working Note 176. * - TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = ONE - ( ABS( A( I, J1 ) ) / VN1( J1 ) )**2 TEMP = MAX( TEMP, ZERO ) - TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + TEMP2 = TEMP*( VN1( J1 ) / VN2( J1 ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN * * Compute the column 2-norm for the partial -* column A(I+1:M,J) by explicitly computing it, +* column A(I+1:M,J1) by explicitly computing it, * and store it in both partial 2-norm vector VN1 * and exact column 2-norm vector VN2. * - VN1( J ) = DNRM2( M-I, A( I+1, J ), 1 ) - VN2( J ) = VN1( J ) + VN1( J1 ) = DNRM2( M-I, A( I+1, J1 ), 1 ) + VN2( J1 ) = VN1( J1 ) * ELSE * * Update the column 2-norm for the partial -* column A(I+1:M,J) by removing one -* element A(I,J) and store it in partial +* column A(I+1:M,J1) by removing one +* element A(I,J1) and store it in partial * 2-norm vector VN1. * - VN1( J ) = VN1( J )*SQRT( TEMP ) + VN1( J1 ) = VN1( J1 )*SQRT( TEMP ) * END IF END IF @@ -701,8 +701,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * factorized, set TAUs corresponding to the columns that were * not factorized to ZERO, i.e. TAU(KF+1:MINMNFACT) set to ZERO. * - DO J = KF + 1, MINMNFACT - TAU( J ) = ZERO + DO J1 = KF + 1, MINMNFACT + TAU( J1 ) = ZERO END DO * RETURN From f84ee6c9cc25a3b735ba2e3227e7bf2dd54d76ae Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 045/106] Revert "renamed old auxiliary index J into J1 in DLAQP2RK" This reverts commit ea0c1ca130a0e628a28651db0475f6da6be07813. This reverts a rename of J into J1 in DLAQP2RK. --- SRC/dlaqp2rk.f | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 66d7c19966..97dd38da6e 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -355,7 +355,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - INTEGER I, ITEMP, J1, JMAXC2NRM, K, KP, MINMNFACT, + INTEGER I, ITEMP, J, JMAXC2NRM, K, KP, MINMNFACT, $ MINMNUPDT DOUBLE PRECISION AIK, HUGEVAL, TEMP, TEMP2, TOL3Z * .. @@ -481,8 +481,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * Set TAUs corresponding to the columns that were not * factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. * - DO J1 = K, MINMNFACT - TAU( J1 ) = ZERO + DO J = K, MINMNFACT + TAU( J ) = ZERO END DO * * Return from the routine. @@ -529,8 +529,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * Set TAUs corresponding to the columns that were not * factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. * - DO J1 = K, MINMNFACT - TAU( J1 ) = ZERO + DO J = K, MINMNFACT + TAU( J ) = ZERO END DO * * Return from the routine. @@ -633,33 +633,33 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * only if the residual matrix A(I+1:M,K+1:N) exists, i.e. * when K < min(M-IOFFSET, N). * - DO J1 = K + 1, N - IF( VN1( J1 ).NE.ZERO ) THEN + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following lines follow from the analysis in * Lapack Working Note 176. * - TEMP = ONE - ( ABS( A( I, J1 ) ) / VN1( J1 ) )**2 + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 TEMP = MAX( TEMP, ZERO ) - TEMP2 = TEMP*( VN1( J1 ) / VN2( J1 ) )**2 + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 IF( TEMP2 .LE. TOL3Z ) THEN * * Compute the column 2-norm for the partial -* column A(I+1:M,J1) by explicitly computing it, +* column A(I+1:M,J) by explicitly computing it, * and store it in both partial 2-norm vector VN1 * and exact column 2-norm vector VN2. * - VN1( J1 ) = DNRM2( M-I, A( I+1, J1 ), 1 ) - VN2( J1 ) = VN1( J1 ) + VN1( J ) = DNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) * ELSE * * Update the column 2-norm for the partial -* column A(I+1:M,J1) by removing one -* element A(I,J1) and store it in partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial * 2-norm vector VN1. * - VN1( J1 ) = VN1( J1 )*SQRT( TEMP ) + VN1( J ) = VN1( J )*SQRT( TEMP ) * END IF END IF @@ -701,8 +701,8 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * factorized, set TAUs corresponding to the columns that were * not factorized to ZERO, i.e. TAU(KF+1:MINMNFACT) set to ZERO. * - DO J1 = KF + 1, MINMNFACT - TAU( J1 ) = ZERO + DO J = KF + 1, MINMNFACT + TAU( J ) = ZERO END DO * RETURN From 3fc6c23e44324b92b36f0562a640941242812033 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 046/106] optimized, deleted not neede setting of MAXC2NRMK and RELMAXC2NRMK when (IOFFSET + K) =1 --- SRC/dlaqp2rk.f | 4 ---- 1 file changed, 4 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 97dd38da6e..bcaf0294e5 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -409,10 +409,6 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, KP = KP1 WRITE(*,*) "## ## DLAQP2RK IOFFSET=0, first column KP=",KP - -* TODO: optimize MAXC2NRMK and RELMAXC2NRMK - MAXC2NRMK = MAXC2NRM - RELMAXC2NRMK = ONE * * ============================================================ * From bfbcec20f67a693fc8b4dc32f5e23594640b9ac5 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 047/106] optimized, deleted not needed setting of MAXC2NRMK and RELMAXC2NRMK when (IOFFSET + K) =1 in DLAQP3RK --- SRC/dlaqp3rk.f | 4 ---- 1 file changed, 4 deletions(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 8ca10bc63a..1f63a92227 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -452,7 +452,6 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * K = 0 LSTICC = 0 -* TODO: describe DONE in main or in a subroutine DONE = .FALSE. * DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) @@ -466,9 +465,6 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * main routine. * KP = KP1 -* TODO: optimize MAXC2NRMK and RELMAXC2NRMK - MAXC2NRMK = MAXC2NRM - RELMAXC2NRMK = ONE * ELSE * From 1798bdba70cefd1c7385c214e12037052dd861e0 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 048/106] Renamed parameter the number of factorized columns so far KF into K , and column loop index into K into KK in DLAQP2RK --- SRC/dlaqp2rk.f | 208 ++++++++++++++++++++++++------------------------- 1 file changed, 104 insertions(+), 104 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index bcaf0294e5..de53720363 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -19,13 +19,13 @@ * =========== * * SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, -* $ KP1, MAXC2NRM, A, LDA, KF, MAXC2NRMK, +* $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, * $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, * $ INFO ) * IMPLICIT NONE * * .. Scalar Arguments .. -* INTEGER INFO, IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS +* INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, * $ RELTOL * .. @@ -41,16 +41,16 @@ *> *> \verbatim *> -*> DLAQP2RK computes a truncated (rank KF) or full rank Householder QR +*> DLAQP2RK computes a truncated (rank K) or full rank Householder QR *> factorization with column pivoting of the block A(IOFFSET+1:M,1:N) *> -*> A * P(KF) = Q(KF) * R(KF). +*> A * P(K) = Q(K) * R(K). *> *> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) *> is accordingly pivoted, but not factorized. *> *> The routine also overwrites the right-hand-sides matrix block B -*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(KF)**T * B. +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**T * B. *> \endverbatim * * Arguments: @@ -174,21 +174,21 @@ *> array_A = M [ mat_A, mat_B ] *> *> On exit: -*> 1. The elements in block A(IOFFSET+1:M,1:KF) below +*> 1. The elements in block A(IOFFSET+1:M,1:K) below *> the diagonal together with the array TAU represent -*> the orthogonal matrix Q(KF) as a product of elementary +*> the orthogonal matrix Q(K) as a product of elementary *> reflectors. *> 2. The upper triangular block of the matrix A stored -*> in A(IOFFSET+1:M,1:KF) is the triangular factor obtained. +*> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. *> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) *> has been accordingly pivoted, but not factorized. -*> 4. The rest of the array A, block A(IOFFSET+1:M,KF+1:N+NRHS). -*> The left part A(IOFFSET+1:M,KF+1:N) of this block +*> 4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS). +*> The left part A(IOFFSET+1:M,K+1:N) of this block *> contains the residual of the matrix A, and, *> if NRHS > 0, the right part of the block *> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of *> the right-hand-side matrix B. Both these blocks have been -*> updated by multiplication from the left by Q(KF)**T. +*> updated by multiplication from the left by Q(K)**T. *> \endverbatim *> *> \param[in] LDA @@ -197,14 +197,14 @@ *> The leading dimension of the array A. LDA >= max(1,M). *> \endverbatim *> -*> \param[out] KF +*> \param[out] K *> \verbatim -*> KF is INTEGER +*> K is INTEGER *> Factorization rank of the matrix A, i.e. the rank of *> the factor R, which is the same as the number of non-zero -*> rows of the factor R. 0 <= KF <= min(M-IOFFSET,KMAX,N). +*> rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N). *> -*> KF also represents the number of non-zero Householder +*> K also represents the number of non-zero Householder *> vectors. *> \endverbatim *> @@ -212,7 +212,7 @@ *> \verbatim *> MAXC2NRMK is DOUBLE PRECISION *> The maximum column 2-norm of the residual matrix, -*> when the factorization stopped at rank KF. MAXC2NRMK >= 0. +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. *> \endverbatim *> *> \param[out] RELMAXC2NRMK @@ -220,7 +220,7 @@ *> RELMAXC2NRMK is DOUBLE PRECISION *> The ratio MAXC2NRMK / MAXC2NRM of the maximum column *> 2-norm of the residual matrix (when the factorization -*> stopped at rank KF) to the maximum column 2-norm of the +*> stopped at rank K) to the maximum column 2-norm of the *> whole original matrix A. RELMAXC2NRMK >= 0. *> \endverbatim *> @@ -264,25 +264,25 @@ *> was detected and the routine stops the computation. *> The j_1-th column of the matrix A or the j_1-th *> element of array TAU contains the first occurrence -*> of NaN in the factorization step KF+1 ( when KF columns +*> of NaN in the factorization step K+1 ( when K columns *> have been factorized ). *> *> On exit: -*> KF is set to the number of -*> factorized columns without -*> exception. +*> K is set to the number of +*> factorized columns without +*> exception. *> MAXC2NRMK is set to NaN. *> RELMAXC2NRMK is set to NaN. -*> TAU(KF+1:min(M,N)) is not set and contains undefined -*> elements. If j_1=KF+1, TAU(KF+1) may -*> contain NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. *> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then *> no NaN element was detected, but +Inf (or -Inf) *> was detected and the routine continues *> the computation until completion. *> The (j_2-N)-th column of the matrix A contains the *> first occurrence of +Inf (or -Inf) in the -*> factorization step KF+1 ( when KF columns have been +*> factorization step K+1 ( when K columns have been *> factorized ). *> \endverbatim * @@ -328,7 +328,7 @@ * * ===================================================================== SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, - $ KP1, MAXC2NRM, A, LDA, KF, MAXC2NRMK, + $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, $ INFO ) IMPLICIT NONE @@ -338,7 +338,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. - INTEGER INFO, IOFFSET, KP1, KF, KMAX, LDA, M, N, NRHS + INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, $ RELTOL * .. @@ -355,9 +355,9 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. * .. Local Scalars .. - INTEGER I, ITEMP, J, JMAXC2NRM, K, KP, MINMNFACT, + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, $ MINMNUPDT - DOUBLE PRECISION AIK, HUGEVAL, TEMP, TEMP2, TOL3Z + DOUBLE PRECISION AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. EXTERNAL DLARF, DLARFG, DSWAP @@ -391,11 +391,11 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) HUGEVAL = DLAMCH( 'Overflow' ) * -* Compute the factorization. +* Compute the factorization, KK is the lomn loop index. * - DO K = 1, KMAX + DO KK = 1, KMAX * - I = IOFFSET + K + I = IOFFSET + KK * IF( I.EQ.1 ) THEN * @@ -416,14 +416,14 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * ============================================================ * -* Determine the pivot column in K-th step, i.e. the index +* Determine the pivot column in KK-th step, i.e. the index * of the column with the maximum 2-norm in the * submatrix A(I:M,K:N). * - KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) + KP = ( KK-1 ) + IDAMAX( N-KK+1, VN1( KK ), 1 ) * * Determine the maximum column 2-norm and the relative maximum -* column 2-norm of the submatrix A(I:M,K:N) in step K. +* column 2-norm of the submatrix A(I:M,KK:N) in step KK. * RELMAXC2NRMK will be computed later, after somecondition * checks on MAXC2NRMK. * @@ -431,7 +431,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * ============================================================ * -* Check if the submatrix A(I:M,K:N) contains NaN, and set +* Check if the submatrix A(I:M,KK:N) contains NaN, and set * INFO parameter to the column number, where the first NaN * is found and return from the routine. * We need to check the condition only if the @@ -441,17 +441,17 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * IF( DISNAN( MAXC2NRMK ) ) THEN * -* Set KF, the number of factorized columns. +* Set K, the number of factorized columns. * that are not zero. * - KF = K - 1 - INFO = KF + KP + K = KK - 1 + INFO = K + KP * * Set RELMAXC2NRMK to NaN. * RELMAXC2NRMK = MAXC2NRMK * -* Array TAU(KF+1:MINMNFACT) is not set and contains +* Array TAU(K+1:MINMNFACT) is not set and contains * undefined elements. * RETURN @@ -459,7 +459,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * ============================================================ * -* Quick return, if the submatrix A(I:M,K:N) is +* Quick return, if the submatrix A(I:M,KK:N) is * a zero matrix. * We need to check the condition only if the * column index (same as row index) of the original whole @@ -468,16 +468,16 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * IF( MAXC2NRMK.EQ.ZERO ) THEN * -* Set KF, the number of factorized columns. +* Set K, the number of factorized columns. * that are not zero. * - KF = K - 1 + K = KK - 1 RELMAXC2NRMK = ZERO * * Set TAUs corresponding to the columns that were not -* factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. * - DO J = K, MINMNFACT + DO J = KK, MINMNFACT TAU( J ) = ZERO END DO * @@ -489,7 +489,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * ============================================================ * -* Check if the submatrix A(I:M,K:N) contains Inf, +* Check if the submatrix A(I:M,KK:N) contains Inf, * set INFO parameter to the column number, where * the first Inf is found plus N, and continue * the computation. @@ -499,7 +499,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * original matrix is checked in the main routine. * IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN - INFO = N + K - 1 + KP + INFO = N + KK - 1 + KP END IF * * ============================================================ @@ -518,14 +518,14 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN * -* Set KF, the number of factorized columns. +* Set K, the number of factorized columns. * - KF = K - 1 + K = KK - 1 * * Set TAUs corresponding to the columns that were not -* factorized to ZERO, i.e. set TAU(K:MINMNFACT) to ZERO. +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. * - DO J = K, MINMNFACT + DO J = KK, MINMNFACT TAU( J ) = ZERO END DO * @@ -544,92 +544,92 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * =============================================================== * * If the pivot column is not the first column of the -* subblock A(1:M,K:N): -* 1) swap the K-th column and the KP-th pivot column +* subblock A(1:M,KK:N): +* 1) swap the KK-th column and the KP-th pivot column * in A(1:M,1:N); -* 2) copy the K-th element into the KP-th element of the partial +* 2) copy the KK-th element into the KP-th element of the partial * and exact 2-norm vectors VN1 and VN2. ( Swap is not needed * for VN1 and VN2 since we use the element with the index -* larger than K in the next loop step.) +* larger than KK in the next loop step.) * 3) Save the pivot interchange with the indices relative to the * the original matrix A, not the block A(1:M,1:N). * - IF( KP.NE.K ) THEN - CALL DSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) - VN1( KP ) = VN1( K ) - VN2( KP ) = VN2( K ) + IF( KP.NE.KK ) THEN + CALL DSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 ) + VN1( KP ) = VN1( KK ) + VN2( KP ) = VN2( KK ) ITEMP = JPIV( KP ) - JPIV( KP ) = JPIV( K ) - JPIV( K ) = ITEMP + JPIV( KP ) = JPIV( KK ) + JPIV( KK ) = ITEMP END IF * -* Generate elementary reflector H(K) using the column A(I:M,K), +* Generate elementary reflector H(KK) using the column A(I:M,KK), * if the column has more than one element, otherwise * the elementary reflector would be an identity matrix, -* and TAU(K) = ZERO. +* and TAU(KK) = ZERO. * - IF( K.LT.M ) THEN - CALL DLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, - $ TAU( K ) ) + IF( KK.LT.M ) THEN + CALL DLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, + $ TAU( KK ) ) ELSE - TAU( K ) = ZERO + TAU( KK ) = ZERO END IF - WRITE(*,*) "## DLAQP2RK (K, TAU(K) )=", K, TAU(K) + WRITE(*,*) "## DLAQP2RK (K, TAU(Kk) )=", KK, TAU(KK) * -* Check if TAU(K) is NaN, set INFO parameter +* Check if TAU(KK) is NaN, set INFO parameter * to the column number where NaN is found and return from * the routine. -* NOTE: There is no need to check TAU(K) for Inf, -* since *LARFG cannot produce TAU(K) or Householder vector +* NOTE: There is no need to check TAU(KK) for Inf, +* since *LARFG cannot produce TAU(KK) or Householder vector * below the diagonal containing Inf. Only BETA on the diagonal, * returned by *LARFG can contain Inf, which requires -* TAU(K) to be NaN. Therefore, this case of generating Inf by -* *DLARFG is covered by checking TAU(K) for NaN. +* TAU(KK) to be NaN. Therefore, this case of generating Inf by +* *DLARFG is covered by checking TAU(KK) for NaN. * - IF( DISNAN( TAU(K) ) ) THEN - KF = K - 1 - INFO = K - WRITE(*,*) "## ## DLAQP2RK ((TAU is NaN)) (K, INFO)", K, INFO + IF( DISNAN( TAU(KK) ) ) THEN + K = KK - 1 + INFO = KK + WRITE(*,*) "## ## DLAQP2RK ((TAU is NaN)) (KK, INFO)", KK, INFO * * Set MAXC2NRMK and RELMAXC2NRMK to NaN. * - MAXC2NRMK = TAU( K ) - RELMAXC2NRMK = TAU( K ) + MAXC2NRMK = TAU( KK ) + RELMAXC2NRMK = TAU( KK ) * -* Array TAU(K:MINMNFACT) is not set and contains -* undefined elements, except the first element TAU(K) = NaN. +* Array TAU(KK:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(KK) = NaN. * RETURN END IF * -* Apply H(K)**T to A(I:M,K+1:N+NRHS) from the left. -* ( If M >= N, then at K = N there is no residual matrix, +* Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. +* ( If M >= N, then at KK = N there is no residual matrix, * i.e. no columns of A to update, only columns of B ) -* If M < N, then at K = M-IOFFSET, I = M and we have a +* If M < N, then at KK = M-IOFFSET, I = M and we have a * one-row residual matrix in A and the elementary -* reflector is a unit matrix, TAU(K) = ZERO, i.e. no update +* reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update * is needed for the residual matrix in A and the * right-hand-side-matrix in B. * Therefore, we update only if -* K < MINMNUPDT = min(M-IOFFSET, N+NRHS) -* condition is satisfied, not only K < N+NRHS ) -* - IF( K.LT.MINMNUPDT ) THEN - AIK = A( I, K ) - A( I, K ) = ONE - CALL DLARF( 'Left', M-I+1, N+NRHS-K, A( I, K ), 1, - $ TAU( K ), A( I, K+1 ), LDA, WORK( 1 ) ) - A( I, K ) = AIK +* KK < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only KK < N+NRHS ) +* + IF( KK.LT.MINMNUPDT ) THEN + AIKK = A( I, KK ) + A( I, KK ) = ONE + CALL DLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) ) + A( I, KK ) = AIKK END IF * - IF( K.LT.MINMNFACT ) THEN + IF( KK.LT.MINMNFACT ) THEN * * Update the partial column 2-norms for the residual matrix, -* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. -* when K < min(M-IOFFSET, N). +* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. +* when KK < min(M-IOFFSET, N). * - DO J = K + 1, N + DO J = KK + 1, N IF( VN1( J ).NE.ZERO ) THEN * * NOTE: The following lines follow from the analysis in @@ -671,18 +671,18 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * i.e. no condition was triggered to exit the routine. * Set the number of factorized columns. * - KF = KMAX + K = KMAX * * We reached the end of the loop, i.e. all KMAX columns were * factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before * we return. * - IF( KF.LT.MINMNFACT ) THEN + IF( K.LT.MINMNFACT ) THEN * - JMAXC2NRM = KF + IDAMAX( N-KF, VN1( KF+1 ), 1 ) + JMAXC2NRM = K + IDAMAX( N-K, VN1( K+1 ), 1 ) MAXC2NRMK = VN1( JMAXC2NRM ) * - IF( KF.EQ.0 ) THEN + IF( K.EQ.0 ) THEN RELMAXC2NRMK = ONE ELSE RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM @@ -695,9 +695,9 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * We reached the end of the loop, i.e. all KMAX columns were * factorized, set TAUs corresponding to the columns that were -* not factorized to ZERO, i.e. TAU(KF+1:MINMNFACT) set to ZERO. +* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. * - DO J = KF + 1, MINMNFACT + DO J = K + 1, MINMNFACT TAU( J ) = ZERO END DO * From 395d04e7f6ae1083cd32420f9765ad61e08310bd Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:07 -0800 Subject: [PATCH 049/106] Changed tha text alignment in INFO description in DGEQP3RK and DLAQP3RK --- SRC/dgeqp3rk.f | 8 ++++---- SRC/dlaqp3rk.f | 10 +++++----- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index be6ea6916c..132e6bbb85 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -460,13 +460,13 @@ *> *> On exit: *> K is set to the number of -*> factorized columns without -*> exception. +*> factorized columns without +*> exception. *> MAXC2NRMK is set to NaN. *> RELMAXC2NRMK is set to NaN. *> TAU(K+1:min(M,N)) is not set and contains undefined -*> elements. If j_1=K+1, TAU(K+1) may -*> contain NaN. +*> elements. If j_1=K+1, TAU(K+1) may +*> contain NaN. *> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then *> no NaN element was detected, but +Inf (or -Inf) *> was detected and the routine continues diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 1f63a92227..6aedf22514 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -328,13 +328,13 @@ *> *> On exit: *> KB is set to the number of -*> factorized columns without -*> exception. +*> factorized columns without +*> exception. *> MAXC2NRMK is set to NaN. *> RELMAXC2NRMK is set to NaN. -*> TAU(KB+1:min(M,N)) is not set and contains undefined -*> elements. If j_1=KB+1, TAU(KB+1) may -*> contain NaN. +*> TAU(KB+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=KB+1, TAU(KB+1) +*> may contain NaN. *> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then *> no NaN element was detected, but +Inf (or -Inf) *> was detected and the routine continues From a0341b292d5c7ec19efc333af90c1c8e5eba52da Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 050/106] added a new file for testing TESTING/LIN/dchkqp3rk.f LIN/Makefile LIN/CMakeLists.txt --- TESTING/LIN/CMakeLists.txt | 2 +- TESTING/LIN/Makefile | 2 +- TESTING/LIN/dchkqp3rk.f | 1185 ++++++++++++++++++++++++++++++++++++ 3 files changed, 1187 insertions(+), 2 deletions(-) mode change 100644 => 100755 TESTING/LIN/CMakeLists.txt mode change 100644 => 100755 TESTING/LIN/Makefile create mode 100755 TESTING/LIN/dchkqp3rk.f diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt old mode 100644 new mode 100755 index 2c3e2a5fd7..d05ecd4142 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -110,7 +110,7 @@ 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 dchkql.f dchkqr.f dchkrq.f + dchkpt.f dchkq3.f dchkqp3rk.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 diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile old mode 100644 new mode 100755 index 2474d04db1..026c8d452f --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -137,7 +137,7 @@ 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 dchkql.o dchkqr.o dchkrq.o \ + dchkpt.o dchkq3.o dchkqp3rk.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 \ diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f new file mode 100755 index 0000000000..a3b03d12ca --- /dev/null +++ b/TESTING/LIN/dchkqp3rk.f @@ -0,0 +1,1185 @@ +*> \brief \b DCHKQP3RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* ===================================================================== +* SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, +* $ NXVAL, THRESH, A, COPYA, S, TAU, WORK, +* $ IWORK, NOUT ) +* +* .. Scalar Arguments .. +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), +* $ NXVAL( * ) +* DOUBLE PRECISION A( * ), COPYA( * ), S( * ), +* $ TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKQP3RK tests DGEQP3RK. +*> \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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \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[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) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (MMAX*NSMAX) +*> where MMAX is the maximum value of M in MVAL and NSMAX is the +*> maximum value of NRHS in NSVAL. +*> \endverbatim +*> +*> \param[out] COPYB +*> \verbatim +*> COPYB is DOUBLE PRECISION array, dimension (MMAX*NSMAX) +*> \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] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (MMAX*NMAX + 4*NMAX + MMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, + $ B, COPYB, S, TAU, 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 .. + INTEGER NM, NN, NNS, NNB, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), + $ NVAL( * ), NXVAL( * ) + DOUBLE PRECISION A( * ), COPYA( * ), B( * ), COPYB( * ), + $ 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+100 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE + 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, + $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, M, + $ MINMN, MINMNB_GEN, MODE, N, NB, NB_ZERO, + $ NERRS, NFAIL, NB_GEN, NRHS, NRUN, NX, SHIFT, + $ T + DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ MAXC2NRMK, RELMAXC2NRMK, DTEMP, + $ TEST1, TEST2 +* .. +* .. 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, DGEQP3RK, DLACPY, + $ DAXPY, DSWAP, + $ DORMQR, DLAORD, DLASET, DLATB4, DLATMS, + $ ICOPY, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT, DORMQR_LWORK +* .. +* .. 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 ) = 'QK' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = DLAMCH( 'Epsilon' ) + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) + + TEST1 = DLAMCH('Overflow') + TEST2 = DLAPY2(TEST1,TEST1) + +* + WRITE(*,*) "TEST1=DLAMCH('Overflow'),", + $ " TEST2=DLAPY2(TEST1,TEST1), TEST2.GT.TEST1", + $ TEST1, TEST2, TEST2.GT.TEST1 + + WRITE(*,*) "(1) ______ Loop for M=", M +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) + + +* + WRITE(*,*) "(2) ____ ____ Loop for N=", N +* + DO INS = 1, NNS + NRHS = NSVAL( INS ) + + WRITE(*,*) "(3) ____ ____ ____ Loop for NRHS=", + $ NRHS +* +* Set up parameters with DLATB4 and generate +* M-by-NRHS B matrix with DLATMS. +* IMAT=6: Random, geometric distribution, CNDNUM = 2 +* + CALL DLATB4( PATH, 6, M, NRHS, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' + CALL DLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYB, LDA, WORK, INFO ) + + +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, + $ NRHS, -1, -1, -1, 6, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF + + + DO I = 1, LDA + WRITE(*,*) "======== Generating COPYB", + $ COPYB((1-1)*LDA+I), COPYB((2-1)*LDA+I), + $ COPYB((3-1)*LDA+I), COPYB((4-1)*LDA+I), + $ COPYB((5-1)*LDA+I), COPYB((6-1)*LDA+I), + $ COPYB((7-1)*LDA+I), COPYB((8-1)*LDA+I) + END DO + +* + DO IMAT = 1, NTYPES + WRITE(*,*) "(4) ____ ____ ____ ____ Loop for ", + $ "IMAT, DOTYPE(IMAT)= ", IMAT, DOTYPE(IMAT) + + $ +* +* 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 +* 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 11. Random, Half MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM ) +* one small singular value S(N)=1/CNDNUM +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1: Zero matrix +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) + DO I = 1, MINMN + S( I ) = ZERO + END DO + + WRITE(*,*) "GENERATED ZERO MATRIX" +* + ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 ) + $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrices 2-5. +* +* 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 +* + CALL DLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Rectangular matrices 5-13 that contain zero columns. +* + IF( MINMN.GE.2 ) THEN +* +* 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 +* for matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column. +* + IF( IMAT.EQ.5 ) THEN +* +* First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* 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 +* +* First half of MINMN columns is zero. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Last columns are zero columns, +* starting from (MINMN / 2 + 1) column. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - JB_ZERO + 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Half of the columns in the middle of MINMN +* columns is zero, starting from +* MINMN/2 - (MINMN/2)/2 + 1 column. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* 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 +* +* 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. + + WRITE(*,*) "( M,NB_ZERO, LDA before DLASET", + $ M, NB_ZERO, LDA +* + 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' + + WRITE(*,*) "Generate DLAMTS matrix (M,NB_GEN)=", + $ M, NB_GEN + + 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 ) + + WRITE(*,*) "Singular values after mat generation S=" + WRITE(*,*) + $ S(1), S(2), S(3), S(4), + $ S(5), S(6), S(7), S(8) +* +* 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 + + WRITE(*,*) "Matrix COPYA after", + $ " generation N_ZERO and N_GEN" + DO I = 1, M + WRITE(*,*) + $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), + $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), + $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I), + $ COPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) + END DO + + +* +* 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 + + IF(.FALSE.) THEN +* +* (Part 2) +* Swap the generated columns from the right +* NB_GEN-size block from +* (NB_ZERO+JB_ZERO:NB_ZERO+NB_GEN) +* into columns (1:JB_ZERO-1). +* + DO J = JB_ZERO, NB_GEN, 1 + CALL DSWAP( M, + $ COPYA( (NB_ZERO+J-1)*LDA + 1 ), 1, + $ COPYA( (JB_ZERO+J-1)*LDA + 1 ), 1 ) + END DO + + END IF +* + 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 order and add trailing zeros +* that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) + + WRITE(*,*) "Singular values MINB_GEN=", MINMNB_GEN + WRITE(*,*) "Singular values before ordering S=" + WRITE(*,*) + $ S(1), S(2), S(3), S(4), + $ S(5), S(6), S(7), S(8) +* + CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) + + WRITE(*,*) "Singular values after ordering S=" + WRITE(*,*) + $ S(1), S(2), S(3), S(4), + $ S(5), S(6), S(7), S(8) + + DO I = MINMNB_GEN+1, MINMN + WRITE(*,*) "Singular values to ZERO out I=", I + S( I ) = ZERO + END DO + + WRITE(*,*) "Matrix with ZERO columnms COPYA" + DO I = 1, M + WRITE(*,*) + $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), + $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), + $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I), + $ COPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) + END DO + + + WRITE(*,*) "Matrix with ZERO columns ordering of S=" + WRITE(*,*) + $ S(1), S(2), S(3), S(4), + $ S(5), S(6), S(7), S(8) +* + ELSE +* +* IF(MINMN.LT.2) skip this size for this matrix type. +* + CYCLE + END IF +* + END IF +* + + + WRITE(*,*) "AFTER GENERATING COPYA" + DO I = 1, M + WRITE(*,*) + $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), + $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), + $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I), + $ COPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) + END DO + WRITE(*,*) "AFTER GENERATING COPYA, S=" + WRITE(*,*) + $ S(1), S(2), S(3), S(4), + $ S(5), S(6), S(7), S(8) + +* +* Initialize a copy array for a pivot array for DGEQP3RK. +* + DO I = 1, N + IWORK( I ) = 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 ) +* + WRITE(*,*) "(5) ____ ____ ____ ____ ____ Loop for NB,NX=", + $ NB, NX + +* +* We do MAX(M,N) because we need a test for KMAX > N, +* when KMAX is larger than min(M,N), KMAX should be +* KMAX = min(M,N) +* +** DO KMAX = 1, (MIN(M,N) + 1 +* +** DO KMAX = 1, MIN(M,N) +** DO KMAX = 4, 4 +** DO KMAX = 3, 3 + + DO KMAX = 0, min(M,N) + + + + WRITE(*,*) "(6) ____ ____ ____ ____ ____ ____ Loop for KMAX=", + $ KMAX +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). +* Get a working copy of COPYB into into B( 1:M, 1:NRHS ). +* Get a working copy of IWORK(1:N) into +* which is going to be used as pivot array IWORK( N+1:2N ). +* NOTE: IWORK(2N+1:3N) is going to be used as a WORK array +* for the routine. +* + CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + + WRITE(*,*) " ____ ____ ____ ____ ____ ____ set NaN", + $ " in mat A after copy" + + + +* TEST1 = 1.0 +* TEST2 = 1.0 +* A((3-1)*LDA+3) = 0.0/(TEST1-TESt2) + +** TEST1 = DLAMCH('Overflow') + +** A((3-1)*LDA+3) = TEST1 *TEST1 +** A((3-1)*LDA+5) = + + + CALL DLACPY( 'All', M, NRHS, COPYB, LDA, + $ A( LDA*N + 1 ), LDA ) + CALL DLACPY( 'All', M, NRHS, COPYB, LDA, + $ B, LDA ) + CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) +* +* +* Compute the QR factorization with pivoting of A +* + LW = MAX( 1, 2*N+NB*( N+1 ) ) +* +* Compute DGEQP3RK factorization of A. +* + + ABSTOL = -1.0 + RELTOL = -1.0 + + + +* +* ABSTOL = 1.0D+300 +* RELTOL = 2.0 +* +** ABSTOL = -1.0 +** RELTOL = 0.3 + +* +* 310 < dtest_my02.in +* (To exit after 2 cols) +* + +** ABSTOL = 7.26D-004 +** RELTOL = -1.0 +* +* 310 < dtest_my12.in (also < dtest_my02.in ) +* (ABSTOL = 1.8302569483745663E-004) +* to exit after the second column + +* ABSTOL = 1.82D-004 +* RELTOL = -1.0 + + +* +* Process 1 column +* +** ABSTOL = 0.63 +** RELTOL = -1.0 + +* +* Process 2 columns +* +* ABSTOL = 0.49 +* RELTOL = -1.0 + +** ABSTOL = -1.0 +** RELTOL = -1.0 + +** ABSTOL = 0.7 +** RELTOL = -1.0 + +* ABSTOL = -1.0 +* RELTOL = -1.0 + +* ABSTOL = 1.1405204575311260E-004 +* RELTOL = -1.0 + +* (5x5) whole matrix +* ABSTOL = 0.66704678404750084 +* RELTOL = -1.0 + + +* (5x5) only ABSTOL for (4x4) submatrix +* ABSTOL = 1.1405304575311260E-004 +* RELTOL = -1.0 +* +* (5x5) only ABSTOL for (3x3) submatrix +* ABSTOL = 6.0481785131836600E-008 +* RELTOL = -1.0 + +* (5x5) only ABSTOL for (2x2) submatrix +* ABSTOL = 1.3084410232299372E-011 +* RELTOL = -1.0 + +* (5x5) only ABSTOL for (1x1) submatrix +* ABSTOL = 3.8085269032348996E-015 +* RELTOL = -1.0 + +* +* +* (5x5) only ABSTOL for (1x1) submatrix +* ABSTOL = -1.0 +* RELTOL = 5.7095334155208096E-015 + + + WRITE(*,*) "inside the test M=", M, " N=", N, + $ " IMAT=", IMAT, " NB=", NB," NX=", NX + WRITE(*,*) "NRHS=", NRHS, " KMAX=", KMAX, + $ " ABSTOL=", ABSTOL, " RELTOL=", RELTOL + WRITE(*,*) " " + + WRITE(*,*) "B(BEGIN) VALUE OF B after COPYB into B" + + DO I = 1, LDA + WRITE(*,*) + $ B((1-1)*LDA+I), B((2-1)*LDA+I), + $ B((3-1)*LDA+I), B((4-1)*LDA+I), + $ B((5-1)*LDA+I), B((6-1)*LDA+I), + $ B((7-1)*LDA+I), B((8-1)*LDA+I), + $ B((9-1)*LDA+I), B((10-1)*LDA+I) +* $ ,B((11-1)*LDA+I), B((12-1)*LDA+I) + END DO +* +* + WRITE(*,*) "A(BEGIN) AFTER copying COPYA", + $ " and COPY B into A" + DO I = 1, LDA + WRITE(*,*) + $ A((1-1)*LDA+I), A((2-1)*LDA+I), + $ A((3-1)*LDA+I), A((4-1)*LDA+I), + $ A((5-1)*LDA+I), A((6-1)*LDA+I), + $ A((7-1)*LDA+I), A((8-1)*LDA+I), + $ A((9-1)*LDA+I), A((10-1)*LDA+I) +* $ ,A((11-1)*LDA+I), A((12-1)*LDA+I) + END DO + WRITE(*,*) " " + + WRITE(*,*) "TAU before DGEQP3RK" + WRITE(*,*) + $ TAU(1), TAU(2), TAU(3), TAU(4), + $ TAU(5), TAU(6), TAU(7), TAU(8) + WRITE(*,*) " " + + WRITE(*,*) "jPIV before DGEQP3RK" + WRITE(*,*) + $ IWORK(N+1), IWORK(2), IWORK(3), IWORK(4), + $ IWORK(5), IWORK(6), IWORK(7), IWORK(8) + WRITE(*,*) " " + + SRNAMT = 'DGEQP3RK' + CALL DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ A, LDA, KFACT, MAXC2NRMK, + $ RELMAXC2NRMK, IWORK( N+1 ), TAU, + $ WORK, LW, IWORK( 2*N+1 ), INFO ) + + + * +* + WRITE(*,*) "A after DGEQP3RK" + DO I = 1, LDA + WRITE(*,*) + $ A((1-1)*LDA+I), A((2-1)*LDA+I), + $ A((3-1)*LDA+I), A((4-1)*LDA+I), + $ A((5-1)*LDA+I), A((6-1)*LDA+I), + $ A((7-1)*LDA+I), A((8-1)*LDA+I), + $ A((9-1)*LDA+I), A((10-1)*LDA+I) +* $ ,A((11-1)*LDA+I), A((12-1)*LDA+I) + END DO + WRITE(*,*) "TAU after DGEQP3RK" + WRITE(*,*) + $ TAU(1), TAU(2), TAU(3), TAU(4), + $ TAU(5), TAU(6), TAU(7), TAU(8) + WRITE(*,*) " " + + WRITE(*,*) "JPIV after DGEQP3RK" + WRITE(*,*) + $ IWORK(N+1), IWORK(N+2), IWORK(N+3), IWORK(N+4), + $ IWORK(N+5), IWORK(N+6), IWORK(N+7), IWORK(N+8) + WRITE(*,*) " " + + WRITE(*,*) "INFO after DGEQP3RK" + WRITE(*,*) INFO + WRITE(*,*) " " +* +* Check error code from DGEQP3RK. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'DGEQP3RK', 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 ) +* + WRITE(*,*) "After DGEQP3RK, KFACT, MAX2N, REL2N", + $ KFACT, MAXC2NRMK, RELMAXC2NRMK + + IF( KFACT.EQ.MINMN ) THEN +* + RESULT( 1 ) = DQRT12( M, N, A, LDA, S, WORK, + $ LWORK ) +* + DO T = 1, 1 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, NB, NX, + $ IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 + END IF +* +* +* + DO I = 1, MIN(M,N) + WRITE(*,*) "Generated_S(", I, ")=", S(I) + END DO +* +* 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, KFACT, COPYA, A, LDA, TAU, + $ IWORK( N+1 ), WORK, LWORK ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = DQRT11( M, KFACT, A, LDA, TAU, WORK, + $ LWORK ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 2, 3 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater than 2. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)), +* K=1:KFACT-1 +* + IF( MIN(KFACT, MINMN).GE.2 ) THEN +* + DO J = 1, KFACT-1, 1 + WRITE(*,*) " TEST 4: Diagonal (I, A(I), A(I+1) )" + WRITE(*,*) J, ABS( A( (J-1)*M+J ) ), + $ ABS( A( (J)*M+J+1 ) ) + + DTEMP = (( ABS( A( (J-1)*M+J ) ) - + $ ABS( A( (J)*M+J+1 ) ) ) / + $ ABS( A(1) ) ) + + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF + END DO +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 4, 4 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', + $ M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, + $ RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* Compute test 5: +* +* This test in only for matrix A with min(M,N) > 0. +* +* The test returns the ratio: +* +* 1-norm(Q**T * B - Q**T * B ) / +* ( M * EPS ) +* +* (1) Compute B:=Q**T * B in the matrix B. +* + IF( MIN(M,N).GT.0 ) THEN +* + + WRITE(*,*) + WRITE(*,*) "TEST 5: B before computing Q**T * B" + DO I = 1, LDA + WRITE(*,*) + $ B((1-1)*LDA+I), B((2-1)*LDA+I), + $ B((3-1)*LDA+I), B((4-1)*LDA+I), + $ B((5-1)*LDA+I), B((6-1)*LDA+I), + $ B((7-1)*LDA+I), B((8-1)*LDA+I), + $ B((9-1)*LDA+I), B((10-1)*LDA+I) +* $ ,B((11-1)*LDA+I), B((12-1)*LDA+I) + END DO +* + DORMQR_LWORK = MAX(1, NRHS) + CALL DORMQR( 'Left', 'Transpose', M, NRHS, KFACT, + $ A, LDA, TAU, B, LDA, WORK, + $ DORMQR_LWORK, INFO ) +* +* + WRITE(*,*) + WRITE(*,*) "TEST 5: B after computing Q**T * B" +* + DO I = 1, LDA + WRITE(*,*) + $ B((1-1)*LDA+I), B((2-1)*LDA+I), + $ B((3-1)*LDA+I), B((4-1)*LDA+I), + $ B((5-1)*LDA+I), B((6-1)*LDA+I), + $ B((7-1)*LDA+I), B((8-1)*LDA+I), + $ B((9-1)*LDA+I), B((10-1)*LDA+I) +* $ ,B((11-1)*LDA+I), B((12-1)*LDA+I) + END DO + + + DO I = 1, NRHS +* +* Compare N+J-th column of A and J-column of B. +* + CALL DAXPY( M, -ONE, A( ( N+I-1 )*LDA+1 ), 1, + $ B( ( I-1 )*LDA+1 ), 1 ) + + + END DO +* + WRITE(*,*) + WRITE(*,*) "TEST 5: B after B:= A(B) - Q**T * B" +* + DO I = 1, LDA + WRITE(*,*) + $ B((1-1)*LDA+I), B((2-1)*LDA+I), + $ B((3-1)*LDA+I), B((4-1)*LDA+I), + $ B((5-1)*LDA+I), B((6-1)*LDA+I), + $ B((7-1)*LDA+I), B((8-1)*LDA+I), + $ B((9-1)*LDA+I), B((10-1)*LDA+I) +* $ ,B((10-1)*LDA+I), B((11-1)*LDA+I) + END DO +* + RESULT( 5 ) = + $ ABS( + $ DLANGE( 'One-norm', M, NRHS, B, M, RDUMMY ) / + $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) + $ ) + + WRITE(*,*) "TEST 5: DLANGE, RESULT( 5 )", + $ DLANGE( 'One-norm', M, NRHS, B, M, RDUMMY ), + $ RESULT( 5 ) + WRITE(*,*) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 5, 5 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'DGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End compute test 5. +* + END IF +* +* END DO KMAX = 1, MAX(M,N) +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for INS = 1, NNS +* + 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, ', NRHS =', I5, + $ ', KMAX =', I5, ', ABSTOL =', G12.5, ', RELTOL =', G12.5, + $ ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of DCHKQP3RK +* + END From 79f4d030e30df1cb47567559a3a0233c1e79595e Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 051/106] added testing for truncated Qr TESTING/LIN/dchkq3rk.f --- TESTING/LIN/dchkaa.F | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) mode change 100644 => 100755 TESTING/LIN/dchkaa.F diff --git a/TESTING/LIN/dchkaa.F b/TESTING/LIN/dchkaa.F old mode 100644 new mode 100755 index ef9d7808ce..915258789d --- a/TESTING/LIN/dchkaa.F +++ b/TESTING/LIN/dchkaa.F @@ -63,6 +63,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 *> DTZ 3 List types on next line if 0 < NTYPES < 3 *> DLS 6 List types on next line if 0 < NTYPES < 6 *> DEQ @@ -164,8 +165,8 @@ PROGRAM DCHKAA * .. External Subroutines .. EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, $ DCHKORHR_COL, DCHKPB, DCHKPO, DCHKPS, DCHKPP, - $ DCHKPT, DCHKQ3, DCHKQL, DCHKQR, DCHKRQ, DCHKSP, - $ DCHKSY, DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, + $ DCHKPT, DCHKQ3, DCHKQP3RK, DCHKQL, DCHKQR, DCHKRQ, + $ DCHKSP, DCHKSY, DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, $ DCHKTB, DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, $ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT, $ DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK, @@ -919,9 +920,26 @@ PROGRAM DCHKAA CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN - CALL DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL, - $ THRESH, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), - $ B( 1, 3 ), WORK, IWORK, NOUT ) + CALL DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, + $ NXVAL, THRESH, A( 1, 1 ), A( 1, 2 ), + $ B( 1, 1 ), B( 1, 3 ), WORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* QK: truncated QR factorization with pivoting +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ), + $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), B( 1, 4 ), + $ WORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF From 7c1c8b0271dbe07947eb0462c6faf48ff5d8d7fd Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 052/106] updated LIN/alaerh.f with GEQP3RK --- TESTING/LIN/alaerh.f | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) mode change 100644 => 100755 TESTING/LIN/alaerh.f diff --git a/TESTING/LIN/alaerh.f b/TESTING/LIN/alaerh.f old mode 100644 new mode 100755 index 1845888a66..6c8a47f1e2 --- a/TESTING/LIN/alaerh.f +++ b/TESTING/LIN/alaerh.f @@ -797,6 +797,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, 'QK' ) ) THEN +* +* xQK: truncated QR factorization with pivoting +* + IF( LSAMEN( 7, SUBNAM( 2: 8 ), 'GEQP3RK' ) ) 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 * @@ -1147,6 +1159,11 @@ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, * What we do next * 9949 FORMAT( ' ==> Doing only the condition estimate for this case' ) +* +* SUBNAM, INFO, M, N, NB, IMAT +* + 9930 FORMAT( ' *** Error code from ', A, '=', I5, / ' ==> M =', I5, + $ ', N =', I5, ', NX =', I5, ', NB =', I4, ', type ', I2 ) * RETURN * From e209e7392532822ca25926c57ae228f2255fa602 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 053/106] added test matrices types reporting and test type reporinting for DGEQP3RK in TESTING/LIN/alahd.f --- TESTING/LIN/alahd.f | 62 ++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 58 insertions(+), 4 deletions(-) mode change 100644 => 100755 TESTING/LIN/alahd.f diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f old mode 100644 new mode 100755 index dd75394b3a..ca090c9763 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -584,13 +584,27 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) * * QR decomposition with column pivoting * - WRITE( IOUNIT, FMT = 9986 )PATH + WRITE( IOUNIT, FMT = 8006 )PATH WRITE( IOUNIT, FMT = 9969 ) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9940 )1 WRITE( IOUNIT, FMT = 9939 )2 WRITE( IOUNIT, FMT = 9938 )3 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) +* + ELSE IF( LSAMEN( 2, P2, 'QK' ) ) THEN +* +* truncated QR decomposition with column pivoting +* + WRITE( IOUNIT, FMT = 8006 )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 = 8064 )5 + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'TZ' ) ) THEN * @@ -779,6 +793,8 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) $ 'tall-skinny or short-wide matrices' ) 8005 FORMAT( / 1X, A3, ': Householder reconstruction from TSQR', $ ' factorization output ', /,' for tall-skinny matrices.' ) + 8006 FORMAT( / 1X, A3, ': truncated QR factorization', + $ ' with column pivoting' ) * * GE matrix types * @@ -922,6 +938,36 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) $ / 4X, '3. Geometric distribution', 10X, $ '6. Every second column fixed' ) * +* 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, ' 8. Random, Middle column in MINMN is zero,', + $ ' CNDNUM = 2', / + $ 4X, ' 9. Random, First half of MINMN columns are zero,', + $ ' CNDNUM = 2', / + $ 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', / + $ 4X, '17. Random, CNDNUM = 0.1/EPS,', + $ ' one small singular value S(N)=1/CNDNUM', / + $ 4X, '18. Random, CNDNUM = 2, scaled near underflow,', + $ ' NORM = SMALL = SAFMIN', / + $ 4X, '19. Random, CNDNUM = 2, scaled near overflow,', + $ ' NORM = LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) )' ) +* * TZ matrix types * 9968 FORMAT( ' Matrix types (2-3 have condition 1/EPS):', / 4X, @@ -1030,9 +1076,8 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) $ ' * norm(C) * EPS )' ) 9940 FORMAT( 3X, I2, ': norm(svd(A) - svd(R)) / ', $ '( M * norm(svd(R)) * EPS )' ) - 9939 FORMAT( 3X, I2, ': norm( A*P - Q*R ) / ( M * norm(A) * EPS )' - $ ) - 9938 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' ) + 9939 FORMAT( 3X, I2, ': norm( A*P - Q*R ) / ( M * norm(A) * EPS )') + 9938 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' ) 9937 FORMAT( 3X, I2, ': norm( A - R*Q ) / ( M * norm(A) * EPS )' $ ) 9935 FORMAT( 3X, I2, ': norm( B - A * X ) / ', @@ -1105,6 +1150,15 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) 8054 FORMAT(3X,I2,': norm( C*Q - C*Q ) / ( M * norm(C) * EPS )' ) 8055 FORMAT(3X,I2,': norm( C*Q'' - C*Q'' ) / ( M * norm(C) * EPS )') + 8060 FORMAT( 3X, I2, ': 2-norm(svd(A) - svd(R)) / ', + $ '( max(M,N) * 2-norm(svd(R)) * EPS )' ) + 8061 FORMAT( 3X, I2, ': 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A)', + $ ' * EPS )') + 8062 FORMAT( 3X, I2, ': 1-norm( I - Q''*Q ) / ( M * EPS )' ) + 8063 FORMAT( 3X, I2, ': Returns 1.0D+100 if abs(R(K+1,K+1))', + $ ' > abs(R(K,K)), where K=1:KFACT-1' ) + 8064 FORMAT( 3X, I2, ': 1-norm(Q**T * B - Q**T * B ) / ( M * EPS )') + * RETURN * From 14e5f471f3f2d4682756cd1d27be30bfacd812b7 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 054/106] matrix configuration for DGEQP3RK in LIN/dlatb4.f --- TESTING/LIN/dlatb4.f | 135 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 134 insertions(+), 1 deletion(-) mode change 100644 => 100755 TESTING/LIN/dlatb4.f diff --git a/TESTING/LIN/dlatb4.f b/TESTING/LIN/dlatb4.f old mode 100644 new mode 100755 index 28689877c7..8bd285ebbb --- a/TESTING/LIN/dlatb4.f +++ b/TESTING/LIN/dlatb4.f @@ -133,7 +133,7 @@ SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, * * .. Parameters .. DOUBLE PRECISION SHRINK, TENTH - PARAMETER ( SHRINK = 0.25D0, TENTH = 0.1D+0 ) + PARAMETER ( SHRINK = 0.25D+0, TENTH = 0.1D+0 ) DOUBLE PRECISION ONE PARAMETER ( ONE = 1.0D+0 ) DOUBLE PRECISION TWO @@ -224,6 +224,139 @@ SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE ANORM = ONE END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* xQK: 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' is +* + DIST = 'S' +* +* Set the lower and upper bandwidths. +* + 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 +* +* Set the condition number. +* +* IF ( IMAT.EQ.6 ) THEN +* CNDNUM = BADC1 +* ELSE IF ( IMAT.EQ.7 ) THEN +* CNDNUM = BADC2 +* ELSE IF ( IMAT.EQ.8 ) THEN +* CNDNUM = BADC2 +* ELSE +* CNDNUM = TWO +* END IF +* +* Set norm +* +* IF( IMAT.EQ.9 ) THEN +* ANORM = SMALL8 +* ELSE IF( IMAT.EQ.10 ) THEN +* ANORM = LARGE +* ELSE +* ANORM = ONE +* END IF +* +* Set MODE +* +* IF( IMAT.EQ.8 ) THEN +* MODE = 2 +* ELSE +* MODE = 3 +* END IF * ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN * From a111c9bb6152208bd46e23be0f43f3aedbceb7a9 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 055/106] Changed comments and updated GOTO statements in LIN/dqpt01.f --- TESTING/LIN/dqpt01.f | 42 ++++++++++++++++++++++++++++-------------- 1 file changed, 28 insertions(+), 14 deletions(-) mode change 100644 => 100755 TESTING/LIN/dqpt01.f diff --git a/TESTING/LIN/dqpt01.f b/TESTING/LIN/dqpt01.f old mode 100644 new mode 100755 index 8efbdc774d..af3f5dd364 --- a/TESTING/LIN/dqpt01.f +++ b/TESTING/LIN/dqpt01.f @@ -28,12 +28,13 @@ *> *> DQPT01 tests the QR-factorization with pivoting of a matrix A. The *> array AF contains the (possibly partial) QR-factorization of A, where -*> the upper triangle of AF(1:k,1:k) is a partial triangular factor, -*> the entries below the diagonal in the first k columns are the +*> the upper triangle of AF(1:K,1:K) is a partial triangular factor, +*> the entries below the diagonal in the first K columns are the *> Householder vectors, and the rest of AF contains a partially updated *> matrix. *> -*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) +*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) ), +*> where || . || is matrix one norm. *> \endverbatim * * Arguments: @@ -172,28 +173,41 @@ DOUBLE PRECISION FUNCTION DQPT01( M, N, K, A, AF, LDA, TAU, JPVT, * NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK ) * - DO 30 J = 1, K - DO 10 I = 1, MIN( J, M ) + DO J = 1, K +* +* Copy the upper triangular part of the factor R stored +* in AF(1:K,1:K) into the work array WORK. +* + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - DO 20 I = J + 1, M + END DO +* +* Zero out the elements below the diagonal in the work array. +* + DO I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO - 20 CONTINUE - 30 CONTINUE - DO 40 J = K + 1, N + END DO + END DO +* +* Copy columns (K+1,N) from AF into the work array WORK. +* AF(1:K,K+1:N) contains the rectangular block of the upper trapezoidal +* factor R, AF(K+1:M,K+1:N) contains the partially updated residual +* matrix of R. +* + DO J = K + 1, N CALL DCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) - 40 CONTINUE + END DO * CALL DORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * - DO 50 J = 1, N + DO J = 1, N * -* Compare i-th column of QR and jpvt(i)-th column of A +* Compare J-th column of QR and JPVT(J)-th column of A. * CALL DAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ), $ 1 ) - 50 CONTINUE + END DO * DQPT01 = DLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) ) From ea810c995c24ba62f0ed7a23257cf6d7e969460a Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 056/106] replaced GO TO statements with DO J=1,M ... END DO in dqrt11.f --- TESTING/LIN/dqrt11.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 TESTING/LIN/dqrt11.f diff --git a/TESTING/LIN/dqrt11.f b/TESTING/LIN/dqrt11.f old mode 100644 new mode 100755 index 33c7fab378..38bbeb8228 --- a/TESTING/LIN/dqrt11.f +++ b/TESTING/LIN/dqrt11.f @@ -157,9 +157,9 @@ DOUBLE PRECISION FUNCTION DQRT11( M, K, A, LDA, TAU, WORK, LWORK ) CALL DORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M, $ WORK( M*M+1 ), INFO ) * - DO 10 J = 1, M + DO J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE - 10 CONTINUE + END DO * DQRT11 = DLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) From 2eac2f6332279ec00341eee197c16d79f9c63f8b Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 057/106] replaced GO TO statements with DO J=1,M ... END DO in dqrt12.f and corrected description formula --- TESTING/LIN/dqrt12.f | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) mode change 100644 => 100755 TESTING/LIN/dqrt12.f diff --git a/TESTING/LIN/dqrt12.f b/TESTING/LIN/dqrt12.f old mode 100644 new mode 100755 index a3bfbebb3d..b8a124c591 --- a/TESTING/LIN/dqrt12.f +++ b/TESTING/LIN/dqrt12.f @@ -26,7 +26,7 @@ *> DQRT12 computes the singular values `svlues' of the upper trapezoid *> of A(1:M,1:N) and returns the ratio *> -*> || s - svlues||/(||svlues||*eps*max(M,N)) +*> || svlues - s ||/(||s||*eps*max(M,N)) *> \endverbatim * * Arguments: @@ -144,11 +144,11 @@ DOUBLE PRECISION FUNCTION DQRT12( M, N, A, LDA, S, WORK, LWORK ) * Copy upper triangle of A into work * CALL DLASET( 'Full', M, N, ZERO, ZERO, WORK, M ) - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) + DO J = 1, N + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE + END DO + END DO * * Get machine parameters * @@ -197,16 +197,18 @@ DOUBLE PRECISION FUNCTION DQRT12( M, N, A, LDA, S, WORK, LWORK ) * ELSE * - DO 30 I = 1, MN + DO I = 1, MN WORK( M*N+I ) = ZERO - 30 CONTINUE + END DO END IF * * Compare s and singular values of work * CALL DAXPY( MN, -ONE, S, 1, WORK( M*N+1 ), 1 ) +* DQRT12 = DASUM( MN, WORK( M*N+1 ), 1 ) / - $ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) ) + $ ( DLAMCH('Epsilon') * DBLE( MAX( M, N ) ) ) +* IF( NRMSVL.NE.ZERO ) $ DQRT12 = DQRT12 / NRMSVL * From 8d7f6153302daffaaee19b959718f253962be511 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 058/106] added DQK test path for DGEQP3RK into TESTING/dtest.in --- TESTING/dtest.in | 1 + 1 file changed, 1 insertion(+) diff --git a/TESTING/dtest.in b/TESTING/dtest.in index 29bb8b92eb..1b6c7bd4a8 100644 --- a/TESTING/dtest.in +++ b/TESTING/dtest.in @@ -36,6 +36,7 @@ DRQ 8 List types on next line if 0 < NTYPES < 8 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 DTZ 3 List types on next line if 0 < NTYPES < 3 DLS 6 List types on next line if 0 < NTYPES < 6 DEQ From 36fa12432d9133b3fce714c9b807f3b78be6aea0 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 059/106] added IMPLICIT NONE to TESTING/LIN/dchkqp3rk.f --- TESTING/LIN/dchkqp3rk.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index a3b03d12ca..66d3e3d60b 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -12,7 +12,7 @@ * SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, * $ NXVAL, THRESH, A, COPYA, S, TAU, WORK, * $ IWORK, NOUT ) -* +* IMPLICIT NONE * .. Scalar Arguments .. * INTEGER NM, NN, NNB, NOUT * DOUBLE PRECISION THRESH From 46ef59fcee5af505e9bf946bbc3598f2fb9e8029 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 060/106] fixed description from '\ingroup heqp3rk' to '\ingroup geqp3rk' in SRC/dgeqp3rk.f --- SRC/dgeqp3rk.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 132e6bbb85..99557ad968 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -485,7 +485,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup heqp3rk +*> \ingroup geqp3rk * *> \par Further Details: * ===================== From 18c19a461c27aed401dbe390e99050883751232c Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 061/106] fixed a typo in TESTING/LIN/alahd.f --- TESTING/LIN/alahd.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f index ca090c9763..8f966c5841 100755 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -1155,7 +1155,7 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) 8061 FORMAT( 3X, I2, ': 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A)', $ ' * EPS )') 8062 FORMAT( 3X, I2, ': 1-norm( I - Q''*Q ) / ( M * EPS )' ) - 8063 FORMAT( 3X, I2, ': Returns 1.0D+100 if abs(R(K+1,K+1))', + 8063 FORMAT( 3X, I2, ': Returns 1.0D+100, if abs(R(K+1,K+1))', $ ' > abs(R(K,K)), where K=1:KFACT-1' ) 8064 FORMAT( 3X, I2, ': 1-norm(Q**T * B - Q**T * B ) / ( M * EPS )') From 12e939727a9b2b9b9d3b2ca6e2744af40540f8bf Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 062/106] Corrected WORK array size requirements for minimum and optimal size in DGEQP3RK and tests as well. Also reduces the requirement for WORK array size in DLAQP2RK to from N to N-1 --- SRC/dgeqp3rk.f | 45 ++++++++++++++++++++++++++++++++++++----- SRC/dlaqp2rk.f | 4 ++-- TESTING/LIN/dchkqp3rk.f | 2 +- 3 files changed, 43 insertions(+), 8 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 99557ad968..a41a31a009 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -426,9 +426,18 @@ *> \param[in] LWORK *> \verbatim *> LWORK is INTEGER -*> The dimension of the array WORK. LWORK >= 3*N+1. -*> For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB -*> is the optimal block size for DGEQP3RK returned by ILAENV. +*> The dimension of the array WORK. +*. LWORK >= (2*N + (N+NRHS) - 1). +*> For optimal performance LWORK >= (2*N + NB*( N+NRHS+1 )), +*> where NB is the optimal block size for DGEQP3RK returned +*> by ILAENV. Minimal block size MINNB=2. +*> +*> NOTE: The decision, whether to use unblocked BLAS 2 +*> or blocked BLAS 3 code is based not only on the dimension +*> LWORK of the availbale workspace WORK, but also also on the +*> matrix A dimension N via crossover point NX returned +*> by ILAENV. (For N less than NX, unblocked code should be +*> used.) *> *> If LWORK = -1, then a workspace query is assumed; *> the routine only calculates the optimal size of the WORK @@ -645,12 +654,38 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, IWS = 1 LWKOPT = 1 ELSE - IWS = 3*N +* +* Minimal workspace size in case of using only unblocked +* BLAS 2 code in DLAQP2RK. +* 1) DGEQP3RK and DLAQP2RK: 2*N to store full and partial +* column 2-norms. +* 2) DLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in DLARF subroutine inside DLAQP2RK to apply an +* elementary reflector from the left. +* TOTAL_WORK_SIZE = 3*N + NRHS - 1 +* + IWS = 3*N + NRHS - 1 * * Assign to NB optimal block size. * NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) - LWKOPT = 2*N + NB*( 1+N+NRHS ) +* +* A formula for the optimal workspace size in case of using +* both unblocked BLAS 2 in DLAQP2RK and blocked BLAS 3 code +* in DLAQP3RK. +* 1) DGEQP3RK, DLAQP2RK, DLAQP3RK: 2*N to store full and +* partial column 2-norms. +* 2) DLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in DLARF subroutine to apply an elementary reflector +* from the left. +* 3) DLAQP3RK: NB*(N+NRHS) to use in the work array F that +* is used to apply a block reflector from +* the left. +* 4) DLAQP3RK: NB to use in the auxilixary array AUX. +* Sizes (2) and ((3) + (4)) should intersect, therefore +* TOTAL_WORK_SIZE = 2*N + NB*( N+NRHS+1 ), given NBMIN=2. +* + LWKOPT = 2*N + NB*( N+NRHS+1 ) END IF WORK( 1 ) = DBLE( LWKOPT ) * diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index de53720363..c5ff49c334 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -251,9 +251,9 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (N) +*> WORK is DOUBLE PRECISION array, dimension (N-1) *> Used in DLARF subroutine to apply an elementary -*> reflector. +*> reflector from the left. *> \endverbatim *> *> \param[out] INFO diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index 66d3e3d60b..008faf2ca4 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -755,7 +755,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * * Compute the QR factorization with pivoting of A * - LW = MAX( 1, 2*N+NB*( N+1 ) ) + LW = MAX( 1, MAX( 2*N+NB*( N+1 ) , 3*N+NRHS-1 ) ) * * Compute DGEQP3RK factorization of A. * From 4161851dd69cbafcefea329928a7a7d026f43069 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 063/106] changed padding of parameters in the function signature of DGEQP3RK --- SRC/dgeqp3rk.f | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index a41a31a009..97af5dd1d0 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -18,14 +18,14 @@ * Definition: * =========== * -* SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, -* $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, -* $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) +* SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ WORK, LWORK, IWORK, INFO ) * IMPLICIT NONE * * .. Scalar Arguments .. * INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS -* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL * .. * .. Array Arguments .. * INTEGER IWORK( * ), JPIV( * ) @@ -570,9 +570,9 @@ *> \endhtmlonly * * ===================================================================== - SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, - $ A, LDA, K, MAXC2NRMK, RELMAXC2NRMK, - $ JPIV, TAU, WORK, LWORK, IWORK, INFO ) + SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ WORK, LWORK, IWORK, INFO ) IMPLICIT NONE * * -- LAPACK computational routine -- From 8482937cfa4442c210863d9af34cc48435b8ad4e Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 064/106] added GEQP3RK to ILAENV routine, it changed ilaenv.f and dgeqp3rk.f --- SRC/dgeqp3rk.f | 6 +++--- SRC/ilaenv.f | 19 +++++++++++++++++++ 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 97af5dd1d0..0fb5cee3ef 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -668,7 +668,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * * Assign to NB optimal block size. * - NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 ) + NB = ILAENV( INB, 'DGEQP3RK', ' ', M, N, -1, -1 ) * * A formula for the optimal workspace size in case of using * both unblocked BLAS 2 in DLAQP2RK and blocked BLAS 3 code @@ -889,7 +889,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * Determine when to cross over from blocked to unblocked code. * (for N less than NX, unblocked code should be used). * - NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', M, N, -1, -1 ) ) + NX = MAX( 0, ILAENV( IXOVER, 'DGEQP3RK', ' ', M, N, -1, -1 )) * IF( NX.LT.MINMN ) THEN * @@ -902,7 +902,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * Reduce NB and determine the minimum value of NB. * NB = ( LWORK-2*N ) / ( N+1 ) - NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', M, N, + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQP3RK', ' ', M, N, $ -1, -1 ) ) * END IF diff --git a/SRC/ilaenv.f b/SRC/ilaenv.f index a03d0abe97..e74a2b35ec 100644 --- a/SRC/ilaenv.f +++ b/SRC/ilaenv.f @@ -355,6 +355,12 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ELSE NB = 64 END IF + ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF END IF ELSE IF( C2.EQ.'PO' ) THEN IF( C3.EQ.'TRF' ) THEN @@ -541,7 +547,14 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ELSE NBMIN = 2 END IF + ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF END IF + ELSE IF( C2.EQ.'SY' ) THEN IF( C3.EQ.'TRF' ) THEN IF( SNAME ) THEN @@ -618,6 +631,12 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) ELSE NX = 128 END IF + ELSE IF( SUBNAM( 4: 7 ).EQ.'QP3RK' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF END IF ELSE IF( C2.EQ.'SY' ) THEN IF( SNAME .AND. C3.EQ.'TRD' ) THEN From 8e5b70565c5cbaaeb39ce4229fd7165719614068 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 065/106] Removed blank line in the comments of dgeqp3rk.f --- SRC/dgeqp3rk.f | 1 - 1 file changed, 1 deletion(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 0fb5cee3ef..a603708014 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -1022,7 +1022,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * N_SUB = N-J+1 IOFFSET = J-1 -* * CALL DLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, From f1a95eebeb8ccd78d83832575f0c48ed24640cab Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:08 -0800 Subject: [PATCH 066/106] changed comment for LWORK in dgeqp3rk.f for minimum LWORK brackets, cosmetic change --- SRC/dgeqp3rk.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index a603708014..34b36cd156 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -427,7 +427,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. -*. LWORK >= (2*N + (N+NRHS) - 1). +*. LWORK >= (2*N + N+NRHS - 1) *> For optimal performance LWORK >= (2*N + NB*( N+NRHS+1 )), *> where NB is the optimal block size for DGEQP3RK returned *> by ILAENV. Minimal block size MINNB=2. From a020ed05b8a6ac78c26a30712fd8f995f4de4b6f Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 067/106] changed comment in DLAQP2RK in the code section about IF guard for DLARF --- SRC/dlaqp2rk.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index c5ff49c334..8ebdbaa9b9 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -605,7 +605,7 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * * Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. * ( If M >= N, then at KK = N there is no residual matrix, -* i.e. no columns of A to update, only columns of B ) +* i.e. no columns of A to update, only columns of B. * If M < N, then at KK = M-IOFFSET, I = M and we have a * one-row residual matrix in A and the elementary * reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update From b20545c6d4c5149798a6d8399b645b8f63966462 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 068/106] cnanged doxigen comments in \brief for dgeqp3rk.f dlaqp2rk.f dlaqp3rk.f to have real in matrix A and B description --- SRC/dgeqp3rk.f | 2 +- SRC/dlaqp2rk.f | 2 +- SRC/dlaqp3rk.f | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 34b36cd156..a49edfba21 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -1,4 +1,4 @@ -*> \brief \b DGEQP3RK computes a truncated Householder QR factorization with column pivoting of a real m-by-n matrix A by using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**T * B. +*> \brief \b DGEQP3RK computes a truncated Householder QR factorization with column pivoting of a real m-by-n matrix A by using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. * * =========== DOCUMENTATION =========== * diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 8ebdbaa9b9..916e479c9a 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -1,4 +1,4 @@ -*> \brief \b DLAQP2RK computes truncated QR factorization with column pivoting of the matrix block using Level 2 BLAS and overwrites m-by-nrhs matrix B with Q**T * B. +*> \brief \b DLAQP2RK computes truncated QR factorization with column pivoting of a real matrix block using Level 2 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. * * =========== DOCUMENTATION =========== * diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 6aedf22514..944b0ca007 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -1,4 +1,4 @@ -*> \brief \b DLAQP3RK computes a step of truncated QR factorization with column pivoting of a real m-by-n matrix A using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**T * B. +*> \brief \b DLAQP3RK computes a step of truncated QR factorization with column pivoting of a real m-by-n matrix A using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. * * =========== DOCUMENTATION =========== * From 37b19bffed14455ceade89a0600b5b0438ba655d Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 069/106] changed the description of DLAQP3RK to include real --- SRC/dlaqp2rk.f | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 916e479c9a..0a485803bc 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -42,7 +42,8 @@ *> \verbatim *> *> DLAQP2RK computes a truncated (rank K) or full rank Householder QR -*> factorization with column pivoting of the block A(IOFFSET+1:M,1:N) +*> factorization with column pivoting of a real matrix +*> block A(IOFFSET+1:M,1:N) as *> *> A * P(K) = Q(K) * R(K). *> From a39a28f68c9a03777fc63012465a9ec9b2d7e893 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 070/106] changed comments about TAU in dlaqp2rk.f and dlaqp3rk.f --- SRC/dlaqp2rk.f | 6 +++--- SRC/dlaqp3rk.f | 14 +++++++------- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 0a485803bc..cdb7ec3366 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -582,11 +582,11 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * to the column number where NaN is found and return from * the routine. * NOTE: There is no need to check TAU(KK) for Inf, -* since *LARFG cannot produce TAU(KK) or Householder vector +* since DLARFG cannot produce TAU(KK) or Householder vector * below the diagonal containing Inf. Only BETA on the diagonal, -* returned by *LARFG can contain Inf, which requires +* returned by DLARFG can contain Inf, which requires * TAU(KK) to be NaN. Therefore, this case of generating Inf by -* *DLARFG is covered by checking TAU(KK) for NaN. +* DLARFG is covered by checking TAU(KK) for NaN. * IF( DISNAN( TAU(KK) ) ) THEN K = KK - 1 diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 944b0ca007..b64e3cef89 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -593,8 +593,8 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * difficult columns, since we stop the factorization. * * Set TAUs corresponding to the columns that were not -* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) to ZERO, -* which is equivalent to seting TAU(K:MINMNFACT) to ZERO. +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. * DO J = K, MINMNFACT TAU( J ) = ZERO @@ -681,8 +681,8 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * difficult columns, since we stop the factorization. * * Set TAUs corresponding to the columns that were not -* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) to ZERO, -* which is equivalent to seting TAU(K:MINMNFACT) to ZERO. +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. * DO J = K, MINMNFACT TAU( J ) = ZERO @@ -744,11 +744,11 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * to the column number where NaN is found and return from * the routine. * NOTE: There is no need to check TAU(K) for Inf, -* since *LARFG cannot produce TAU(K) or Householder vector +* since DLARFG cannot produce TAU(K) or Householder vector * below the diagonal containing Inf. Only BETA on the diagonal, -* returned by *LARFG can contain Inf, which requires +* returned by DLARFG can contain Inf, which requires * TAU(K) to be NaN. Therefore, this case of generating Inf by -* *DLARFG is covered by checking TAU(K) for NaN. +* DLARFG is covered by checking TAU(K) for NaN. * IF( DISNAN( TAU(K) ) ) THEN * From 8ecf1119ab02702abc27542fecdccb9dbff4afad Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 071/106] changed text aligment for DGEMM and DGEMV function calls in DLAQP3RK --- SRC/dlaqp3rk.f | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index b64e3cef89..88902392e0 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -521,9 +521,9 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, - $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), - $ LDF, ONE, A( IF+1, N+1 ), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) END IF * * There is no need to recompute the 2-norm of the @@ -584,9 +584,9 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, $ " block reflector (M-IF, NRHS, KB)", $ M-IF, NRHS, KB - CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, - $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), - $ LDF, ONE, A( IF+1, N+1 ), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) END IF * * There is no need to recompute the 2-norm of the @@ -671,10 +671,9 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, $ " block reflector (M-IF, N+NRHS-KB, KB)", $ M-IF, N+NRHS-KB, KB - CALL DGEMM( 'No transpose', 'Transpose', M-IF, - $ N+NRHS-KB, KB,-ONE, A( IF+1, 1 ), LDA, - $ F( KB+1, 1 ), LDF, ONE, - $ A( IF+1, KB+1 ), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', + $ M-IF, N+NRHS-KB, KB,-ONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA ) END IF * * There is no need to recompute the 2-norm of the @@ -785,9 +784,9 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. * IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M-IF, NRHS, - $ KB, -ONE, A( IF+1, 1 ), LDA, F( N+1, 1 ), - $ LDF, ONE, A( IF+1, N+1 ), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) END IF * * There is no need to recompute the 2-norm of the @@ -812,9 +811,9 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K). * IF( K.LT.N+NRHS ) THEN - CALL DGEMV( 'Transpose', M-I+1, N+NRHS-K, TAU( K ), - $ A( I, K+1 ), LDA, A( I, K ), 1, ZERO, - $ F( K+1, K ), 1 ) + CALL DGEMV( 'Transpose', M-I+1, N+NRHS-K, + $ TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1, + $ ZERO, F( K+1, K ), 1 ) END IF * * 2) Zero out elements above and on the diagonal of the @@ -829,8 +828,9 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * * A(I:M,K). * IF( K.GT.1 ) THEN - CALL DGEMV( 'Transpose', M-I+1, K-1, -TAU( K ), A( I, 1 ), - $ LDA, A( I, K ), 1, ZERO, AUXV( 1 ), 1 ) + CALL DGEMV( 'Transpose', M-I+1, K-1, -TAU( K ), + $ A( I, 1 ), LDA, A( I, K ), 1, ZERO, + $ AUXV( 1 ), 1 ) * CALL DGEMV( 'No transpose', N+NRHS, K-1, ONE, $ F( 1, 1 ), LDF, AUXV( 1 ), 1, ONE, @@ -911,9 +911,9 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. * IF( KB.LT.MINMNUPDT ) THEN - CALL DGEMM( 'No transpose', 'Transpose', M-IF, N+NRHS-KB, KB, - $ -ONE, A( IF+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE, - $ A( IF+1, KB+1 ), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', + $ M-IF, N+NRHS-KB, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA ) END IF * * Recompute the 2-norm of the difficult columns. From 2c939526a57539cd0cc2255cb3422de64c98767e Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 072/106] changed comments about checking TAU for NaN in dlaqp2rk.f and dlaqp3rk.f and changed aligment of IMPLICIT NONE in the description of DGEQP3RK in dgeqp3rk.f --- SRC/dgeqp3rk.f | 2 +- SRC/dlaqp2rk.f | 6 +++--- SRC/dlaqp3rk.f | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index a49edfba21..7958701385 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -21,7 +21,7 @@ * SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, * $ WORK, LWORK, IWORK, INFO ) -* IMPLICIT NONE +* IMPLICIT NONE * * .. Scalar Arguments .. * INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index cdb7ec3366..2408cb259d 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -578,15 +578,15 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, WRITE(*,*) "## DLAQP2RK (K, TAU(Kk) )=", KK, TAU(KK) * -* Check if TAU(KK) is NaN, set INFO parameter +* Check if TAU(KK) contains NaN, set INFO parameter * to the column number where NaN is found and return from * the routine. * NOTE: There is no need to check TAU(KK) for Inf, * since DLARFG cannot produce TAU(KK) or Householder vector * below the diagonal containing Inf. Only BETA on the diagonal, * returned by DLARFG can contain Inf, which requires -* TAU(KK) to be NaN. Therefore, this case of generating Inf by -* DLARFG is covered by checking TAU(KK) for NaN. +* TAU(KK) to contain NaN. Therefore, this case of generating Inf +* by DLARFG is covered by checking TAU(KK) for NaN. * IF( DISNAN( TAU(KK) ) ) THEN K = KK - 1 diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 88902392e0..bd919fba49 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -739,15 +739,15 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, TAU( K ) = ZERO END IF * -* Check if TAU(K) is NaN, set INFO parameter +* Check if TAU(K) contains NaN, set INFO parameter * to the column number where NaN is found and return from * the routine. * NOTE: There is no need to check TAU(K) for Inf, * since DLARFG cannot produce TAU(K) or Householder vector * below the diagonal containing Inf. Only BETA on the diagonal, * returned by DLARFG can contain Inf, which requires -* TAU(K) to be NaN. Therefore, this case of generating Inf by -* DLARFG is covered by checking TAU(K) for NaN. +* TAU(K) to contain NaN. Therefore, this case of generating Inf +* by DLARFG is covered by checking TAU(K) for NaN. * IF( DISNAN( TAU(K) ) ) THEN * From 86cf7053085256096dbd643aa33c2553ebfbbf15 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 073/106] Updated description of the INFO about NaN detection in DGEQP3RK, DLAQP3RK, DLAQP2RK --- SRC/dgeqp3rk.f | 22 ++++++++++------------ SRC/dlaqp2rk.f | 18 ++++++++---------- SRC/dlaqp3rk.f | 18 ++++++++---------- 3 files changed, 26 insertions(+), 32 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 7958701385..0965116e66 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -460,8 +460,8 @@ *> 1) INFO = 0: successful exit. *> 2) INFO < 0: if INFO = -i, the i-th argument had an *> illegal value. -*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN element -*> was detected and the routine stops the computation. +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. *> The j_1-th column of the matrix A or the j_1-th *> element of array TAU contains the first occurrence *> of NaN in the factorization step K+1 ( when K columns @@ -474,16 +474,14 @@ *> MAXC2NRMK is set to NaN. *> RELMAXC2NRMK is set to NaN. *> TAU(K+1:min(M,N)) is not set and contains undefined -*> elements. If j_1=K+1, TAU(K+1) may -*> contain NaN. -*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then -*> no NaN element was detected, but +Inf (or -Inf) -*> was detected and the routine continues -*> the computation until completion. -*> The (j_2-N)-th column of the matrix A contains the -*> first occurrence of +Inf (or -Inf) in the -*> factorization step K+1 ( when K columns have been -*> factorized ). +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). *> \endverbatim * * Authors: diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 2408cb259d..5444f5af0e 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -261,8 +261,8 @@ *> \verbatim *> INFO is INTEGER *> 1) INFO = 0: successful exit. -*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN element -*> was detected and the routine stops the computation. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. *> The j_1-th column of the matrix A or the j_1-th *> element of array TAU contains the first occurrence *> of NaN in the factorization step K+1 ( when K columns @@ -277,14 +277,12 @@ *> TAU(K+1:min(M,N)) is not set and contains undefined *> elements. If j_1=K+1, TAU(K+1) *> may contain NaN. -*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then -*> no NaN element was detected, but +Inf (or -Inf) -*> was detected and the routine continues -*> the computation until completion. -*> The (j_2-N)-th column of the matrix A contains the -*> first occurrence of +Inf (or -Inf) in the -*> factorization step K+1 ( when K columns have been -*> factorized ). +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). *> \endverbatim * * Authors: diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index bd919fba49..99024f58ec 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -319,8 +319,8 @@ *> \verbatim *> INFO is INTEGER *> 1) INFO = 0: successful exit. -*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN element -*> was detected and the routine stops the computation. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. *> The j_1-th column of the matrix A or the j_1-th *> element of array TAU contains the first occurrence *> of NaN in the factorization step KB+1 ( when KB columns @@ -335,14 +335,12 @@ *> TAU(KB+1:min(M,N)) is not set and contains undefined *> elements. If j_1=KB+1, TAU(KB+1) *> may contain NaN. -*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then -*> no NaN element was detected, but +Inf (or -Inf) -*> was detected and the routine continues -*> the computation until completion. -*> The (j_2-N)-th column of the matrix A contains the -*> first occurrence of +Inf (or -Inf) in the -*> factorization step KB+1 ( when KB columns have been -*> factorized ). +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the actorization +*> step KB+1 ( when KB columns have been factorized ). *> \endverbatim * * Authors: From f1bbf6c1c38c452746d69b18946ae529ec3db31d Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 074/106] fixed comments of function signature description in TESTING/LIN/dchkqp3rk.f --- TESTING/LIN/dchkqp3rk.f | 36 ++++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index 008faf2ca4..85ed2d8b55 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -8,22 +8,26 @@ * Definition: * =========== * -* ===================================================================== -* SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, -* $ NXVAL, THRESH, A, COPYA, S, TAU, WORK, -* $ IWORK, NOUT ) -* IMPLICIT NONE -* .. Scalar Arguments .. -* INTEGER NM, NN, NNB, NOUT -* DOUBLE PRECISION THRESH -* .. -* .. Array Arguments .. -* LOGICAL DOTYPE( * ) -* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), -* $ NXVAL( * ) -* DOUBLE PRECISION A( * ), COPYA( * ), S( * ), -* $ TAU( * ), WORK( * ) -* .. +* SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, +* $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, +* $ B, COPYB, S, TAU, 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 .. +* INTEGER NM, NN, NNS, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), +* $ NVAL( * ), NXVAL( * ) +* DOUBLE PRECISION A( * ), COPYA( * ), B( * ), COPYB( * ), +* $ S( * ), TAU( * ), WORK( * ) +* .. * * *> \par Purpose: From 93b5bc325e1f7e10ba0a3d7eff8322efc5880c41 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 075/106] changed comments in dlatb4.f --- TESTING/LIN/dlatb4.f | 30 ------------------------------ 1 file changed, 30 deletions(-) diff --git a/TESTING/LIN/dlatb4.f b/TESTING/LIN/dlatb4.f index 8bd285ebbb..a3c3e090f1 100755 --- a/TESTING/LIN/dlatb4.f +++ b/TESTING/LIN/dlatb4.f @@ -327,36 +327,6 @@ SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, END IF * END IF -* -* Set the condition number. -* -* IF ( IMAT.EQ.6 ) THEN -* CNDNUM = BADC1 -* ELSE IF ( IMAT.EQ.7 ) THEN -* CNDNUM = BADC2 -* ELSE IF ( IMAT.EQ.8 ) THEN -* CNDNUM = BADC2 -* ELSE -* CNDNUM = TWO -* END IF -* -* Set norm -* -* IF( IMAT.EQ.9 ) THEN -* ANORM = SMALL8 -* ELSE IF( IMAT.EQ.10 ) THEN -* ANORM = LARGE -* ELSE -* ANORM = ONE -* END IF -* -* Set MODE -* -* IF( IMAT.EQ.8 ) THEN -* MODE = 2 -* ELSE -* MODE = 3 -* END IF * ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN * From 59fc007bc24a90bf11405235b3800e8fd9648697 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 076/106] simplified the formula in the descriotion from LWORK >= (2*N + N+NRHS - 1) to LWORK >= (3*N + NRHS - 1) --- SRC/dgeqp3rk.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 0965116e66..fd1a6060e0 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -427,7 +427,7 @@ *> \verbatim *> LWORK is INTEGER *> The dimension of the array WORK. -*. LWORK >= (2*N + N+NRHS - 1) +*. LWORK >= (3*N + NRHS - 1) *> For optimal performance LWORK >= (2*N + NB*( N+NRHS+1 )), *> where NB is the optimal block size for DGEQP3RK returned *> by ILAENV. Minimal block size MINNB=2. From 8e888aaa61ff906f107e721ecc1e40a43e1068f3 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 077/106] changed comments in dlatb4.f and changed text allignment for function calls in dchkqp3rk.f --- TESTING/LIN/dchkqp3rk.f | 63 +++++++++++++++++++++-------------------- TESTING/LIN/dlatb4.f | 3 +- 2 files changed, 35 insertions(+), 31 deletions(-) diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index 85ed2d8b55..24bf9f713f 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -10,7 +10,8 @@ * * SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, -* $ B, COPYB, S, TAU, WORK, IWORK, NOUT ) +* $ B, COPYB, S, TAU, +* $ WORK, IWORK, NOUT ) * IMPLICIT NONE * * -- LAPACK test routine -- @@ -178,7 +179,8 @@ * ===================================================================== SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, - $ B, COPYB, S, TAU, WORK, IWORK, NOUT ) + $ B, COPYB, S, TAU, + $ WORK, IWORK, NOUT ) IMPLICIT NONE * * -- LAPACK test routine -- @@ -186,13 +188,13 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. - INTEGER NM, NN, NNS, NNB, NOUT + INTEGER NM, NN, NNB, NNS, NOUT DOUBLE PRECISION THRESH * .. * .. Array Arguments .. LOGICAL DOTYPE( * ) - INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), - $ NVAL( * ), NXVAL( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NSVAL( * ), NXVAL( * ) DOUBLE PRECISION A( * ), COPYA( * ), B( * ), COPYB( * ), $ S( * ), TAU( * ), WORK( * ) * .. @@ -215,12 +217,12 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ INB, IND_OFFSET_GEN, $ IND_IN, IND_OUT, INS, INFO, $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO, K, - $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, M, - $ MINMN, MINMNB_GEN, MODE, N, NB, NB_ZERO, - $ NERRS, NFAIL, NB_GEN, NRHS, NRUN, NX, SHIFT, - $ T + $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, + $ LWORK_DORMQR, M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, + $ NRUN, NX, SHIFT, T DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, - $ MAXC2NRMK, RELMAXC2NRMK, DTEMP, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK, $ TEST1, TEST2 * .. * .. Local Arrays .. @@ -233,10 +235,9 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12, DLANGE * .. * .. External Subroutines .. - EXTERNAL ALAERH, ALAHD, ALASUM, DGEQP3RK, DLACPY, - $ DAXPY, DSWAP, - $ DORMQR, DLAORD, DLASET, DLATB4, DLATMS, - $ ICOPY, XLAENV + EXTERNAL ALAERH, ALAHD, ALASUM, DAXPY, DGEQP3RK, + $ DLACPY, DLAORD, DLASET, DLATB4, DLATMS, + $ DORMQR, DSWAP, ICOPY, XLAENV * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, MOD @@ -244,7 +245,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * .. Scalars in Common .. LOGICAL LERR, OK CHARACTER*32 SRNAMT - INTEGER INFOT, IOUNIT, DORMQR_LWORK + INTEGER INFOT, IOUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, IOUNIT, OK, LERR @@ -755,14 +756,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, CALL DLACPY( 'All', M, NRHS, COPYB, LDA, $ B, LDA ) CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) -* -* -* Compute the QR factorization with pivoting of A -* - LW = MAX( 1, MAX( 2*N+NB*( N+1 ) , 3*N+NRHS-1 ) ) -* -* Compute DGEQP3RK factorization of A. -* ABSTOL = -1.0 RELTOL = -1.0 @@ -888,14 +881,24 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ IWORK(5), IWORK(6), IWORK(7), IWORK(8) WRITE(*,*) " " + + + +* +* +* Compute the QR factorization with pivoting of A +* + LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ), + $ 3*N + NRHS - 1 ) ) +* +* Compute DGEQP3RK factorization of A. +* SRNAMT = 'DGEQP3RK' CALL DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, $ A, LDA, KFACT, MAXC2NRMK, $ RELMAXC2NRMK, IWORK( N+1 ), TAU, $ WORK, LW, IWORK( 2*N+1 ), INFO ) - - - * +* * WRITE(*,*) "A after DGEQP3RK" DO I = 1, LDA @@ -1078,10 +1081,10 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * $ ,B((11-1)*LDA+I), B((12-1)*LDA+I) END DO * - DORMQR_LWORK = MAX(1, NRHS) + LWORK_DORMQR = MAX(1, NRHS) CALL DORMQR( 'Left', 'Transpose', M, NRHS, KFACT, $ A, LDA, TAU, B, LDA, WORK, - $ DORMQR_LWORK, INFO ) + $ LWORK_DORMQR, INFO ) * * WRITE(*,*) @@ -1180,8 +1183,8 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) * 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, ', NRHS =', I5, - $ ', KMAX =', I5, ', ABSTOL =', G12.5, ', RELTOL =', G12.5, - $ ', NB =', I4, ', NX =', I4, + $ ', KMAX =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) * * End of DCHKQP3RK diff --git a/TESTING/LIN/dlatb4.f b/TESTING/LIN/dlatb4.f index a3c3e090f1..f3bccd45b2 100755 --- a/TESTING/LIN/dlatb4.f +++ b/TESTING/LIN/dlatb4.f @@ -227,7 +227,8 @@ SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, * ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN * -* xQK: Set parameters to generate a general +* xQK: truncated QR with pivoting. +* Set parameters to generate a general * M x N matrix. * * Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. From 35634f322c0708907e101ced8b91d6b6bff101a7 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 078/106] changed the matrix IMAT in DCHKQP3RK to call DLATB4 to 14 --- TESTING/LIN/dchkqp3rk.f | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index 24bf9f713f..312652a2a5 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -307,9 +307,11 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * * Set up parameters with DLATB4 and generate * M-by-NRHS B matrix with DLATMS. -* IMAT=6: Random, geometric distribution, CNDNUM = 2 +* IMAT = 14: +* Random matrix, CNDNUM = 2, NORM = ONE, +* MODE = 3 (geometric distribution of singular values). * - CALL DLATB4( PATH, 6, M, NRHS, TYPE, KL, KU, ANORM, + CALL DLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM, $ MODE, CNDNUM, DIST ) * SRNAMT = 'DLATMS' @@ -339,16 +341,18 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * DO IMAT = 1, NTYPES - WRITE(*,*) "(4) ____ ____ ____ ____ Loop for ", - $ "IMAT, DOTYPE(IMAT)= ", IMAT, DOTYPE(IMAT) - - $ * * Do the tests only if DOTYPE( IMAT ) is true. * IF( .NOT.DOTYPE( IMAT ) ) $ CYCLE + WRITE(*,*) "(4) ____ ____ ____ ____ Loop for ", + $ "IMAT, DOTYPE(IMAT)= ", IMAT, DOTYPE(IMAT) + + $ + + * * The type of distribution used to generate the random * eigen-/singular values: From 6abbd2b64deb086c904dd1bffbf56f03da0e4e58 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 079/106] merged if MINMN contition with matrix types conditon for matrixces with ZEROes generation in DCHKQP3RK --- TESTING/LIN/dchkqp3rk.f | 52 +++++++++++------------------------------ 1 file changed, 13 insertions(+), 39 deletions(-) diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index 312652a2a5..67c1bd6245 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -340,14 +340,14 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, END DO * - DO IMAT = 1, NTYPES + DO IMAT = 1, NTYPES * * Do the tests only if DOTYPE( IMAT ) is true. * IF( .NOT.DOTYPE( IMAT ) ) $ CYCLE - WRITE(*,*) "(4) ____ ____ ____ ____ Loop for ", + WRITE(*,*) "(4) ____ ____ ____ ____ Loop for ", $ "IMAT, DOTYPE(IMAT)= ", IMAT, DOTYPE(IMAT) $ @@ -419,11 +419,11 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * CALL DLAORD( 'Decreasing', MINMN, S, 1 ) * - ELSE IF( IMAT.GE.5 .AND. IMAT.LE.13 ) THEN + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN * -* Rectangular matrices 5-13 that contain zero columns. -* - IF( MINMN.GE.2 ) THEN +* Rectangular matrices 5-13 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. @@ -434,9 +434,9 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * J_FIRS_NZ is the index of the first non-zero * column. * - IF( IMAT.EQ.5 ) THEN + IF( IMAT.EQ.5 ) THEN * -* First column is zero. +* First column is zero. * JB_ZERO = 1 NB_ZERO = 1 @@ -517,7 +517,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) * to zero. - WRITE(*,*) "( M,NB_ZERO, LDA before DLASET", + WRITE(*,*) "( M,NB_ZERO, LDA before DLASET", $ M, NB_ZERO, LDA * CALL DLASET( 'Full', M, NB_ZERO, ZERO, ZERO, @@ -542,7 +542,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ COPYA( IND_OFFSET_GEN + 1 ), LDA, $ WORK, INFO ) - WRITE(*,*) "Singular values after mat generation S=" + WRITE(*,*) "Singular val after mat generation S=" WRITE(*,*) $ S(1), S(2), S(3), S(4), $ S(5), S(6), S(7), S(8) @@ -588,22 +588,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, $ COPYA( (J-1)*LDA + 1 ), 1 ) END DO - - IF(.FALSE.) THEN -* -* (Part 2) -* Swap the generated columns from the right -* NB_GEN-size block from -* (NB_ZERO+JB_ZERO:NB_ZERO+NB_GEN) -* into columns (1:JB_ZERO-1). -* - DO J = JB_ZERO, NB_GEN, 1 - CALL DSWAP( M, - $ COPYA( (NB_ZERO+J-1)*LDA + 1 ), 1, - $ COPYA( (JB_ZERO+J-1)*LDA + 1 ), 1 ) - END DO - - END IF * ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN * @@ -668,17 +652,13 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ S(1), S(2), S(3), S(4), $ S(5), S(6), S(7), S(8) * - ELSE + ELSE * * IF(MINMN.LT.2) skip this size for this matrix type. * CYCLE - END IF -* END IF * - - WRITE(*,*) "AFTER GENERATING COPYA" DO I = 1, M WRITE(*,*) @@ -713,17 +693,11 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ NB, NX * -* We do MAX(M,N) because we need a test for KMAX > N, +* 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 KMAX = 1, (MIN(M,N) + 1 -* -** DO KMAX = 1, MIN(M,N) -** DO KMAX = 4, 4 -** DO KMAX = 3, 3 - - DO KMAX = 0, min(M,N) + DO KMAX = 0, min(M,N)+1 From 231dd99d0c3a1b3e7e86050a723bd89b5df4eecd Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 080/106] changed alligment of if statements in generation matrices with zeros in TESTINg/LIN/dchkqp3rk.f --- TESTING/LIN/dchkqp3rk.f | 234 ++++++++++++++++++++-------------------- 1 file changed, 117 insertions(+), 117 deletions(-) diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index 67c1bd6245..45cd55ee65 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -425,136 +425,136 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * Rectangular matrices 5-13 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 -* for matrix 12 and 13. -* J_FIRS_NZ is the index of the first non-zero -* column. +* 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 +* for matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column. * IF( IMAT.EQ.5 ) THEN * * First column is zero. * - JB_ZERO = 1 - NB_ZERO = 1 - NB_GEN = N - NB_ZERO + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO * - ELSE IF( IMAT.EQ.6 ) THEN + ELSE IF( IMAT.EQ.6 ) THEN * -* Last column MINMN is zero. +* Last column MINMN is zero. * - JB_ZERO = MINMN - NB_ZERO = 1 - NB_GEN = N - NB_ZERO + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO * - ELSE IF( IMAT.EQ.7 ) THEN + ELSE IF( IMAT.EQ.7 ) THEN * -* Last column N is zero. +* Last column N is zero. * - JB_ZERO = N - NB_ZERO = 1 - NB_GEN = N - NB_ZERO + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO * - ELSE IF( IMAT.EQ.8 ) THEN + ELSE IF( IMAT.EQ.8 ) THEN * -* Middle column in MINMN is zero. +* Middle column in MINMN is zero. * - JB_ZERO = MINMN / 2 + 1 - NB_ZERO = 1 - NB_GEN = N - NB_ZERO + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO * - ELSE IF( IMAT.EQ.9 ) THEN + ELSE IF( IMAT.EQ.9 ) THEN * -* First half of MINMN columns is zero. +* First half of MINMN columns is zero. * - JB_ZERO = 1 - NB_ZERO = MINMN / 2 - NB_GEN = N - NB_ZERO + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO * - ELSE IF( IMAT.EQ.10 ) THEN + ELSE IF( IMAT.EQ.10 ) THEN * -* Last columns are zero columns, -* starting from (MINMN / 2 + 1) column. +* Last columns are zero columns, +* starting from (MINMN / 2 + 1) column. * - JB_ZERO = MINMN / 2 + 1 - NB_ZERO = N - JB_ZERO + 1 - NB_GEN = N - NB_ZERO + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - JB_ZERO + 1 + NB_GEN = N - NB_ZERO * - ELSE IF( IMAT.EQ.11 ) THEN + ELSE IF( IMAT.EQ.11 ) THEN * -* Half of the columns in the middle of MINMN -* columns is zero, starting from -* MINMN/2 - (MINMN/2)/2 + 1 column. +* Half of the columns in the middle of MINMN +* columns is zero, starting from +* MINMN/2 - (MINMN/2)/2 + 1 column. * - JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 - NB_ZERO = MINMN / 2 - NB_GEN = N - NB_ZERO + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO * - ELSE IF( IMAT.EQ.12 ) THEN + ELSE IF( IMAT.EQ.12 ) THEN * -* Odd-numbered columns are zero, +* Odd-numbered columns are zero, * - NB_GEN = N / 2 - NB_ZERO = N - NB_GEN - J_INC = 2 - J_FIRST_NZ = 2 + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 * - ELSE IF( IMAT.EQ.13 ) THEN + ELSE IF( IMAT.EQ.13 ) THEN * -* Even-numbered columns are zero. +* Even-numbered columns are zero. * - NB_ZERO = N / 2 - NB_GEN = N - NB_ZERO - J_INC = 2 - J_FIRST_NZ = 1 + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 * - END IF + END IF * * -* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) -* to zero. +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. WRITE(*,*) "( M,NB_ZERO, LDA before DLASET", $ M, NB_ZERO, LDA * - CALL DLASET( 'Full', M, NB_ZERO, ZERO, ZERO, - $ COPYA, LDA ) + 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 ) + CALL DLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) * - SRNAMT = 'DLATMS' + SRNAMT = 'DLATMS' WRITE(*,*) "Generate DLAMTS matrix (M,NB_GEN)=", $ M, NB_GEN - IND_OFFSET_GEN = NB_ZERO * LDA + 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 ) + CALL DLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) WRITE(*,*) "Singular val after mat generation S=" WRITE(*,*) $ S(1), S(2), S(3), S(4), $ S(5), S(6), S(7), S(8) * -* Check error code from DLATMS. +* 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 + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF WRITE(*,*) "Matrix COPYA after", $ " generation N_ZERO and N_GEN" @@ -568,56 +568,56 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * -* 3) Swap the gererated colums from the right side -* NB_GEN-size block in COPYA into correct column -* positions. +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. * - IF( IMAT.EQ.6 + 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). +* 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 + 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 + 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 = 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. +* ( 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 + 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 ) + CALL DSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN), 1 ) END DO * - END IF + END IF * -* 5) Order the singular values generated by -* DLAMTS in decreasing order and add trailing zeros -* that correspond to zero columns. -* The total number of singular values is MINMN. +* 5) Order the singular values generated by +* DLAMTS in decreasing order and add trailing zeros +* that correspond to zero columns. +* The total number of singular values is MINMN. * - MINMNB_GEN = MIN( M, NB_GEN ) + MINMNB_GEN = MIN( M, NB_GEN ) WRITE(*,*) "Singular values MINB_GEN=", MINMNB_GEN WRITE(*,*) "Singular values before ordering S=" @@ -625,17 +625,17 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ S(1), S(2), S(3), S(4), $ S(5), S(6), S(7), S(8) * - CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) + CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) WRITE(*,*) "Singular values after ordering S=" WRITE(*,*) $ S(1), S(2), S(3), S(4), $ S(5), S(6), S(7), S(8) - DO I = MINMNB_GEN+1, MINMN + DO I = MINMNB_GEN+1, MINMN WRITE(*,*) "Singular values to ZERO out I=", I - S( I ) = ZERO - END DO + S( I ) = ZERO + END DO WRITE(*,*) "Matrix with ZERO columnms COPYA" DO I = 1, M @@ -701,8 +701,8 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, - WRITE(*,*) "(6) ____ ____ ____ ____ ____ ____ Loop for KMAX=", - $ KMAX + WRITE(*,*) "(6) ____ ____ ____ ____ ____" , + $ " ____ Loop for KMAX=", KMAX * * Get a working copy of COPYA into A( 1:M,1:N ). * Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). @@ -714,7 +714,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) - WRITE(*,*) " ____ ____ ____ ____ ____ ____ set NaN", + WRITE(*,*) " ____ ____ ____ ____ ____ ____ set NaN", $ " in mat A after copy" From 1309b6c5cc4e49e0f8c6752b7a0391a21020afc4 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 081/106] fixed an DLARFG index bug in dlaqp2rk.f and inserted debug statement in dlaqp3rk.f --- SRC/dlaqp2rk.f | 8 ++++++-- SRC/dlaqp3rk.f | 6 ++++++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 5444f5af0e..0ca1aed9e5 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -389,6 +389,10 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, KMAX = MIN( KMAX, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) HUGEVAL = DLAMCH( 'Overflow' ) + + WRITE(*,*) "####_#### Enter DLAQP2RK " + WRITE(*,*) " (M, N, NRHS, IOFFSET, KMAX, KP1, MAXC2NRM)", + $ M, N, NRHS, IOFFSET, KMAX, KP1, MAXC2NRM * * Compute the factorization, KK is the lomn loop index. * @@ -567,14 +571,14 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * the elementary reflector would be an identity matrix, * and TAU(KK) = ZERO. * - IF( KK.LT.M ) THEN + IF( I.LT.M ) THEN CALL DLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, $ TAU( KK ) ) ELSE TAU( KK ) = ZERO END IF - WRITE(*,*) "## DLAQP2RK (K, TAU(Kk) )=", KK, TAU(KK) + WRITE(*,*) "## DLAQP2RK (KK, TAU(Kk) )=", KK, TAU(KK) * * Check if TAU(KK) contains NaN, set INFO parameter * to the column number where NaN is found and return from diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 99024f58ec..69706eed6b 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -444,6 +444,12 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, NB = MIN( NB, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) HUGEVAL = DLAMCH( 'Overflow' ) + + WRITE(*,*) "$$$$_$$$$ Enter DLAQP3RK " + WRITE(*,*) " (M, N, NRHS, IOFFSET, NB, KP1, MAXC2NRM)", + $ M, N, NRHS, IOFFSET, NB, KP1, MAXC2NRM + + * * Compute factorization in a while loop over NB columns, * K is the column index in the block A(1:M,1:N). From 667f08c385b7656ce4bdd300580ce1db3fc512b4 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 082/106] corrected comment in update the i-th row of A in DLAQP3RK --- SRC/dlaqp3rk.f | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 69706eed6b..4329a14500 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -844,7 +844,8 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * =============================================================== * * Update the current I-th row of A: -* A(I,K+1:N) := A(I,K+1:N) - A(I,1:K)*F(K+1:N,1:K)**T. +* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) +* - A(I,1:K)*F(K+1:N+NRHS,1:K)**T. * IF( K.LT.N+NRHS ) THEN CALL DGEMV( 'No transpose', N+NRHS-K, K, -ONE, From c3eaab30c6f3de3229decfd9bb9feea98a864c59 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:09 -0800 Subject: [PATCH 083/106] corrected comments in TESTING/LIN/dchkqp3rk.f for KMAX loop --- TESTING/LIN/dchkqp3rk.f | 47 ++++++++++++++++++++--------------------- 1 file changed, 23 insertions(+), 24 deletions(-) diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index 45cd55ee65..7f1e687172 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -216,11 +216,11 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, 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, + $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO, $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, $ LWORK_DORMQR, M, MINMN, MINMNB_GEN, MODE, N, $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, - $ NRUN, NX, SHIFT, T + $ NRUN, NX, T DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, $ DTEMP, MAXC2NRMK, RELMAXC2NRMK, $ TEST1, TEST2 @@ -681,7 +681,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * DO INB = 1, NNB * -* * Do for each pair of values (NB,NX) in NBVAL and NXVAL. * NB = NBVAL( INB ) @@ -694,10 +693,10 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * * 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) +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) * - DO KMAX = 0, min(M,N)+1 + DO KMAX = 0, MIN(M,N)+1 @@ -707,7 +706,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * Get a working copy of COPYA into A( 1:M,1:N ). * Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). * Get a working copy of COPYB into into B( 1:M, 1:NRHS ). -* Get a working copy of IWORK(1:N) into +* Get a working copy of IWORK(1:N) awith zeroes into * which is going to be used as pivot array IWORK( N+1:2N ). * NOTE: IWORK(2N+1:3N) is going to be used as a WORK array * for the routine. @@ -734,7 +733,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, CALL DLACPY( 'All', M, NRHS, COPYB, LDA, $ B, LDA ) CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) - +* ABSTOL = -1.0 RELTOL = -1.0 @@ -892,17 +891,17 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, WRITE(*,*) $ TAU(1), TAU(2), TAU(3), TAU(4), $ TAU(5), TAU(6), TAU(7), TAU(8) - WRITE(*,*) " " + WRITE(*,*) WRITE(*,*) "JPIV after DGEQP3RK" WRITE(*,*) $ IWORK(N+1), IWORK(N+2), IWORK(N+3), IWORK(N+4), $ IWORK(N+5), IWORK(N+6), IWORK(N+7), IWORK(N+8) - WRITE(*,*) " " + WRITE(*,*) WRITE(*,*) "INFO after DGEQP3RK" WRITE(*,*) INFO - WRITE(*,*) " " + WRITE(*,*) * * Check error code from DGEQP3RK. * @@ -944,6 +943,9 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, END IF END DO NRUN = NRUN + 1 +* +* End test 1 +* END IF * * @@ -1044,7 +1046,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * * (1) Compute B:=Q**T * B in the matrix B. * - IF( MIN(M,N).GT.0 ) THEN + IF( MINMN.GT.0 ) THEN * WRITE(*,*) @@ -1059,11 +1061,10 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * $ ,B((11-1)*LDA+I), B((12-1)*LDA+I) END DO * - LWORK_DORMQR = MAX(1, NRHS) - CALL DORMQR( 'Left', 'Transpose', M, NRHS, KFACT, - $ A, LDA, TAU, B, LDA, WORK, - $ LWORK_DORMQR, INFO ) -* + LWORK_DORMQR = MAX(1, NRHS) + CALL DORMQR( 'Left', 'Transpose', + $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, + $ WORK, LWORK_DORMQR, INFO ) * WRITE(*,*) WRITE(*,*) "TEST 5: B after computing Q**T * B" @@ -1081,12 +1082,10 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, DO I = 1, NRHS * -* Compare N+J-th column of A and J-column of B. +* Compare N+J-th column of A and J-column of B. * - CALL DAXPY( M, -ONE, A( ( N+I-1 )*LDA+1 ), 1, - $ B( ( I-1 )*LDA+1 ), 1 ) - - + CALL DAXPY( M, -ONE, A( ( N+I-1 )*LDA+1 ), 1, + $ B( ( I-1 )*LDA+1 ), 1 ) END DO * WRITE(*,*) @@ -1104,7 +1103,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * RESULT( 5 ) = $ ABS( - $ DLANGE( 'One-norm', M, NRHS, B, M, RDUMMY ) / + $ DLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) / $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) $ ) @@ -1132,7 +1131,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * END IF * -* END DO KMAX = 1, MAX(M,N) +* END DO KMAX = 1, MIN(M,N)+1 * END DO * From c037c322b718229968752e36294c3dec94d29e5f Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 084/106] added SRC/zgeqp3rk.f SRC/zlaqp2rk.f SRC/zlaqp2rk.f and changed Makefile and CMakeLists.txt accordingly --- SRC/CMakeLists.txt | 5 +- SRC/Makefile | 5 +- SRC/zgeqp3rk.f | 1128 ++++++++++++++++++++++++++++++++++++++++++++ SRC/zlaqp2rk.f | 750 +++++++++++++++++++++++++++++ SRC/zlaqp3rk.f | 1008 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 2892 insertions(+), 4 deletions(-) create mode 100755 SRC/zgeqp3rk.f create mode 100755 SRC/zlaqp2rk.f create mode 100755 SRC/zlaqp3rk.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index f047dc4471..69195463f5 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -375,7 +375,8 @@ set(ZLASRC zgbtf2.f zgbtrf.f zgbtrs.f zgebak.f zgebal.f zgebd2.f zgebrd.f zgecon.f zgeequ.f zgees.f zgeesx.f zgeev.f zgeevx.f zgehd2.f zgehrd.f zgelq2.f zgelqf.f - zgels.f zgelst.f zgelsd.f zgelss.f zgelsy.f zgeql2.f zgeqlf.f zgeqp3.f + zgels.f zgelst.f zgelsd.f zgelss.f zgelsy.f zgeql2.f zgeqlf.f + zgeqp3.f zgeqp3rk.f zgeqr2.f zgeqr2p.f zgeqrf.f zgeqrfp.f zgerfs.f zgerq2.f zgerqf.f zgesc2.f zgesdd.f zgesv.f zgesvd.f zgesvdx.f zgesvx.f zgesvj.f zgejsv.f zgsvj0.f zgsvj1.f @@ -412,7 +413,7 @@ set(ZLASRC zlanhe.f zlanhp.f zlanhs.f zlanht.f zlansb.f zlansp.f zlansy.f zlantb.f zlantp.f zlantr.f zlapll.f zlapmt.f zlaqgb.f zlaqge.f - zlaqhb.f zlaqhe.f zlaqhp.f zlaqp2.f zlaqps.f zlaqsb.f + zlaqhb.f zlaqhe.f zlaqhp.f zlaqp2.f zlaqps.f zlaqp2rk.f zlaqp3rk.f zlaqsb.f zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f zlaqr4.f zlaqr5.f zlaqsp.f zlaqsy.f zlar1v.f zlar2v.f ilazlr.f ilazlc.f zlarcm.f zlarf.f zlarfb.f zlarfb_gett.f diff --git a/SRC/Makefile b/SRC/Makefile index 33cec713e4..a98a98f6e2 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -412,7 +412,8 @@ ZLASRC = \ zgbtf2.o zgbtrf.o zgbtrs.o zgebak.o zgebal.o zgebd2.o zgebrd.o \ zgecon.o zgeequ.o zgees.o zgeesx.o zgeev.o zgeevx.o \ zgehd2.o zgehrd.o zgelq2.o zgelqf.o \ - zgels.o zgelst.o zgelsd.o zgelss.o zgelsy.o zgeql2.o zgeqlf.o zgeqp3.o \ + zgels.o zgelst.o zgelsd.o zgelss.o zgelsy.o zgeql2.o zgeqlf.o \ + zgeqp3.o zgeqp3rk.o \ zgeqr2.o zgeqr2p.o zgeqrf.o zgeqrfp.o zgerfs.o zgerq2.o zgerqf.o \ zgesc2.o zgesdd.o zgesv.o zgesvd.o zgesvdx.o \ zgesvj.o zgejsv.o zgsvj0.o zgsvj1.o \ @@ -449,7 +450,7 @@ ZLASRC = \ zlanhe.o \ zlanhp.o zlanhs.o zlanht.o zlansb.o zlansp.o zlansy.o zlantb.o \ zlantp.o zlantr.o zlapll.o zlapmt.o zlaqgb.o zlaqge.o \ - zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqps.o zlaqsb.o \ + zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqps.o zlaqp2rk.o zlaqp3rk.o zlaqsb.o \ zlaqr0.o zlaqr1.o zlaqr2.o zlaqr3.o zlaqr4.o zlaqr5.o \ zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \ zlarcm.o zlarf.o zlarfb.o zlarfb_gett.o \ diff --git a/SRC/zgeqp3rk.f b/SRC/zgeqp3rk.f new file mode 100755 index 0000000000..d9c26fb656 --- /dev/null +++ b/SRC/zgeqp3rk.f @@ -0,0 +1,1128 @@ +*> \brief \b ZGEQP3RK computes a truncated Householder QR factorization with column pivoting of a complex m-by-n matrix A by using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ WORK, LWORK, RWORK, IWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a complex +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank of the +*> factor R, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is an N-by-N permutation matrix; +*> Q(K) is an M-by-M orthogonal matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a complex M-by-NRHS +*> matrix B with Q(K)**H * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAX, the maximum number of columns +*> KMAX to factorize, i.e. the factorization rank is limited +*> to KMAX. If KMAX >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) to +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> 4) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix R22(K) is a zero matrix in some +*> factorization step K. ( This stopping criterion is implicit. ) +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> To factorize the whole matrix A, use the values +*> KMAX >= min(M,N), ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_residual); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**H * B, the matrix B with the orthogonal +*> transformation Q(K)**H applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M orthogonal matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**H, +*> +*> where 1 <= j <= K and +*> I is an M-by-M identity matrix, +*> tau is a complex scalar, +*> v is a complex vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e. the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M,N), then this stopping criterion +*> is not used, the routine factorizes columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> +*> The second factorization stopping criterion, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. Let SAFMIN = DLAMCH('S'). +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If ABSTOL chosen above is >= MAXC2NRM, then this +*> stopping criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. The routine +*> returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION +*> +*> The third factorization stopping criterion, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. Let EPS = DLAMCH('E'). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX 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. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. +*> The routine returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend that RELTOL satisfy +*> min(max(M,N)*EPS, sqrt(EPS)) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of the +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,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(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) If NRHS > 0, the subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**H * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> +*> NOTE: If K = 0, a) the arrays A and B are not modified; +*> b) the array TAU(1:min(M,N)) is set to ZERO, +*> if the matrix A does not contain NaN, +*> otherwise the elements TAU(1:min(M,N)) +*> are undefined; +*> c) the elements of the array JPIV are set +*> as follows: for j = 1:N, JPIV(j) = j. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix R22(K), +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK in the factorization step K would equal +*> R(K+1,K+1) in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix R22(K) (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK in the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The elements of the array JPIV(1:N) are always set +*> by the routine, for example, even when no columns +*> were factorized, i.e. when K = 0, the elements are +*> set as JPIV(j) = j for j = 1:N. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= min(M,N), only the elements TAU(1:K) of +*> the array TAU are modified by the factorization. +*> After the factorization computed, if no NaN was found +*> during the factorization, the remaining elements +*> TAU(K+1:min(M,N)) are set to zero, otherwise the +*> elements TAU(K+1:min(M,N)) are not set and therefore +*> undefined. +*> ( If K = 0, all elements of TAU are set to zero, if +*> the matrix A does not contain NaN. ) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*. LWORK >= N+NRHS-1 +*> For optimal performance LWORK >= NB*( N+NRHS+1 ), +*> where NB is the optimal block size for ZGEQP3RK returned +*> by ILAENV. Minimal block size MINNB=2. +*> +*> NOTE: The decision, whether to use unblocked BLAS 2 +*> or blocked BLAS 3 code is based not only on the dimension +*> LWORK of the availbale workspace WORK, but also also on the +*> matrix A dimension N via crossover point NX returned +*> by ILAENV. (For N less than NX, unblocked code should be +*> used.) +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine ZLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> ZGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in ZGEQP3 routine which uses +*> ZLARFG routine to generate Householder reflectors +*> for QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ WORK, LWORK, RWORK, IWORK, 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 .. + INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE + INTEGER IINFO, IOFFSET, IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, N_SUB, NB, + $ NBMIN, NX + DOUBLE PRECISION EPS, HUGEVAL, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL ZLAQP2RK, ZLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DISNAN, DLAMCH, DZNRM2, IDAMAX, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE +* +* Minimal workspace size in case of using only unblocked +* BLAS 2 code in ZLAQP2RK. +* 1) ZLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in ZLARF subroutine inside ZLAQP2RK to apply an +* elementary reflector from the left. +* TOTAL_WORK_SIZE = 3*N + NRHS - 1 +* + IWS = N + NRHS - 1 +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'ZGEQP3RK', ' ', M, N, -1, -1 ) +* +* A formula for the optimal workspace size in case of using +* both unblocked BLAS 2 in ZLAQP2RK and blocked BLAS 3 code +* in ZLAQP3RK. +* 1) ZGEQP3RK, ZLAQP2RK, ZLAQP3RK: 2*N to store full and +* partial column 2-norms. +* 2) ZLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in ZLARF subroutine to apply an elementary reflector +* from the left. +* 3) ZLAQP3RK: NB*(N+NRHS) to use in the work array F that +* is used to apply a block reflector from +* the left. +* 4) ZLAQP3RK: NB to use in the auxilixary array AUX. +* Sizes (2) and ((3) + (4)) should intersect, therefore +* TOTAL_WORK_SIZE = 2*N + NB*( N+NRHS+1 ), given NBMIN=2. +* + LWKOPT = 2*N + NB*( N+NRHS+1 ) + END IF + WORK( 1 ) = DCMPLX( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M=0 or N=0. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease in each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + RWORK( J ) = DZNRM2( M, A( 1, J ), 1 ) + RWORK( N+J ) = RWORK( J ) + END DO + + WRITE(*,*) + WRITE(*,*) "===== ZGEQP3RK 2NORM =" + WRITE(*,*) + $ RWORK( 1 ), RWORK( 2 ), RWORK( 3 ), RWORK( 4 ), + $ RWORK( 5 ), RWORK( 6 ), RWORK( 7 ), RWORK( 8 ) + WRITE(*,*) +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole original matrix stored in A(1:M,1:N). +* + KP1 = IDAMAX( N, RWORK( 1 ), 1 ) + MAXC2NRM = RWORK( KP1 ) + WRITE(*,*) "======= ZGEQP3RK ((( before NaN in MATRIX ))) KP1=", + $ KP1 +* +* ==================================================================. +* + IF( DISNAN( MAXC2NRM ) ) THEN +* +* Check if the matrix A contains NaN, set INFO parameter +* to the column number where the first NaN is found and return +* from the routine. +* + WRITE(*,*) "======= ZGEQP3RK ((( NaN in MATRIX ))) ====" + + K = 0 + INFO = KP1 +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = MAXC2NRM +* +* Array TAU is not set and contains undefined elements. +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* =================================================================== +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* +* Check is the matrix A is a zero matrix, set array TAU and +* return from the routine. +* + WRITE(*,*) "======= ZGEQP3RK ((( ZERO MATRIX ))) ====" + + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = CZERO + END DO +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN +* + END IF +* +* =================================================================== +* + HUGEVAL = DLAMCH( 'Overflow' ) +* + IF( MAXC2NRM.GT.HUGEVAL ) THEN +* +* Check if the matrix A contains +Inf or -Inf, set INFO parameter +* to the column number, where the first +/-Inf is found plus N, +* and continue the computation. +* + INFO = N + KP1 +* + END IF +* +* ================================================================== +* +* Quick return if possible for the case when the first +* stopping criterion is satisfied, i.e. KMAX = 0. +* + IF( KMAX.EQ.0 ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = CZERO + END DO + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + END IF +* +* Adjust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + END IF +* +* =================================================================== +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* =================================================================== +* +* Quick return if possible for the case when the second or third +* stopping criterion for the whole original matrix is satified, +* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL +* (which is ONE <= RELTOL). +* + IF( MAXC2NRM.LE.ABSTOL .OR. ONE.LE.RELTOL ) THEN +* + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + DO J = 1, MINMN + TAU( J ) = CZERO + END DO +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'ZGEQP3RK', ' ', M, N, -1, -1 ) ) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'ZGEQP3RK', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* +* ================================================================== +* +* DONE is the boolean flag to rerpresent the case when the +* factorization completed in the block factorization routine, +* before the end of the block. +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB; +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) + N_SUB = N-J+1 + IOFFSET = J-1 +* +* Factorize JB columns among the columns A(J:N). +* + WRITE(*,*) + WRITE(*,*) "===== ZGEQP3RK loop before block(IOFFSET, JB)=", + $ J-1, JB + + CALL ZLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ RWORK( J ), RWORK( N+J ), + $ WORK( 1 ), WORK( JB+1 ), + $ N+NRHS-J+1, IWORK, IINFO ) +* + + WRITE(*,*) "======= ZGEQP3RK loop after block (JBF)=", + $ JBF +* +* Set INFO on the first occurence of Inf. +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + END IF +* + IF( DONE ) THEN +* +* Either the submatrix is zero before the end of the +* column block, or ABSTOL or RELTOL criterion is +* satisfied before the end of the column block, we can +* return from the routine. Perform the following before +* returning: +* a) Set the number of factorized columns K, +* K = IOFFSET + JBF from the last call of blocked +* routine. +* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned +* by the block factorization routine; +* 2) The remaining TAUs are set to ZERO by the +* block factorization routine. +* + K = IOFFSET + JBF +* +* Set INFO on the first occurrence of NaN, NaN takes +* prcedence over Inf. +* + IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* +* Return from the routine. +* + WORK( 1 ) = DCMPLX( LWKOPT ) +* + RETURN +* + END IF +* + J = J + JBF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of +* columns, that is in ELSE clause we need to compute +* the MAXC2NORM and RELMAXC2NORM to return after we processed +* the blocks. +* + IF( J.LE.JMAX ) THEN +* +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + N_SUB = N-J+1 + IOFFSET = J-1 +* + CALL ZLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, + $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ KF, MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), RWORK( J ), RWORK( N+J ), + $ WORK( 1 ), IINFO ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* +* Set INFO on the first exception occurence. +* + WRITE(*,*) "======= ZGEQP3RK after call to ZLAQP2RK INFO=", + $ INFO +* +* Set INFO on the first exception occurence of Inf or NaN, +* (NaN takes precedence over Inf). +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + IDAMAX( N-K, RWORK( K+1 ), 1 ) + MAXC2NRMK = RWORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = CZERO + END DO + + + WRITE(*,*) + WRITE(*,*) "===== END ZGEQP3RK compute low rank ", + $ "(MAXC2NRMK, RELMAXC2NRMK)=", + $ MAXC2NRMK, RELMAXC2NRMK + + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + + WRITE(*,*) + WRITE(*,*) "===== END ZGEQP3RK compute full rank ", + $ "(MAXC2NRMK, RELMAXC2NRMK)=", + $ MAXC2NRMK, RELMAXC2NRMK + + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF + + + DO J = 1 , MINMN + WRITE(*,*) "===== END ZGEQP3RK before return (J,TAU(J))", + $ J, TAU( J ) + END DO + + WRITE(*,*) + WRITE(*,*) "===== END ZGEQP3RK before return ", + $ "(K, MAXC2NRMK, RELMAXC2NRMK)=", + $ K, MAXC2NRMK, RELMAXC2NRMK + +* + WORK( 1 ) = DCMPLX( LWKOPT ) +* + RETURN +* +* End of ZGEQP3RK +* + END diff --git a/SRC/zlaqp2rk.f b/SRC/zlaqp2rk.f new file mode 100755 index 0000000000..02e9a76be5 --- /dev/null +++ b/SRC/zlaqp2rk.f @@ -0,0 +1,750 @@ +*> \brief \b ZLAQP2RK computes truncated QR factorization with column pivoting of a complex matrix block using Level 2 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, +* $ INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* DOUBLE PRECISION VN1( * ), VN2( * ) +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* $ +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of the complex matrix +*> block A(IOFFSET+1:M,1:N) as +*> +*> A * P(K) = Q(K) * R(K). +*> +*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides matrix block B +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**H * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine ZGEQP3RK. 1 <= KP1 <= N_orig_mat. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine ZGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:K) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS). +*> The left part A(IOFFSET+1:M,K+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(K)**H. +*> \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 +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N-1) +*> Used in ZLARF subroutine to apply an elementary +*> reflector from the left. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + DOUBLE PRECISION VN1( * ), VN2( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, + $ MINMNUPDT + DOUBLE PRECISION HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z + COMPLEX*16 AIKK +* .. +* .. External Subroutines .. + EXTERNAL ZLARF, ZLARFG, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DISNAN, DLAMCH, IDAMAX, DZNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* +* MINMNUPDT is the smallest dimension +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which +* contains the submatrices A(IOFFSET+1:M,1:N) and +* B(IOFFSET+1:M,1:NRHS) as column blocks. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KMAX = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) + HUGEVAL = DLAMCH( 'Overflow' ) + + WRITE(*,*) + WRITE(*,*) "####_#### Enter ZLAQP2RK " + WRITE(*,*) " (M, N, NRHS, IOFFSET, KMAX, KP1,", + $ " MAXC2NRM)", + $ M, N, NRHS, IOFFSET, KMAX, KP1, MAXC2NRM + WRITE(*,*) + +* +* Compute the factorization, KK is the lomn loop index. +* + DO KK = 1, KMAX +* + I = IOFFSET + KK +* + IF( I.EQ.1 ) THEN +* +* ============================================================ +* +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + + KP = KP1 + + WRITE(*,*) " _#### ZLAQP2RK IOFFSET=0, + $ first column KP=",KP +* +* ============================================================ +* + ELSE +* +* ============================================================ +* +* Determine the pivot column in KK-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( KK-1 ) + IDAMAX( N-KK+1, VN1( KK ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,KK:N) in step KK. +* RELMAXC2NRMK will be computed later, after somecondition +* checks on MAXC2NRMK. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains NaN, and set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( DISNAN( MAXC2NRMK ) ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + INFO = K + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* Array TAU(K+1:MINMNFACT) is not set and contains +* undefined elements. +* + RETURN + END IF +* +* ============================================================ +* +* Quick return, if the submatrix A(I:M,KK:N) is +* a zero matrix. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + RELMAXC2NRMK = ZERO +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + KK - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL >= ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. + + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Set K, the number of factorized columns. +* + K = KK - 1 +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,KK:N): +* 1) swap the KK-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the KK-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than KK in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.KK ) THEN + CALL ZSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 ) + VN1( KP ) = VN1( KK ) + VN2( KP ) = VN2( KK ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( KK ) + JPIV( KK ) = ITEMP + END IF +* +* Generate elementary reflector H(KK) using the column A(I:M,KK), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(KK) = CZERO. +* + IF( I.LT.M ) THEN + CALL ZLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, + $ TAU( KK ) ) + ELSE + TAU( KK ) = CZERO + END IF + + WRITE(*,*) " _#### ZLAQP2RK (K, TAU(Kk) )=", KK, TAU(KK) +* +* Check if TAU(KK) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(KK) for Inf, +* since ZLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by ZLARFG can contain Inf, which requires +* TAU(KK) to contain NaN. Therefore, this case of generating Inf +* by ZLARFG is covered by checking TAU(KK) for NaN. +* + IF( DISNAN( DBLE( TAU(KK) ) ) ) THEN + TAUNAN = DBLE( TAU(KK) ) + ELSE IF( DISNAN( DIMAG( TAU(KK) ) ) ) THEN + TAUNAN = DIMAG( TAU(KK) ) + ELSE + TAUNAN = ZERO + END IF +* + IF( DISNAN( TAUNAN ) ) THEN + K = KK - 1 + INFO = KK + WRITE(*,*) " _#### ZLAQP2RK ((TAU is NaN))", + $ " (KK, INFO),TAU", + $ KK, INFO, TAU(KK) +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAUNAN + RELMAXC2NRMK = TAUNAN +* +* Array TAU(KK:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(KK) = NaN. +* + RETURN + END IF +* +* Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. +* ( If M >= N, then at KK = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B. +* If M < N, then at KK = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* KK < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only KK < N+NRHS ) +* + IF( KK.LT.MINMNUPDT ) THEN + AIKK = A( I, KK ) + A( I, KK ) = CONE + CALL ZLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ DCONJG( TAU( KK ) ), A( I, KK+1 ), LDA, + $ WORK( 1 ) ) + A( I, KK ) = AIKK + END IF +* + IF( KK.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. +* when KK < min(M-IOFFSET, N). +* + DO J = KK + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* If we reached this point, all colunms have been factorized, +* i.e. no condition was triggered to exit the routine. +* Set the number of factorized columns. +* + K = KMAX +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before +* we return. +* + + WRITE(*,*) " _#### ZLAQP2RK after loop (K,MINMNFACT)", K, + $ MINMNFACT + + IF( K.LT.MINMNFACT ) THEN +* + JMAXC2NRM = K + IDAMAX( N-K, VN1( K+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, set TAUs corresponding to the columns that were +* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. +* + DO J = K + 1, MINMNFACT + TAU( J ) = CZERO + END DO + + DO J = 1 , MINMNFACT + WRITE(*,*) " _#### END ZLAQP2RK before return", + $ " (J,TAU(J))", + $ J, TAU( J ) + END DO + + + WRITE(*,*) + WRITE(*,*) " _#### Exit ZLAQP2RK " + WRITE(*,*) " (K, MAXC2NRMK, RELMAXC2NRMK)", + $ K, MAXC2NRMK, RELMAXC2NRMK + WRITE(*,*) + +* + RETURN +* +* End of ZLAQP2RK +* + END diff --git a/SRC/zlaqp3rk.f b/SRC/zlaqp3rk.f new file mode 100755 index 0000000000..ce729adfa6 --- /dev/null +++ b/SRC/zlaqp3rk.f @@ -0,0 +1,1008 @@ +*> \brief \b ZLAQP3RK computes a step of truncated QR factorization with column pivoting of a complex m-by-n matrix A using Level 3 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZLAQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, +* $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, +* $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) +* IMPLICIT NONE +* LOGICAL DONE +* INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, +* $ NB, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* +* .. Scalar Arguments .. +* LOGICAL DONE +* INTEGER KB, LDA, LDF, M, N, NB, NRHS, IOFFSET +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION VN1( * ), VN2( * ) +* COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQP3RK computes a step of truncated QR factorization with column +*> pivoting of a complex M-by-N matrix A block A(IOFFSET+1:M,1:N) +*> by using Level 3 BLAS as +*> +*> A * P(KB) = Q(KB) * R(KB). +*> +*> The routine tries to factorize NB columns from A starting from +*> the row IOFFSET+1 and updates the residual matrix with BLAS 3 +*> xGEMM. The number of actually factorized columns is returned +*> is smaller than NB. +*> +*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides B matrix stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**H * B. +*> +*> Cases when the number of factorized columns KB < NB: +*> +*> (1) In some cases, due to catastrophic cancellations, it cannot +*> factorize all NB columns and need to update the residual matrix. +*> Hence, the actual number of factorized columns in the block returned +*> in KB is smaller than NB. The logical DONE is returned as FALSE. +*> The factorization of the whole original matrix A_orig must proceed +*> with the next block. +*> +*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. +*> +*> (3) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix is a zero matrix in some factorization +*> step KB, the factorization of the whole original matrix A_orig is +*> stopped, the logical DONE is returned as TRUE. The number of +*> factorized columns which is smaller than NB is returned in KB. +*> +*> (4) Whenever NaN is detected in the matrix A or in the array TAU, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. The INFO +*> parameter is set to the column index of the first NaN occurrence. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Factorization block size, i.e the number of columns +*> to factorize in the matrix A. 0 <= NB +*> +*> If NB = 0, then the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine ZGEQP3RK. 1 <= KP1 <= N_orig. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine ZGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KB) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(KB) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:KB) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KB+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(KB)**H. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] +*> \verbatim +*> DONE is LOGICAL +*> TRUE: a) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to ABSTOL +*> or RELTOL criterion, +*> b) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to the +*> residual matrix being a ZERO matrix. +*> c) when NaN was detected in the matrix A +*> or in the array TAU. +*> FALSE: otherwise. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= KB <= min(M-IOFFSET,NB,N). +*> +*> KB also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank KB. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank KB) to the maximum column 2-norm of the +*> original matrix A_orig. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] AUXV +*> \verbatim +*> AUXV is DOUBLE PRECISION array, dimension (NB) +*> Auxiliary vector. +*> \endverbatim +*> +*> \param[out] F +*> \verbatim +*> F is DOUBLE PRECISION array, dimension (LDF,NB) +*> Matrix F**H = L*(Y**H)*A. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1,N+NRHS). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step KB+1 ( when KB columns +*> have been factorized ). +*> +*> On exit: +*> KB is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(KB+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=KB+1, TAU(KB+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the actorization +*> step KB+1 ( when KB columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp3rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, + $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary 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 DONE + INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, + $ NB, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION VN1( * ), VN2( * ) + COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, + $ LSTICC, KP, I, IF + DOUBLE PRECISION HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z + COMPLEX*16 AIK +* .. +* .. External Subroutines .. + EXTERNAL ZGEMM, ZGEMV, ZLARFG, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DISNAN, DLAMCH, IDAMAX, DZNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + NB = MIN( NB, MINMNFACT ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) + HUGEVAL = DLAMCH( 'Overflow' ) + + WRITE(*,*) "$$$$_$$$$ Enter ZLAQP3RK " + WRITE(*,*) " (M, N, NRHS, IOFFSET, NB, KP1, MAXC2NRM)", + $ M, N, NRHS, IOFFSET, NB, KP1, MAXC2NRM + + +* +* Compute factorization in a while loop over NB columns, +* K is the column index in the block A(1:M,1:N). +* + K = 0 + LSTICC = 0 + DONE = .FALSE. +* + DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) + K = K + 1 + I = IOFFSET + K +* + IF( I.EQ.1 ) THEN +* +* We are at the first column of the original whole matrix A_orig, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* + ELSE +* +* Determine the pivot column in K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) in step K. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains NaN, set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( DISNAN( MAXC2NRMK ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = KB + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. + + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check it only if the column index +* (same as row index) is larger than 1, since the condition +* for the whole original matrix A_orig is checked in the main +* routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN + + + WRITE(*,*) "$$$$$$ ZLAQP3RK zero submatrix, IOFFSET, K= ", + $ IOFFSET, K +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + WRITE(*,*) + $ "$$$$$$$$ ZLAQP3RK zero submatrix (ABSTOL, K)= ", + $ ABSTOL, K +* + KB = K - 1 + IF = I - 1 + RELMAXC2NRMK = ZERO +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix is zero and we stop the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + + + WRITE(*,*) "$$$$$$$$$$ ZLAQP3RK zero submatrix", + $ " block reflector (M-IF, NRHS, KB)", + $ M-IF, NRHS, KB + + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. +* + DO J = K, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + K - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third tolerance stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig; +* + KB = K - 1 + IF = I - 1 + + WRITE(*,*) "$$$$$$$$$$ ZLAQP3RK condition for", + $ " ABSTOL or RELTOL (ABSTOL, RELTOL),", + $ " (MAXC2NRMK, RELMAXC2NRMK)", + $ ABSTOL, RELTOL, MAXC2NRMK, RELMAXC2NRMK + + +* Apply the block reflector to the residual of the +* matrix A and the residual of the right hand sides B, if +* the residual matrix and and/or the residual of the right +* hand sides exist, i.e. if the submatrix +* A(I+1:M,KB+1:N+NRHS) exists. This occurs when +* KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. +* + IF( KB.LT.MINMNUPDT ) THEN + + WRITE(*,*) "$$$$$$$$$$ ZLAQP3RK ABSTOL or RELTOL", + $ " block reflector (M-IF, N+NRHS-KB, KB)", + $ M-IF, N+NRHS-KB, KB + + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, N+NRHS-KB, KB,-CONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. +* + DO J = K, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) +* 3) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. (Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 4) Save the pivot interchange with the indices relative to the +* the original matrix A_orig, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL ZSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + CALL ZSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Apply previous Householder reflectors to column K: +* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**H. +* + IF( K.GT.1 ) THEN + DO J = 1, K - 1 + F( K, J ) = DCONJG( F( K, J ) ) + END DO + CALL ZGEMV( 'No transpose', M-I+1, K-1, -CONE, A( I, 1 ), + $ LDA, F( K, 1 ), LDF, CONE, A( I, K ), 1 ) + DO J = 1, K - 1 + F( K, J ) = DCONJG( F( K, J ) ) + END DO + END IF +* +* Generate elementary reflector H(k) using the column A(I:M,K). +* + IF( I.LT.M ) THEN + CALL ZLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) ) + ELSE + TAU( K ) = CZERO + END IF +* +* Check if TAU(K) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(K) for Inf, +* since ZLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by ZLARFG can contain Inf, which requires +* TAU(K) to contain NaN. Therefore, this case of generating Inf +* by ZLARFG is covered by checking TAU(K) for NaN. +* + IF( DISNAN( DBLE( TAU(K) ) ) ) THEN + TAUNAN = DBLE( TAU(K) ) + ELSE IF( DISNAN( DIMAG( TAU(K) ) ) ) THEN + TAUNAN = DIMAG( TAU(K) ) + ELSE + TAUNAN = ZERO + END IF +* + IF( DISNAN( TAUNAN ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = K + + WRITE(*,*) "## ZLAQP2RK ((TAU is NaN)) (K, INFO),TAU", + $ K, INFO, TAU(K) +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAUNAN + RELMAXC2NRMK = TAUNAN +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* =============================================================== +* + AIK = A( I, K ) + A( I, K ) = CONE +* +* =============================================================== +* +* Compute the current K-th column of F: +* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**H * A(I:M,K). +* + IF( K.LT.N+NRHS ) THEN + CALL ZGEMV( 'Conjugate transpose', M-I+1, N+NRHS-K, + $ TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1, + $ CZERO, F( K+1, K ), 1 ) + END IF +* +* 2) Zero out elements above and on the diagonal of the +* column K in matrix F, i.e elements F(1:K,K). +* + DO J = 1, K + F( J, K ) = CZERO + END DO +* +* 3) Incremental updating of the K-th column of F: +* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**H +* * A(I:M,K). +* + IF( K.GT.1 ) THEN + CALL ZGEMV( 'Conjugate Transpose', M-I+1, K-1, -TAU( K ), + $ A( I, 1 ), LDA, A( I, K ), 1, CZERO, + $ AUXV( 1 ), 1 ) +* + CALL ZGEMV( 'No transpose', N+NRHS, K-1, CONE, + $ F( 1, 1 ), LDF, AUXV( 1 ), 1, CONE, + $ F( 1, K ), 1 ) + END IF +* +* =============================================================== +* +* Update the current I-th row of A: +* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) +* - A(I,1:K)*F(K+1:N+NRHS,1:K)**H. +* + IF( K.LT.N+NRHS ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ 1, N+NRHS-K, K, -CONE, A( I, 1 ), LDA, + $ F( K+1, 1 ), LDF, CONE, A( I, K+1 ), LDA ) + END IF +* + A( I, K ) = AIK +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < MINMNFACT = min( M-IOFFSET, N ). +* + IF( K.LT.MINMNFACT ) THEN +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2.LE.TOL3Z ) THEN +* +* At J-index, we have a difficult column for the +* update of the 2-norm. Save the index of the previous +* difficult column in IWORK(J-1). +* NOTE: ILSTCC > 1, threfore we can use IWORK only +* with N-1 elements, where the elements are +* shifted by 1 to the left. +* + IWORK( J-1 ) = LSTICC +* +* Set the index of the last difficult column LSTICC. +* + LSTICC = J +* + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + END DO +* + END IF +* +* End of while loop. +* + END DO +* +* Now, afler the loop: +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig, IF = IOFFSET + KB. +* + KB = K + IF = I +* +* Apply the block reflector to the residual of the matrix A +* and the residual of the right hand sides B, if the residual +* matrix and and/or the residual of the right hand sides +* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. +* This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. +* + WRITE(*,*) " _$$$$ ZLAQP3RK A before ZGEMM" + WRITE(*,*) " ( KB, IF, MINMNUPDT, NRHS )", + $ KB, IF, MINMNUPDT, NRHS + + + IF( KB.LT.MINMNUPDT ) THEN + CALL ZGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, N+NRHS-KB, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. +* + + WRITE(*,*) " _$$$$ ZLAQP3RK A after ZGEMM" + DO J = 1, M + WRITE(*,*) + $ A(J,1), A(J,2), + $ A(J,3), A(J,4), + $ A(J, 5), A(J,6) + END DO + WRITE(*,*) + + + DO WHILE( LSTICC.GT.0 ) + + WRITE(*,*) " _$$$$ ZLAQP3RK inside bad norm updating" +* +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. +* + ITEMP = IWORK( LSTICC-1 ) +* +* Compute the 2-norm explicilty for the last difficult column and +* save it in the partial and exact 2-norm vectors VN1 and VN2. +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* DZNRM2 does not fail on vectors with norm below the value of +* SQRT(DLAMCH('S')) +* + VN1( LSTICC ) = DZNRM2( M-IF, A( IF+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) +* +* Downdate the index of the last difficult column to +* the index of the previous difficult column. +* + LSTICC = ITEMP +* + END DO + + DO J = 1 , MINMNFACT + WRITE(*,*) " _$$$$ END ZLAQP3RK before return", + $ " (J,TAU(J))", + $ J, TAU( J ) + END DO + + + WRITE(*,*) + WRITE(*,*) " _$$$$ Exit ZLAQP2RK " + WRITE(*,*) " (KB, MAXC2NRMK, RELMAXC2NRMK)", + $ KB, MAXC2NRMK, RELMAXC2NRMK + WRITE(*,*) + +* + RETURN +* +* End of ZLAQP3RK +* + END From e3b58c4cda026bc573513c7cc1b74424fb6ceb0c Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 085/106] added testing code for DGEQP3RK --- TESTING/LIN/CMakeLists.txt | 2 +- TESTING/LIN/Makefile | 2 +- TESTING/LIN/zchkaa.F | 31 +- TESTING/LIN/zchkqp3rk.f | 974 +++++++++++++++++++++++++++++++++++++ TESTING/LIN/zlatb4.f | 104 ++++ TESTING/LIN/zqpt01.f | 22 +- TESTING/LIN/zqrt11.f | 4 +- TESTING/LIN/zqrt12.f | 15 +- TESTING/ztest.in | 1 + 9 files changed, 1127 insertions(+), 28 deletions(-) create mode 100644 TESTING/LIN/zchkqp3rk.f diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index d05ecd4142..5f9b2bee8b 100755 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -158,7 +158,7 @@ set(ZLINTST zchkaa.F zchkhe.f zchkhe_rook.f zchkhe_rk.f zchkhe_aa.f zchkhe_aa_2stage.f zchkhp.f zchklq.f zchkpb.f - zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkql.f + zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkq3rk.f zchkql.f zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f zchksy_aa.f zchksy_aa_2stage.f zchktb.f diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 026c8d452f..65ad9c493e 100755 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -182,7 +182,7 @@ ZLINTST = zchkaa.o \ zchkeq.o zchkgb.o zchkge.o zchkgt.o \ zchkhe.o zchkhe_rook.o zchkhe_rk.o zchkhe_aa.o zchkhe_aa_2stage.o \ zchkhp.o zchklq.o zchkpb.o \ - zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o \ + zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkqp3rk.o zchkql.o \ zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchksy_rk.o \ zchksy_aa.o zchksy_aa_2stage.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ diff --git a/TESTING/LIN/zchkaa.F b/TESTING/LIN/zchkaa.F index a118515a5d..edbf167c58 100644 --- a/TESTING/LIN/zchkaa.F +++ b/TESTING/LIN/zchkaa.F @@ -69,6 +69,7 @@ *> ZLQ 8 List types on next line if 0 < NTYPES < 8 *> ZQL 8 List types on next line if 0 < NTYPES < 8 *> ZQP 6 List types on next line if 0 < NTYPES < 6 +*> ZQK 19 List types on next line if 0 < NTYPES < 19 *> ZTZ 3 List types on next line if 0 < NTYPES < 3 *> ZLS 6 List types on next line if 0 < NTYPES < 6 *> ZEQ @@ -153,12 +154,11 @@ PROGRAM ZCHKAA $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) - DOUBLE PRECISION S( 2*NMAX ) COMPLEX*16 E( NMAX ) * * .. Allocatable Arrays .. INTEGER AllocateStatus - DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE:: RWORK + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE:: RWORK, S COMPLEX*16, DIMENSION(:,:), ALLOCATABLE:: A, B, WORK * .. * .. External Functions .. @@ -170,8 +170,8 @@ PROGRAM ZCHKAA EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE, $ ZCHKHE_ROOK, ZCHKHE_RK, ZCHKHE_AA, ZCHKHP, $ ZCHKLQ, ZCHKUNHR_COL, ZCHKPB, ZCHKPO, ZCHKPS, - $ ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ, - $ ZCHKSP, ZCHKSY, ZCHKSY_ROOK, ZCHKSY_RK, + $ ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQP3RK, ZCHKQL, ZCHKQR, + $ ZCHKRQ, ZCHKSP, ZCHKSY, ZCHKSY_ROOK, ZCHKSY_RK, $ ZCHKSY_AA, ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, $ ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHE_ROOK, $ ZDRVHE_RK, ZDRVHE_AA, ZDRVHE_AA_2STAGE, ZDRVHP, @@ -197,14 +197,16 @@ PROGRAM ZCHKAA DATA THREQ / 2.0D0 / , INTSTR / '0123456789' / * * .. Allocate memory dynamically .. - ALLOCATE (RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE (A ((KDMAX+1) * NMAX, 7), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE (B (NMAX * MAXRHS, 4), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE (WORK (NMAX, NMAX+MAXRHS+10), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE (S( 2*NMAX ), STAT = AllocateStatus) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE (RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * .. * .. Executable Statements .. * @@ -1109,6 +1111,23 @@ PROGRAM ZCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* QK: truncated QR factorization with pivoting +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ), + $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), + $ S( 1 ), B( 1, 4 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN * diff --git a/TESTING/LIN/zchkqp3rk.f b/TESTING/LIN/zchkqp3rk.f new file mode 100644 index 0000000000..2e78f99da9 --- /dev/null +++ b/TESTING/LIN/zchkqp3rk.f @@ -0,0 +1,974 @@ +*> \brief \b ZCHKQP3RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, +* $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, +* $ B, COPYB, S, TAU, +* $ WORK, RWORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), +* $ NXVAL( * ) +* DOUBLE PRECISION S( * ), RWORK( * ) +* COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKQP3RK tests ZGEQP3. +*> \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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \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[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is COMPLEX*16 array, dimension (MMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (MMAX*NSMAX) +*> where MMAX is the maximum value of M in MVAL and NSMAX is the +*> maximum value of NRHS in NSVAL. +*> \endverbatim +*> +*> \param[out] COPYB +*> \verbatim +*> COPYB is COMPLEX*16 array, dimension (MMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (max(M*max(M,N) + 4*min(M,N) + max(M,N))) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (4*NMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, + $ B, COPYB, S, TAU, + $ WORK, RWORK, 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 .. + INTEGER NM, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NSVAL( * ), NXVAL( * ) + DOUBLE PRECISION S( * ), RWORK( * ) + COMPLEX*16 A( * ), COPYA( * ), B( * ), COPYB( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + DOUBLE PRECISION ONE, ZERO, BIGNUM + COMPLEX*16 CONE, CZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, + $ CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ), + $ BIGNUM = 1.0D+100 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE + 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, + $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, + $ LWORK_ZUNMQR, M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, + $ NRUN, NX, T + DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ), RDUMMY( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, ZQPT01, ZQRT11, ZQRT12, ZLANGE + EXTERNAL DLAMCH, ZQPT01, ZQRT11, ZQRT12, ZLANGE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DLAORD, ICOPY, ZAXPY, + $ XLAENV, ZGEQP3RK, ZLACPY, ZLASET, ZLATB4, + $ ZLATMS, ZUNMQR, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT, ZUNMQR_LWORK +* .. +* .. 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 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'QK' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = DLAMCH( 'Epsilon' ) + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* + DO INS = 1, NNS + NRHS = NSVAL( INS ) +* +* Set up parameters with ZLATB4 and generate +* M-by-NRHS B matrix with ZLATMS. +* IMAT = 14: +* Random matrix, CNDNUM = 2, NORM = ONE, +* MODE = 3 (geometric distribution of singular values). +* + CALL ZLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYB, LDA, WORK, INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M, + $ NRHS, -1, -1, -1, 6, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + DO IMAT = 1, NTYPES +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE + + WRITE(*,*) "(4) ____ ____ ____ ____ Loop for " + WRITE(*,*) "IMAT, DOTYPE(IMAT), M, N, NRHS = ", + $ IMAT, DOTYPE(IMAT), M, N, NRHS + + + + +* +* 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 +* 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 11. Random, Half MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM ) +* one small singular value S(N)=1/CNDNUM +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1: Zero matrix +* + CALL ZLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA ) + DO I = 1, MINMN + S( I ) = ZERO + END DO + + WRITE(*,*) "GENERATED CZERO MATRIX" +* + ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 ) + $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrices 2-5. +* +* Set up parameters with DLATB4 and generate a test +* matrix with ZLATMS. +* + CALL ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + CALL DLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Rectangular matrices 5-13 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 +* for matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column. +* + IF( IMAT.EQ.5 ) THEN +* +* First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* 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 +* +* First half of MINMN columns is zero. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Last columns are zero columns, +* starting from (MINMN / 2 + 1) column. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - JB_ZERO + 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Half of the columns in the middle of MINMN +* columns is zero, starting from +* MINMN/2 - (MINMN/2)/2 + 1 column. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* 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 +* +* 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. + + WRITE(*,*) "( M,NB_ZERO, LDA before ZLASET", + $ M, NB_ZERO, LDA +* + CALL ZLASET( 'Full', M, NB_ZERO, CZERO, CZERO, + $ 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 ZLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' + + WRITE(*,*) "Generate DLAMTS matrix (M,NB_GEN)=", + $ M, NB_GEN + + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL ZLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) + + WRITE(*,*) "Singular val after mat generation S=" + WRITE(*,*) + $ S(1), S(2), S(3), S(4), + $ S(5), S(6), S(7), S(8) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF + + WRITE(*,*) "Matrix COPYA after", + $ " generation N_ZERO and N_GEN" + DO I = 1, M + WRITE(*,*) + $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), + $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), + $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I), + $ COPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) + END DO + + +* +* 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 ZSWAP( 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 ZSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing order and add trailing zeros +* that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) + + WRITE(*,*) "Singular values MINB_GEN=", MINMNB_GEN + WRITE(*,*) "Singular values before ordering S=" + WRITE(*,*) + $ S(1), S(2), S(3), S(4), + $ S(5), S(6), S(7), S(8) +* + CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) + + WRITE(*,*) "Singular values after ordering S=" + WRITE(*,*) + $ S(1), S(2), S(3), S(4), + $ S(5), S(6), S(7), S(8) + + DO I = MINMNB_GEN+1, MINMN + WRITE(*,*) "Singular values to ZERO out I=", I + S( I ) = ZERO + END DO + + WRITE(*,*) "Matrix with ZERO columnms COPYA" + DO I = 1, M + WRITE(*,*) + $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), + $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), + $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I), + $ COPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) + END DO + + + WRITE(*,*) "Matrix with ZERO columns ordering of S=" + WRITE(*,*) + $ S(1), S(2), S(3), S(4), + $ S(5), S(6), S(7), S(8) +* + ELSE +* +* IF(MINMN.LT.2) skip this size for this matrix type. +* + CYCLE + END IF +* + WRITE(*,*) "AFTER GENERATING COPYA" + DO I = 1, M + WRITE(*,*) + $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), + $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), + $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I) +** $ C,OPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) + END DO + WRITE(*,*) "AFTER GENERATING COPYA, S=" + WRITE(*,*) + $ S(1), S(2), S(3), S(4), + $ S(5), S(6) +** $ , S(7), S(8) + +* +* Initialize a copy array for a pivot array for DGEQP3RK. +* + DO I = 1, N + IWORK( I ) = 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 ) +* + + WRITE(*,*) "(5) ____ ____ ____ ____ ____ Loop for NB,NX=", + $ NB, 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 KMAX = 0, MIN(M,N)+1 + + + WRITE(*,*) "(6) ____ ____ ____ ____ ____" , + $ " ____ Loop for KMAX=", KMAX +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). +* Get a working copy of COPYB into into B( 1:M, 1:NRHS ). +* Get a working copy of IWORK(1:N) awith zeroes into +* which is going to be used as pivot array IWORK( N+1:2N ). +* NOTE: IWORK(2N+1:3N) is going to be used as a WORK array +* for the routine. +* + CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL ZLACPY( 'All', M, NRHS, COPYB, LDA, + $ A( LDA*N + 1 ), LDA ) + CALL ZLACPY( 'All', M, NRHS, COPYB, LDA, + $ B, LDA ) + CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) +* + ABSTOL = -1.0 + RELTOl = -1.0 + + + WRITE(*,*) "(BEGIN) B VALUE OF B after COPYB into B" + + DO I = 1, LDA + WRITE(*,*) + $ B((1-1)*LDA+I), B((2-1)*LDA+I), + $ B((3-1)*LDA+I), B((4-1)*LDA+I), + $ B((5-1)*LDA+I), B((6-1)*LDA+I) +* $ ,B((7-1)*LDA+I), B((8-1)*LDA+I) +* $ ,B((9-1)*LDA+I), B((10-1)*LDA+I) +* $ ,B((11-1)*LDA+I), B((12-1)*LDA+I) + END DO + + WRITE(*,*) + WRITE(*,*) "(BEGIN) A after COPYA and COPYB into A" + DO I = 1, LDA + WRITE(*,*) + $ A((1-1)*LDA+I), A((2-1)*LDA+I), + $ A((3-1)*LDA+I), A((4-1)*LDA+I), + $ A((5-1)*LDA+I), A((6-1)*LDA+I) + END DO + WRITE(*,*) +* +* Compute the QR factorization with pivoting of A +* + LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ), + $ 3*N + NRHS - 1 ) ) +* +* Compute ZGEQP3RK factorization of A. +* + SRNAMT = 'ZGEQP3RK' + CALL ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ A, LDA, KFACT, MAXC2NRMK, + $ RELMAXC2NRMK, IWORK( N+1 ), TAU, + $ WORK, LW, RWORK, IWORK( 2*N+1 ), + $ INFO ) + + WRITE(*,*) + WRITE(*,*) "(END) A after ZGEQP3RK" + DO I = 1, LDA + WRITE(*,*) + $ A((1-1)*LDA+I), A((2-1)*LDA+I), + $ A((3-1)*LDA+I), A((4-1)*LDA+I), + $ A((5-1)*LDA+I), A((6-1)*LDA+I) + END DO + WRITE(*,*) + + WRITE(*,*) "TAU after ZGEQP3RK" + WRITE(*,*) + $ TAU(1), TAU(2), TAU(3), TAU(4), + $ TAU(5), TAU(6) + WRITE(*,*) + + WRITE(*,*) "JPIV after ZGEQP3RK", + $ IWORK(N+1), IWORK(N+2), IWORK(N+3), IWORK(N+4), + $ IWORK(N+5), IWORK(N+6) + WRITE(*,*) +* + WRITE(*,*) "INFO after ZGEQP3RK" + WRITE(*,*) INFO + WRITE(*,*) +* +* Check error code from ZGEQP3RK. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'ZGEQP3RK', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* + + + WRITE(*,*) "After ZGEQP3RK, KFACT, MAX2N, REL2N", + $ KFACT, MAXC2NRMK, RELMAXC2NRMK + + + IF( KFACT.EQ.MINMN ) THEN +* +* 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 ) +* + RESULT( 1 ) = ZQRT12( M, N, A, LDA, S, WORK, + $ LWORK , RWORK ) +* + DO T = 1, 1 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, NB, NX, + $ IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + 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 ) = ZQPT01( M, N, KFACT, COPYA, A, LDA, TAU, + $ IWORK( N+1 ), WORK, LWORK ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = ZQRT11( M, KFACT, A, LDA, TAU, WORK, + $ LWORK ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 2, 3 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater than 2. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)), +* K=1:KFACT-1 +* + IF( MIN(KFACT, MINMN).GE.2 ) THEN +* + DO J = 1, KFACT-1, 1 +* + DTEMP = (( ABS( A( (J-1)*M+J ) ) - + $ ABS( A( (J)*M+J+1 ) ) ) / + $ ABS( A(1) ) ) + + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF + END DO +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 4, 4 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', + $ M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, + $ RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* Compute test 5: +* +* This test in only for matrix A with min(M,N) > 0. +* +* The test returns the ratio: +* +* 1-norm(Q**T * B - Q**T * B ) / +* ( M * EPS ) +* +* (1) Compute B:=Q**T * B in the matrix B. +* + IF( MINMN.GT.0 ) THEN +* + LWORK_ZUNMQR = MAX(1, NRHS) + CALL ZUNMQR( 'Left', 'Conjugate transpose', + $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, + $ WORK, LWORK_ZUNMQR, INFO ) +* + DO I = 1, NRHS +* +* Compare N+J-th column of A and J-column of B. +* + CALL ZAXPY( M, -CONE, A( ( N+I-1 )*LDA+1 ), 1, + $ B( ( I-1 )*LDA+1 ), 1 ) + END DO +* + RESULT( 5 ) = + $ ABS( + $ ZLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) / + $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) + $ ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 5, 5 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'ZGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End compute test 5. +* + END IF +* +* 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 INS = 1, NNS +* + 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, ', NRHS =', I5, + $ ', KMAX =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of ZCHKQP3RK +* + END diff --git a/TESTING/LIN/zlatb4.f b/TESTING/LIN/zlatb4.f index 5001774dbf..a2b19f83d5 100644 --- a/TESTING/LIN/zlatb4.f +++ b/TESTING/LIN/zlatb4.f @@ -225,6 +225,110 @@ SUBROUTINE ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE ANORM = ONE END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* xQK: truncated QR with pivoting. +* 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' is +* + DIST = 'S' +* +* Set the lower and upper bandwidths. +* + 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, 'GE' ) ) THEN * diff --git a/TESTING/LIN/zqpt01.f b/TESTING/LIN/zqpt01.f index 4e53f92c84..c69eb658fd 100644 --- a/TESTING/LIN/zqpt01.f +++ b/TESTING/LIN/zqpt01.f @@ -33,7 +33,7 @@ *> Householder vectors, and the rest of AF contains a partially updated *> matrix. *> -*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) +*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) ) *> \endverbatim * * Arguments: @@ -172,28 +172,28 @@ DOUBLE PRECISION FUNCTION ZQPT01( M, N, K, A, AF, LDA, TAU, JPVT, * NORMA = ZLANGE( 'One-norm', M, N, A, LDA, RWORK ) * - DO 30 J = 1, K - DO 10 I = 1, MIN( J, M ) + DO J = 1, K + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - DO 20 I = J + 1, M + END DO + DO I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO - 20 CONTINUE - 30 CONTINUE - DO 40 J = K + 1, N + END DO + END DO + DO J = K + 1, N CALL ZCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) - 40 CONTINUE + END DO * CALL ZUNMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * - DO 50 J = 1, N + DO J = 1, N * * Compare i-th column of QR and jpvt(i)-th column of A * CALL ZAXPY( M, DCMPLX( -ONE ), A( 1, JPVT( J ) ), 1, $ WORK( ( J-1 )*M+1 ), 1 ) - 50 CONTINUE + END DO * ZQPT01 = ZLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) ) diff --git a/TESTING/LIN/zqrt11.f b/TESTING/LIN/zqrt11.f index c3be59c365..dc4af744f6 100644 --- a/TESTING/LIN/zqrt11.f +++ b/TESTING/LIN/zqrt11.f @@ -158,9 +158,9 @@ DOUBLE PRECISION FUNCTION ZQRT11( M, K, A, LDA, TAU, WORK, LWORK ) CALL ZUNM2R( 'Left', 'Conjugate transpose', M, M, K, A, LDA, TAU, $ WORK, M, WORK( M*M+1 ), INFO ) * - DO 10 J = 1, M + DO J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE - 10 CONTINUE + END DO * ZQRT11 = ZLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) diff --git a/TESTING/LIN/zqrt12.f b/TESTING/LIN/zqrt12.f index b128579288..91477b5ea2 100644 --- a/TESTING/LIN/zqrt12.f +++ b/TESTING/LIN/zqrt12.f @@ -28,7 +28,7 @@ *> ZQRT12 computes the singular values `svlues' of the upper trapezoid *> of A(1:M,1:N) and returns the ratio *> -*> || s - svlues||/(||svlues||*eps*max(M,N)) +*> || svlues - s||/(||s||*eps*max(M,N)) *> \endverbatim * * Arguments: @@ -154,11 +154,11 @@ DOUBLE PRECISION FUNCTION ZQRT12( M, N, A, LDA, S, WORK, LWORK, * CALL ZLASET( 'Full', M, N, DCMPLX( ZERO ), DCMPLX( ZERO ), WORK, $ M ) - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) + DO J = 1, N + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE + END DO + END DO * * Get machine parameters * @@ -207,9 +207,9 @@ DOUBLE PRECISION FUNCTION ZQRT12( M, N, A, LDA, S, WORK, LWORK, * ELSE * - DO 30 I = 1, MN + DO I = 1, MN RWORK( I ) = ZERO - 30 CONTINUE + END DO END IF * * Compare s and singular values of work @@ -217,6 +217,7 @@ DOUBLE PRECISION FUNCTION ZQRT12( M, N, A, LDA, S, WORK, LWORK, CALL DAXPY( MN, -ONE, S, 1, RWORK( 1 ), 1 ) ZQRT12 = DASUM( MN, RWORK( 1 ), 1 ) / $ ( DLAMCH( 'Epsilon' )*DBLE( MAX( M, N ) ) ) +* IF( NRMSVL.NE.ZERO ) $ ZQRT12 = ZQRT12 / NRMSVL * diff --git a/TESTING/ztest.in b/TESTING/ztest.in index 58da33d605..c83e82e456 100644 --- a/TESTING/ztest.in +++ b/TESTING/ztest.in @@ -42,6 +42,7 @@ ZRQ 8 List types on next line if 0 < NTYPES < 8 ZLQ 8 List types on next line if 0 < NTYPES < 8 ZQL 8 List types on next line if 0 < NTYPES < 8 ZQP 6 List types on next line if 0 < NTYPES < 6 +ZQK 19 List types on next line if 0 < NTYPES < 19 ZTZ 3 List types on next line if 0 < NTYPES < 3 ZLS 6 List types on next line if 0 < NTYPES < 6 ZEQ From 7656583a53460025b331d3eafce940f4ebd46dc6 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 086/106] changed formatting in the RELTOL description WE recomment RELTOL to be ... and for complex case added a factor of 10 as min( 10*max(M,N)*EPS, sqrt(EPS) ) <= RELTOL --- SRC/dgeqp3rk.f | 2 +- SRC/zgeqp3rk.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index fd1a6060e0..8571f84773 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -272,7 +272,7 @@ *> modified, and the matrix A is itself the residual. *> *> NOTE: We recommend that RELTOL satisfy -*> min(max(M,N)*EPS, sqrt(EPS)) <= RELTOL +*> min( max(M,N)*EPS, sqrt(EPS) ) <= RELTOL *> \endverbatim *> *> \param[in,out] A diff --git a/SRC/zgeqp3rk.f b/SRC/zgeqp3rk.f index d9c26fb656..d12ed5e589 100755 --- a/SRC/zgeqp3rk.f +++ b/SRC/zgeqp3rk.f @@ -273,7 +273,7 @@ *> modified, and the matrix A is itself the residual. *> *> NOTE: We recommend that RELTOL satisfy -*> min(max(M,N)*EPS, sqrt(EPS)) <= RELTOL +*> min( 10*max(M,N)*EPS, sqrt(EPS) ) <= RELTOL *> \endverbatim *> *> \param[in,out] A From bfbd799e1a41214ad6f52ecec2ec4b3147ec24c9 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 087/106] DOWNDATED comments in SRC/zgeqp3rk.f SRC/zlaqp2rk.f SRC/zlaqp3rk.f --- SRC/zgeqp3rk.f | 52 ++----------------------------------- SRC/zlaqp2rk.f | 35 ------------------------- SRC/zlaqp3rk.f | 70 +++----------------------------------------------- 3 files changed, 5 insertions(+), 152 deletions(-) diff --git a/SRC/zgeqp3rk.f b/SRC/zgeqp3rk.f index d12ed5e589..0cfc459b91 100755 --- a/SRC/zgeqp3rk.f +++ b/SRC/zgeqp3rk.f @@ -741,13 +741,6 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, RWORK( J ) = DZNRM2( M, A( 1, J ), 1 ) RWORK( N+J ) = RWORK( J ) END DO - - WRITE(*,*) - WRITE(*,*) "===== ZGEQP3RK 2NORM =" - WRITE(*,*) - $ RWORK( 1 ), RWORK( 2 ), RWORK( 3 ), RWORK( 4 ), - $ RWORK( 5 ), RWORK( 6 ), RWORK( 7 ), RWORK( 8 ) - WRITE(*,*) * * ================================================================== * @@ -755,9 +748,6 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * for the whole original matrix stored in A(1:M,1:N). * KP1 = IDAMAX( N, RWORK( 1 ), 1 ) - MAXC2NRM = RWORK( KP1 ) - WRITE(*,*) "======= ZGEQP3RK ((( before NaN in MATRIX ))) KP1=", - $ KP1 * * ==================================================================. * @@ -767,8 +757,6 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * to the column number where the first NaN is found and return * from the routine. * - WRITE(*,*) "======= ZGEQP3RK ((( NaN in MATRIX ))) ====" - K = 0 INFO = KP1 * @@ -790,8 +778,6 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * Check is the matrix A is a zero matrix, set array TAU and * return from the routine. * - WRITE(*,*) "======= ZGEQP3RK ((( ZERO MATRIX ))) ====" - K = 0 MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO @@ -954,10 +940,6 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * * Factorize JB columns among the columns A(J:N). * - WRITE(*,*) - WRITE(*,*) "===== ZGEQP3RK loop before block(IOFFSET, JB)=", - $ J-1, JB - CALL ZLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, @@ -966,10 +948,6 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, $ WORK( 1 ), WORK( JB+1 ), $ N+NRHS-J+1, IWORK, IINFO ) * - - WRITE(*,*) "======= ZGEQP3RK loop after block (JBF)=", - $ JBF -* * Set INFO on the first occurence of Inf. * IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN @@ -1046,9 +1024,6 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, K = J - 1 + KF * * Set INFO on the first exception occurence. -* - WRITE(*,*) "======= ZGEQP3RK after call to ZLAQP2RK INFO=", - $ INFO * * Set INFO on the first exception occurence of Inf or NaN, * (NaN takes precedence over Inf). @@ -1085,39 +1060,16 @@ SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, DO J = K + 1, MINMN TAU( J ) = CZERO END DO - - - WRITE(*,*) - WRITE(*,*) "===== END ZGEQP3RK compute low rank ", - $ "(MAXC2NRMK, RELMAXC2NRMK)=", - $ MAXC2NRMK, RELMAXC2NRMK - +* ELSE MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO - - WRITE(*,*) - WRITE(*,*) "===== END ZGEQP3RK compute full rank ", - $ "(MAXC2NRMK, RELMAXC2NRMK)=", - $ MAXC2NRMK, RELMAXC2NRMK - +* END IF * * END IF( J.LE.JMAX ) THEN * END IF - - - DO J = 1 , MINMN - WRITE(*,*) "===== END ZGEQP3RK before return (J,TAU(J))", - $ J, TAU( J ) - END DO - - WRITE(*,*) - WRITE(*,*) "===== END ZGEQP3RK before return ", - $ "(K, MAXC2NRMK, RELMAXC2NRMK)=", - $ K, MAXC2NRMK, RELMAXC2NRMK - * WORK( 1 ) = DCMPLX( LWKOPT ) * diff --git a/SRC/zlaqp2rk.f b/SRC/zlaqp2rk.f index 02e9a76be5..54fb67f4ec 100755 --- a/SRC/zlaqp2rk.f +++ b/SRC/zlaqp2rk.f @@ -394,14 +394,6 @@ SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, KMAX = MIN( KMAX, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) HUGEVAL = DLAMCH( 'Overflow' ) - - WRITE(*,*) - WRITE(*,*) "####_#### Enter ZLAQP2RK " - WRITE(*,*) " (M, N, NRHS, IOFFSET, KMAX, KP1,", - $ " MAXC2NRM)", - $ M, N, NRHS, IOFFSET, KMAX, KP1, MAXC2NRM - WRITE(*,*) - * * Compute the factorization, KK is the lomn loop index. * @@ -417,11 +409,7 @@ SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * therefore we use the computed KP1 and MAXC2NRM from the * main routine. * - KP = KP1 - - WRITE(*,*) " _#### ZLAQP2RK IOFFSET=0, - $ first column KP=",KP * * ============================================================ * @@ -587,8 +575,6 @@ SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, ELSE TAU( KK ) = CZERO END IF - - WRITE(*,*) " _#### ZLAQP2RK (K, TAU(Kk) )=", KK, TAU(KK) * * Check if TAU(KK) contains NaN, set INFO parameter * to the column number where NaN is found and return from @@ -611,9 +597,6 @@ SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, IF( DISNAN( TAUNAN ) ) THEN K = KK - 1 INFO = KK - WRITE(*,*) " _#### ZLAQP2RK ((TAU is NaN))", - $ " (KK, INFO),TAU", - $ KK, INFO, TAU(KK) * * Set MAXC2NRMK and RELMAXC2NRMK to NaN. * @@ -701,10 +684,6 @@ SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before * we return. * - - WRITE(*,*) " _#### ZLAQP2RK after loop (K,MINMNFACT)", K, - $ MINMNFACT - IF( K.LT.MINMNFACT ) THEN * JMAXC2NRM = K + IDAMAX( N-K, VN1( K+1 ), 1 ) @@ -728,20 +707,6 @@ SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, DO J = K + 1, MINMNFACT TAU( J ) = CZERO END DO - - DO J = 1 , MINMNFACT - WRITE(*,*) " _#### END ZLAQP2RK before return", - $ " (J,TAU(J))", - $ J, TAU( J ) - END DO - - - WRITE(*,*) - WRITE(*,*) " _#### Exit ZLAQP2RK " - WRITE(*,*) " (K, MAXC2NRMK, RELMAXC2NRMK)", - $ K, MAXC2NRMK, RELMAXC2NRMK - WRITE(*,*) - * RETURN * diff --git a/SRC/zlaqp3rk.f b/SRC/zlaqp3rk.f index ce729adfa6..1b96e7dcc7 100755 --- a/SRC/zlaqp3rk.f +++ b/SRC/zlaqp3rk.f @@ -448,12 +448,6 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, NB = MIN( NB, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) HUGEVAL = DLAMCH( 'Overflow' ) - - WRITE(*,*) "$$$$_$$$$ Enter ZLAQP3RK " - WRITE(*,*) " (M, N, NRHS, IOFFSET, NB, KP1, MAXC2NRM)", - $ M, N, NRHS, IOFFSET, NB, KP1, MAXC2NRM - - * * Compute factorization in a while loop over NB columns, * K is the column index in the block A(1:M,1:N). @@ -552,10 +546,6 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * routine. * IF( MAXC2NRMK.EQ.ZERO ) THEN - - - WRITE(*,*) "$$$$$$ ZLAQP3RK zero submatrix, IOFFSET, K= ", - $ IOFFSET, K * DONE = .TRUE. * @@ -565,10 +555,6 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in * the original whole matrix A_orig. -* - WRITE(*,*) - $ "$$$$$$$$ ZLAQP3RK zero submatrix (ABSTOL, K)= ", - $ ABSTOL, K * KB = K - 1 IF = I - 1 @@ -586,12 +572,7 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. * IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN - - - WRITE(*,*) "$$$$$$$$$$ ZLAQP3RK zero submatrix", - $ " block reflector (M-IF, NRHS, KB)", - $ M-IF, NRHS, KB - +* CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) @@ -656,13 +637,7 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * KB = K - 1 IF = I - 1 - - WRITE(*,*) "$$$$$$$$$$ ZLAQP3RK condition for", - $ " ABSTOL or RELTOL (ABSTOL, RELTOL),", - $ " (MAXC2NRMK, RELMAXC2NRMK)", - $ ABSTOL, RELTOL, MAXC2NRMK, RELMAXC2NRMK - - +* * Apply the block reflector to the residual of the * matrix A and the residual of the right hand sides B, if * the residual matrix and and/or the residual of the right @@ -674,11 +649,7 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. * IF( KB.LT.MINMNUPDT ) THEN - - WRITE(*,*) "$$$$$$$$$$ ZLAQP3RK ABSTOL or RELTOL", - $ " block reflector (M-IF, N+NRHS-KB, KB)", - $ M-IF, N+NRHS-KB, KB - +* CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-IF, N+NRHS-KB, KB,-CONE, A( IF+1, 1 ), LDA, $ F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA ) @@ -785,9 +756,6 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, KB = K - 1 IF = I - 1 INFO = K - - WRITE(*,*) "## ZLAQP2RK ((TAU is NaN)) (K, INFO),TAU", - $ K, INFO, TAU(K) * * Set MAXC2NRMK and RELMAXC2NRMK to NaN. * @@ -934,11 +902,6 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - * A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. * - WRITE(*,*) " _$$$$ ZLAQP3RK A before ZGEMM" - WRITE(*,*) " ( KB, IF, MINMNUPDT, NRHS )", - $ KB, IF, MINMNUPDT, NRHS - - IF( KB.LT.MINMNUPDT ) THEN CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-IF, N+NRHS-KB, KB, -CONE, A( IF+1, 1 ), LDA, @@ -949,20 +912,7 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * Loop over the index of the difficult columns from the largest * to the smallest index. * - - WRITE(*,*) " _$$$$ ZLAQP3RK A after ZGEMM" - DO J = 1, M - WRITE(*,*) - $ A(J,1), A(J,2), - $ A(J,3), A(J,4), - $ A(J, 5), A(J,6) - END DO - WRITE(*,*) - - DO WHILE( LSTICC.GT.0 ) - - WRITE(*,*) " _$$$$ ZLAQP3RK inside bad norm updating" * * LSTICC is the index of the last difficult column is greater * than 1. @@ -986,20 +936,6 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, LSTICC = ITEMP * END DO - - DO J = 1 , MINMNFACT - WRITE(*,*) " _$$$$ END ZLAQP3RK before return", - $ " (J,TAU(J))", - $ J, TAU( J ) - END DO - - - WRITE(*,*) - WRITE(*,*) " _$$$$ Exit ZLAQP2RK " - WRITE(*,*) " (KB, MAXC2NRMK, RELMAXC2NRMK)", - $ KB, MAXC2NRMK, RELMAXC2NRMK - WRITE(*,*) - * RETURN * From d086a3d5b88b3730b67f49393032126a2d23bbf6 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 088/106] DOWNDATED comments in LIN/zchkqp3rk.f --- TESTING/LIN/zchkqp3rk.f | 141 +--------------------------------------- 1 file changed, 1 insertion(+), 140 deletions(-) diff --git a/TESTING/LIN/zchkqp3rk.f b/TESTING/LIN/zchkqp3rk.f index 2e78f99da9..73b4d39974 100644 --- a/TESTING/LIN/zchkqp3rk.f +++ b/TESTING/LIN/zchkqp3rk.f @@ -319,14 +319,6 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * IF( .NOT.DOTYPE( IMAT ) ) $ CYCLE - - WRITE(*,*) "(4) ____ ____ ____ ____ Loop for " - WRITE(*,*) "IMAT, DOTYPE(IMAT), M, N, NRHS = ", - $ IMAT, DOTYPE(IMAT), M, N, NRHS - - - - * * The type of distribution used to generate the random * eigen-/singular values: @@ -363,8 +355,6 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, DO I = 1, MINMN S( I ) = ZERO END DO - - WRITE(*,*) "GENERATED CZERO MATRIX" * ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 ) $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN @@ -490,9 +480,6 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * * 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) * to zero. - - WRITE(*,*) "( M,NB_ZERO, LDA before ZLASET", - $ M, NB_ZERO, LDA * CALL ZLASET( 'Full', M, NB_ZERO, CZERO, CZERO, $ COPYA, LDA ) @@ -505,21 +492,13 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ ANORM, MODE, CNDNUM, DIST ) * SRNAMT = 'ZLATMS' - - WRITE(*,*) "Generate DLAMTS matrix (M,NB_GEN)=", - $ M, NB_GEN - +* IND_OFFSET_GEN = NB_ZERO * LDA * CALL ZLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, $ CNDNUM, ANORM, KL, KU, 'No packing', $ COPYA( IND_OFFSET_GEN + 1 ), LDA, $ WORK, INFO ) - - WRITE(*,*) "Singular val after mat generation S=" - WRITE(*,*) - $ S(1), S(2), S(3), S(4), - $ S(5), S(6), S(7), S(8) * * Check error code from ZLATMS. * @@ -529,18 +508,6 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ NERRS, NOUT ) CYCLE END IF - - WRITE(*,*) "Matrix COPYA after", - $ " generation N_ZERO and N_GEN" - DO I = 1, M - WRITE(*,*) - $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), - $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), - $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I), - $ COPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) - END DO - - * * 3) Swap the gererated colums from the right side * NB_GEN-size block in COPYA into correct column @@ -592,39 +559,12 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * The total number of singular values is MINMN. * MINMNB_GEN = MIN( M, NB_GEN ) - - WRITE(*,*) "Singular values MINB_GEN=", MINMNB_GEN - WRITE(*,*) "Singular values before ordering S=" - WRITE(*,*) - $ S(1), S(2), S(3), S(4), - $ S(5), S(6), S(7), S(8) * CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) - WRITE(*,*) "Singular values after ordering S=" - WRITE(*,*) - $ S(1), S(2), S(3), S(4), - $ S(5), S(6), S(7), S(8) - DO I = MINMNB_GEN+1, MINMN - WRITE(*,*) "Singular values to ZERO out I=", I S( I ) = ZERO END DO - - WRITE(*,*) "Matrix with ZERO columnms COPYA" - DO I = 1, M - WRITE(*,*) - $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), - $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), - $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I), - $ COPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) - END DO - - - WRITE(*,*) "Matrix with ZERO columns ordering of S=" - WRITE(*,*) - $ S(1), S(2), S(3), S(4), - $ S(5), S(6), S(7), S(8) * ELSE * @@ -632,21 +572,6 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * CYCLE END IF -* - WRITE(*,*) "AFTER GENERATING COPYA" - DO I = 1, M - WRITE(*,*) - $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), - $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), - $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I) -** $ C,OPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) - END DO - WRITE(*,*) "AFTER GENERATING COPYA, S=" - WRITE(*,*) - $ S(1), S(2), S(3), S(4), - $ S(5), S(6) -** $ , S(7), S(8) - * * Initialize a copy array for a pivot array for DGEQP3RK. * @@ -662,22 +587,12 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) -* - - WRITE(*,*) "(5) ____ ____ ____ ____ ____ Loop for NB,NX=", - $ NB, 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 KMAX = 0, MIN(M,N)+1 - - - WRITE(*,*) "(6) ____ ____ ____ ____ ____" , - $ " ____ Loop for KMAX=", KMAX * * Get a working copy of COPYA into A( 1:M,1:N ). * Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). @@ -696,29 +611,6 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * ABSTOL = -1.0 RELTOl = -1.0 - - - WRITE(*,*) "(BEGIN) B VALUE OF B after COPYB into B" - - DO I = 1, LDA - WRITE(*,*) - $ B((1-1)*LDA+I), B((2-1)*LDA+I), - $ B((3-1)*LDA+I), B((4-1)*LDA+I), - $ B((5-1)*LDA+I), B((6-1)*LDA+I) -* $ ,B((7-1)*LDA+I), B((8-1)*LDA+I) -* $ ,B((9-1)*LDA+I), B((10-1)*LDA+I) -* $ ,B((11-1)*LDA+I), B((12-1)*LDA+I) - END DO - - WRITE(*,*) - WRITE(*,*) "(BEGIN) A after COPYA and COPYB into A" - DO I = 1, LDA - WRITE(*,*) - $ A((1-1)*LDA+I), A((2-1)*LDA+I), - $ A((3-1)*LDA+I), A((4-1)*LDA+I), - $ A((5-1)*LDA+I), A((6-1)*LDA+I) - END DO - WRITE(*,*) * * Compute the QR factorization with pivoting of A * @@ -733,31 +625,6 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ RELMAXC2NRMK, IWORK( N+1 ), TAU, $ WORK, LW, RWORK, IWORK( 2*N+1 ), $ INFO ) - - WRITE(*,*) - WRITE(*,*) "(END) A after ZGEQP3RK" - DO I = 1, LDA - WRITE(*,*) - $ A((1-1)*LDA+I), A((2-1)*LDA+I), - $ A((3-1)*LDA+I), A((4-1)*LDA+I), - $ A((5-1)*LDA+I), A((6-1)*LDA+I) - END DO - WRITE(*,*) - - WRITE(*,*) "TAU after ZGEQP3RK" - WRITE(*,*) - $ TAU(1), TAU(2), TAU(3), TAU(4), - $ TAU(5), TAU(6) - WRITE(*,*) - - WRITE(*,*) "JPIV after ZGEQP3RK", - $ IWORK(N+1), IWORK(N+2), IWORK(N+3), IWORK(N+4), - $ IWORK(N+5), IWORK(N+6) - WRITE(*,*) -* - WRITE(*,*) "INFO after ZGEQP3RK" - WRITE(*,*) INFO - WRITE(*,*) * * Check error code from ZGEQP3RK. * @@ -766,12 +633,6 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ M, N, NX, -1, NB, IMAT, $ NFAIL, NERRS, NOUT ) * - - - WRITE(*,*) "After ZGEQP3RK, KFACT, MAX2N, REL2N", - $ KFACT, MAXC2NRMK, RELMAXC2NRMK - - IF( KFACT.EQ.MINMN ) THEN * * Compute test 1: From 349a295b93655ebde6179e0bc5d305667467e5f8 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 089/106] removed one comment sign * in SRC/zlaqp3rk.f --- SRC/zlaqp3rk.f | 2 -- 1 file changed, 2 deletions(-) diff --git a/SRC/zlaqp3rk.f b/SRC/zlaqp3rk.f index 1b96e7dcc7..0381e10d30 100755 --- a/SRC/zlaqp3rk.f +++ b/SRC/zlaqp3rk.f @@ -572,7 +572,6 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. * IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN -* CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) @@ -649,7 +648,6 @@ SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. * IF( KB.LT.MINMNUPDT ) THEN -* CALL ZGEMM( 'No transpose', 'Conjugate transpose', $ M-IF, N+NRHS-KB, KB,-CONE, A( IF+1, 1 ), LDA, $ F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA ) From c64027aa5edd4f1ea2a349a3cb321a1eb77c44f0 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 090/106] DOWNDATED commnets in SRC/dgeqp3rk.f SRC/dlaqp2rk.f SRC/dlaqp3rk.f --- SRC/dgeqp3rk.f | 41 +---------------------------------------- SRC/dlaqp2rk.f | 9 --------- SRC/dlaqp3rk.f | 35 +---------------------------------- 3 files changed, 2 insertions(+), 83 deletions(-) diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 8571f84773..090e276122 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -734,13 +734,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, WORK( J ) = DNRM2( M, A( 1, J ), 1 ) WORK( N+J ) = WORK( J ) END DO - - WRITE(*,*) - WRITE(*,*) "===== DGEQP3RK 2NORM =" - WRITE(*,*) - $ WORK( 1 ), WORK( 2 ), WORK( 3 ), WORK( 4 ), - $ WORK( 5 ), WORK( 6 ), WORK( 7 ), WORK( 8 ) - WRITE(*,*) * * ================================================================== * @@ -749,8 +742,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * KP1 = IDAMAX( N, WORK( 1 ), 1 ) MAXC2NRM = WORK( KP1 ) - WRITE(*,*) "======= DGEQP3RK ((( before NaN in MATRIX ))) KP1=", - $ KP1 * * ==================================================================. * @@ -760,8 +751,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * to the column number where the first NaN is found and return * from the routine. * - WRITE(*,*) "======= DGEQP3RK ((( NaN in MATRIX ))) ====" - K = 0 INFO = KP1 * @@ -783,8 +772,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * Check is the matrix A is a zero matrix, set array TAU and * return from the routine. * - WRITE(*,*) "======= DGEQP3RK ((( ZERO MATRIX ))) ====" - K = 0 MAXC2NRMK = ZERO RELMAXC2NRMK = ZERO @@ -947,10 +934,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * * Factorize JB columns among the columns A(J:N). * - WRITE(*,*) - WRITE(*,*) "===== DGEQP3RK loop before block(IOFFSET, JB)=", - $ J-1, JB - CALL DLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, @@ -959,10 +942,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), $ N+NRHS-J+1, IWORK, IINFO ) * - - WRITE(*,*) "======= DGEQP3RK loop after block (JBF)=", - $ JBF -* * Set INFO on the first occurence of Inf. * IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN @@ -1039,9 +1018,6 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, K = J - 1 + KF * * Set INFO on the first exception occurence. -* - WRITE(*,*) "======= DGEQP3RK after call to DLAQP2RK INFO=", - $ INFO * * Set INFO on the first exception occurence of Inf or NaN, * (NaN takes precedence over Inf). @@ -1078,22 +1054,7 @@ SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, DO J = K + 1, MINMN TAU( J ) = ZERO END DO - - - WRITE(*,*) - WRITE(*,*) "===== END DGEQP3RK compute low rank ", - $ "(MAXC2NRMK, RELMAXC2NRMK)=", - $ MAXC2NRMK, RELMAXC2NRMK - - ELSE - MAXC2NRMK = ZERO - RELMAXC2NRMK = ZERO - - WRITE(*,*) - WRITE(*,*) "===== END DGEQP3RK compute full rank ", - $ "(MAXC2NRMK, RELMAXC2NRMK)=", - $ MAXC2NRMK, RELMAXC2NRMK - +* END IF * * END IF( J.LE.JMAX ) THEN diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 0ca1aed9e5..3fd29e2673 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -389,10 +389,6 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, KMAX = MIN( KMAX, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) HUGEVAL = DLAMCH( 'Overflow' ) - - WRITE(*,*) "####_#### Enter DLAQP2RK " - WRITE(*,*) " (M, N, NRHS, IOFFSET, KMAX, KP1, MAXC2NRM)", - $ M, N, NRHS, IOFFSET, KMAX, KP1, MAXC2NRM * * Compute the factorization, KK is the lomn loop index. * @@ -410,8 +406,6 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * KP = KP1 - - WRITE(*,*) "## ## DLAQP2RK IOFFSET=0, first column KP=",KP * * ============================================================ * @@ -577,8 +571,6 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, ELSE TAU( KK ) = ZERO END IF - - WRITE(*,*) "## DLAQP2RK (KK, TAU(Kk) )=", KK, TAU(KK) * * Check if TAU(KK) contains NaN, set INFO parameter * to the column number where NaN is found and return from @@ -593,7 +585,6 @@ SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, IF( DISNAN( TAU(KK) ) ) THEN K = KK - 1 INFO = KK - WRITE(*,*) "## ## DLAQP2RK ((TAU is NaN)) (KK, INFO)", KK, INFO * * Set MAXC2NRMK and RELMAXC2NRMK to NaN. * diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 4329a14500..e247856787 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -444,12 +444,6 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, NB = MIN( NB, MINMNFACT ) TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) HUGEVAL = DLAMCH( 'Overflow' ) - - WRITE(*,*) "$$$$_$$$$ Enter DLAQP3RK " - WRITE(*,*) " (M, N, NRHS, IOFFSET, NB, KP1, MAXC2NRM)", - $ M, N, NRHS, IOFFSET, NB, KP1, MAXC2NRM - - * * Compute factorization in a while loop over NB columns, * K is the column index in the block A(1:M,1:N). @@ -548,10 +542,6 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * routine. * IF( MAXC2NRMK.EQ.ZERO ) THEN - - - WRITE(*,*) "$$$$$$ DLAQP3RK zero submatrix, IOFFSET, K= ", - $ IOFFSET, K * DONE = .TRUE. * @@ -561,10 +551,6 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * Set IF, the number of processed rows in the block, which * is the same as the number of processed rows in * the original whole matrix A_orig. -* - WRITE(*,*) - $ "$$$$$$$$ DLAQP3RK zero submatrix (ABSTOL, K)= ", - $ ABSTOL, K * KB = K - 1 IF = I - 1 @@ -582,12 +568,6 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. * IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN - - - WRITE(*,*) "$$$$$$$$$$ DLAQP3RK zero submatrix", - $ " block reflector (M-IF, NRHS, KB)", - $ M-IF, NRHS, KB - CALL DGEMM( 'No transpose', 'Transpose', $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) @@ -652,13 +632,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * KB = K - 1 IF = I - 1 - - WRITE(*,*) "$$$$$$$$$$ DLAQP3RK condition for", - $ " ABSTOL or RELTOL (ABSTOL, RELTOL),", - $ " (MAXC2NRMK, RELMAXC2NRMK)", - $ ABSTOL, RELTOL, MAXC2NRMK, RELMAXC2NRMK - - +* * Apply the block reflector to the residual of the * matrix A and the residual of the right hand sides B, if * the residual matrix and and/or the residual of the right @@ -670,11 +644,6 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, * A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. * IF( KB.LT.MINMNUPDT ) THEN - - WRITE(*,*) "$$$$$$$$$$ DLAQP3RK ABSTOL or RELTOL", - $ " block reflector (M-IF, N+NRHS-KB, KB)", - $ M-IF, N+NRHS-KB, KB - CALL DGEMM( 'No transpose', 'Transpose', $ M-IF, N+NRHS-KB, KB,-ONE, A( IF+1, 1 ), LDA, $ F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA ) @@ -767,8 +736,6 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, KB = K - 1 IF = I - 1 INFO = K - - WRITE(*,*) "$$ $$ DLAQP3RK ((TAU is NaN)) (K, INFO)", K, INFO * * Set MAXC2NRMK and RELMAXC2NRMK to NaN. * From 5bcd5859e51f4a95a4a79efc337a317d8d6508b5 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 091/106] added comments symbols '*' in TESTING/LIN/zchkqp3rk.f --- TESTING/LIN/zchkqp3rk.f | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/TESTING/LIN/zchkqp3rk.f b/TESTING/LIN/zchkqp3rk.f index 73b4d39974..55cbdd787f 100644 --- a/TESTING/LIN/zchkqp3rk.f +++ b/TESTING/LIN/zchkqp3rk.f @@ -720,10 +720,11 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, DTEMP = (( ABS( A( (J-1)*M+J ) ) - $ ABS( A( (J)*M+J+1 ) ) ) / $ ABS( A(1) ) ) - +* IF( DTEMP.LT.ZERO ) THEN RESULT( 4 ) = BIGNUM END IF +* END DO * * Print information about the tests that did not From bd42f8ebafaecd331f3b29f920e9e08adfdb612d Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 092/106] DOWNDATED comments in TESTING/LIN/dchkqp3rk.f --- TESTING/LIN/dchkqp3rk.f | 345 +--------------------------------------- 1 file changed, 4 insertions(+), 341 deletions(-) diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index 7f1e687172..b93ab67683 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -222,8 +222,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, $ NRUN, NX, T DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, - $ DTEMP, MAXC2NRMK, RELMAXC2NRMK, - $ TEST1, TEST2 + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK * .. * .. Local Arrays .. INTEGER ISEED( 4 ), ISEEDY( 4 ) @@ -275,16 +274,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * M = MVAL( IM ) LDA = MAX( 1, M ) - - TEST1 = DLAMCH('Overflow') - TEST2 = DLAPY2(TEST1,TEST1) - -* - WRITE(*,*) "TEST1=DLAMCH('Overflow'),", - $ " TEST2=DLAPY2(TEST1,TEST1), TEST2.GT.TEST1", - $ TEST1, TEST2, TEST2.GT.TEST1 - - WRITE(*,*) "(1) ______ Loop for M=", M * DO IN = 1, NN * @@ -294,16 +283,9 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, MINMN = MIN( M, N ) LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), $ M*N + 2*MINMN + 4*N ) - - -* - WRITE(*,*) "(2) ____ ____ Loop for N=", N * DO INS = 1, NNS NRHS = NSVAL( INS ) - - WRITE(*,*) "(3) ____ ____ ____ Loop for NRHS=", - $ NRHS * * Set up parameters with DLATB4 and generate * M-by-NRHS B matrix with DLATMS. @@ -329,16 +311,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ NOUT ) CYCLE END IF - - - DO I = 1, LDA - WRITE(*,*) "======== Generating COPYB", - $ COPYB((1-1)*LDA+I), COPYB((2-1)*LDA+I), - $ COPYB((3-1)*LDA+I), COPYB((4-1)*LDA+I), - $ COPYB((5-1)*LDA+I), COPYB((6-1)*LDA+I), - $ COPYB((7-1)*LDA+I), COPYB((8-1)*LDA+I) - END DO - * DO IMAT = 1, NTYPES * @@ -346,13 +318,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * IF( .NOT.DOTYPE( IMAT ) ) $ CYCLE - - WRITE(*,*) "(4) ____ ____ ____ ____ Loop for ", - $ "IMAT, DOTYPE(IMAT)= ", IMAT, DOTYPE(IMAT) - - $ - - * * The type of distribution used to generate the random * eigen-/singular values: @@ -389,8 +354,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, DO I = 1, MINMN S( I ) = ZERO END DO - - WRITE(*,*) "GENERATED ZERO MATRIX" * ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 ) $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN @@ -516,9 +479,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * * 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) * to zero. - - WRITE(*,*) "( M,NB_ZERO, LDA before DLASET", - $ M, NB_ZERO, LDA * CALL DLASET( 'Full', M, NB_ZERO, ZERO, ZERO, $ COPYA, LDA ) @@ -531,21 +491,13 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ ANORM, MODE, CNDNUM, DIST ) * SRNAMT = 'DLATMS' - - WRITE(*,*) "Generate DLAMTS matrix (M,NB_GEN)=", - $ M, NB_GEN - +* 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 ) - - WRITE(*,*) "Singular val after mat generation S=" - WRITE(*,*) - $ S(1), S(2), S(3), S(4), - $ S(5), S(6), S(7), S(8) * * Check error code from DLATMS. * @@ -555,18 +507,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ NERRS, NOUT ) CYCLE END IF - - WRITE(*,*) "Matrix COPYA after", - $ " generation N_ZERO and N_GEN" - DO I = 1, M - WRITE(*,*) - $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), - $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), - $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I), - $ COPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) - END DO - - * * 3) Swap the gererated colums from the right side * NB_GEN-size block in COPYA into correct column @@ -618,39 +558,10 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * The total number of singular values is MINMN. * MINMNB_GEN = MIN( M, NB_GEN ) - - WRITE(*,*) "Singular values MINB_GEN=", MINMNB_GEN - WRITE(*,*) "Singular values before ordering S=" - WRITE(*,*) - $ S(1), S(2), S(3), S(4), - $ S(5), S(6), S(7), S(8) * - CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) - - WRITE(*,*) "Singular values after ordering S=" - WRITE(*,*) - $ S(1), S(2), S(3), S(4), - $ S(5), S(6), S(7), S(8) - DO I = MINMNB_GEN+1, MINMN - WRITE(*,*) "Singular values to ZERO out I=", I S( I ) = ZERO END DO - - WRITE(*,*) "Matrix with ZERO columnms COPYA" - DO I = 1, M - WRITE(*,*) - $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), - $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), - $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I), - $ COPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) - END DO - - - WRITE(*,*) "Matrix with ZERO columns ordering of S=" - WRITE(*,*) - $ S(1), S(2), S(3), S(4), - $ S(5), S(6), S(7), S(8) * ELSE * @@ -658,20 +569,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * CYCLE END IF -* - WRITE(*,*) "AFTER GENERATING COPYA" - DO I = 1, M - WRITE(*,*) - $ COPYA((1-1)*LDA+I), COPYA((2-1)*LDA+I), - $ COPYA((3-1)*LDA+I), COPYA((4-1)*LDA+I), - $ COPYA((5-1)*LDA+I), COPYA((6-1)*LDA+I), - $ COPYA((7-1)*LDA+I), COPYA((8-1)*LDA+I) - END DO - WRITE(*,*) "AFTER GENERATING COPYA, S=" - WRITE(*,*) - $ S(1), S(2), S(3), S(4), - $ S(5), S(6), S(7), S(8) - * * Initialize a copy array for a pivot array for DGEQP3RK. * @@ -687,21 +584,12 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, CALL XLAENV( 1, NB ) NX = NXVAL( INB ) CALL XLAENV( 3, NX ) -* - WRITE(*,*) "(5) ____ ____ ____ ____ ____ Loop for NB,NX=", - $ NB, 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 KMAX = 0, MIN(M,N)+1 - - - - WRITE(*,*) "(6) ____ ____ ____ ____ ____" , - $ " ____ Loop for KMAX=", KMAX * * Get a working copy of COPYA into A( 1:M,1:N ). * Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). @@ -712,22 +600,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * for the routine. * CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) - - WRITE(*,*) " ____ ____ ____ ____ ____ ____ set NaN", - $ " in mat A after copy" - - - -* TEST1 = 1.0 -* TEST2 = 1.0 -* A((3-1)*LDA+3) = 0.0/(TEST1-TESt2) - -** TEST1 = DLAMCH('Overflow') - -** A((3-1)*LDA+3) = TEST1 *TEST1 -** A((3-1)*LDA+5) = - - CALL DLACPY( 'All', M, NRHS, COPYB, LDA, $ A( LDA*N + 1 ), LDA ) CALL DLACPY( 'All', M, NRHS, COPYB, LDA, @@ -736,132 +608,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * ABSTOL = -1.0 RELTOL = -1.0 - - - -* -* ABSTOL = 1.0D+300 -* RELTOL = 2.0 -* -** ABSTOL = -1.0 -** RELTOL = 0.3 - -* -* 310 < dtest_my02.in -* (To exit after 2 cols) -* - -** ABSTOL = 7.26D-004 -** RELTOL = -1.0 -* -* 310 < dtest_my12.in (also < dtest_my02.in ) -* (ABSTOL = 1.8302569483745663E-004) -* to exit after the second column - -* ABSTOL = 1.82D-004 -* RELTOL = -1.0 - - -* -* Process 1 column -* -** ABSTOL = 0.63 -** RELTOL = -1.0 - -* -* Process 2 columns -* -* ABSTOL = 0.49 -* RELTOL = -1.0 - -** ABSTOL = -1.0 -** RELTOL = -1.0 - -** ABSTOL = 0.7 -** RELTOL = -1.0 - -* ABSTOL = -1.0 -* RELTOL = -1.0 - -* ABSTOL = 1.1405204575311260E-004 -* RELTOL = -1.0 - -* (5x5) whole matrix -* ABSTOL = 0.66704678404750084 -* RELTOL = -1.0 - - -* (5x5) only ABSTOL for (4x4) submatrix -* ABSTOL = 1.1405304575311260E-004 -* RELTOL = -1.0 -* -* (5x5) only ABSTOL for (3x3) submatrix -* ABSTOL = 6.0481785131836600E-008 -* RELTOL = -1.0 - -* (5x5) only ABSTOL for (2x2) submatrix -* ABSTOL = 1.3084410232299372E-011 -* RELTOL = -1.0 - -* (5x5) only ABSTOL for (1x1) submatrix -* ABSTOL = 3.8085269032348996E-015 -* RELTOL = -1.0 - -* -* -* (5x5) only ABSTOL for (1x1) submatrix -* ABSTOL = -1.0 -* RELTOL = 5.7095334155208096E-015 - - - WRITE(*,*) "inside the test M=", M, " N=", N, - $ " IMAT=", IMAT, " NB=", NB," NX=", NX - WRITE(*,*) "NRHS=", NRHS, " KMAX=", KMAX, - $ " ABSTOL=", ABSTOL, " RELTOL=", RELTOL - WRITE(*,*) " " - - WRITE(*,*) "B(BEGIN) VALUE OF B after COPYB into B" - - DO I = 1, LDA - WRITE(*,*) - $ B((1-1)*LDA+I), B((2-1)*LDA+I), - $ B((3-1)*LDA+I), B((4-1)*LDA+I), - $ B((5-1)*LDA+I), B((6-1)*LDA+I), - $ B((7-1)*LDA+I), B((8-1)*LDA+I), - $ B((9-1)*LDA+I), B((10-1)*LDA+I) -* $ ,B((11-1)*LDA+I), B((12-1)*LDA+I) - END DO -* -* - WRITE(*,*) "A(BEGIN) AFTER copying COPYA", - $ " and COPY B into A" - DO I = 1, LDA - WRITE(*,*) - $ A((1-1)*LDA+I), A((2-1)*LDA+I), - $ A((3-1)*LDA+I), A((4-1)*LDA+I), - $ A((5-1)*LDA+I), A((6-1)*LDA+I), - $ A((7-1)*LDA+I), A((8-1)*LDA+I), - $ A((9-1)*LDA+I), A((10-1)*LDA+I) -* $ ,A((11-1)*LDA+I), A((12-1)*LDA+I) - END DO - WRITE(*,*) " " - - WRITE(*,*) "TAU before DGEQP3RK" - WRITE(*,*) - $ TAU(1), TAU(2), TAU(3), TAU(4), - $ TAU(5), TAU(6), TAU(7), TAU(8) - WRITE(*,*) " " - - WRITE(*,*) "jPIV before DGEQP3RK" - WRITE(*,*) - $ IWORK(N+1), IWORK(2), IWORK(3), IWORK(4), - $ IWORK(5), IWORK(6), IWORK(7), IWORK(8) - WRITE(*,*) " " - - - - -* * * Compute the QR factorization with pivoting of A * @@ -876,33 +622,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ RELMAXC2NRMK, IWORK( N+1 ), TAU, $ WORK, LW, IWORK( 2*N+1 ), INFO ) * -* - WRITE(*,*) "A after DGEQP3RK" - DO I = 1, LDA - WRITE(*,*) - $ A((1-1)*LDA+I), A((2-1)*LDA+I), - $ A((3-1)*LDA+I), A((4-1)*LDA+I), - $ A((5-1)*LDA+I), A((6-1)*LDA+I), - $ A((7-1)*LDA+I), A((8-1)*LDA+I), - $ A((9-1)*LDA+I), A((10-1)*LDA+I) -* $ ,A((11-1)*LDA+I), A((12-1)*LDA+I) - END DO - WRITE(*,*) "TAU after DGEQP3RK" - WRITE(*,*) - $ TAU(1), TAU(2), TAU(3), TAU(4), - $ TAU(5), TAU(6), TAU(7), TAU(8) - WRITE(*,*) - - WRITE(*,*) "JPIV after DGEQP3RK" - WRITE(*,*) - $ IWORK(N+1), IWORK(N+2), IWORK(N+3), IWORK(N+4), - $ IWORK(N+5), IWORK(N+6), IWORK(N+7), IWORK(N+8) - WRITE(*,*) - - WRITE(*,*) "INFO after DGEQP3RK" - WRITE(*,*) INFO - WRITE(*,*) -* * Check error code from DGEQP3RK. * IF( INFO.LT.0 ) @@ -924,9 +643,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * * 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) * - WRITE(*,*) "After DGEQP3RK, KFACT, MAX2N, REL2N", - $ KFACT, MAXC2NRMK, RELMAXC2NRMK - IF( KFACT.EQ.MINMN ) THEN * RESULT( 1 ) = DQRT12( M, N, A, LDA, S, WORK, @@ -948,12 +664,6 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * END IF * -* -* - DO I = 1, MIN(M,N) - WRITE(*,*) "Generated_S(", I, ")=", S(I) - END DO -* * Compute test 2: * * The test returns the ratio: @@ -1002,17 +712,15 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, IF( MIN(KFACT, MINMN).GE.2 ) THEN * DO J = 1, KFACT-1, 1 - WRITE(*,*) " TEST 4: Diagonal (I, A(I), A(I+1) )" - WRITE(*,*) J, ABS( A( (J-1)*M+J ) ), - $ ABS( A( (J)*M+J+1 ) ) DTEMP = (( ABS( A( (J-1)*M+J ) ) - $ ABS( A( (J)*M+J+1 ) ) ) / $ ABS( A(1) ) ) - +* IF( DTEMP.LT.ZERO ) THEN RESULT( 4 ) = BIGNUM END IF +* END DO * * Print information about the tests that did not @@ -1048,38 +756,11 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * IF( MINMN.GT.0 ) THEN * - - WRITE(*,*) - WRITE(*,*) "TEST 5: B before computing Q**T * B" - DO I = 1, LDA - WRITE(*,*) - $ B((1-1)*LDA+I), B((2-1)*LDA+I), - $ B((3-1)*LDA+I), B((4-1)*LDA+I), - $ B((5-1)*LDA+I), B((6-1)*LDA+I), - $ B((7-1)*LDA+I), B((8-1)*LDA+I), - $ B((9-1)*LDA+I), B((10-1)*LDA+I) -* $ ,B((11-1)*LDA+I), B((12-1)*LDA+I) - END DO -* LWORK_DORMQR = MAX(1, NRHS) CALL DORMQR( 'Left', 'Transpose', $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, $ WORK, LWORK_DORMQR, INFO ) * - WRITE(*,*) - WRITE(*,*) "TEST 5: B after computing Q**T * B" -* - DO I = 1, LDA - WRITE(*,*) - $ B((1-1)*LDA+I), B((2-1)*LDA+I), - $ B((3-1)*LDA+I), B((4-1)*LDA+I), - $ B((5-1)*LDA+I), B((6-1)*LDA+I), - $ B((7-1)*LDA+I), B((8-1)*LDA+I), - $ B((9-1)*LDA+I), B((10-1)*LDA+I) -* $ ,B((11-1)*LDA+I), B((12-1)*LDA+I) - END DO - - DO I = 1, NRHS * * Compare N+J-th column of A and J-column of B. @@ -1087,30 +768,12 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, CALL DAXPY( M, -ONE, A( ( N+I-1 )*LDA+1 ), 1, $ B( ( I-1 )*LDA+1 ), 1 ) END DO -* - WRITE(*,*) - WRITE(*,*) "TEST 5: B after B:= A(B) - Q**T * B" -* - DO I = 1, LDA - WRITE(*,*) - $ B((1-1)*LDA+I), B((2-1)*LDA+I), - $ B((3-1)*LDA+I), B((4-1)*LDA+I), - $ B((5-1)*LDA+I), B((6-1)*LDA+I), - $ B((7-1)*LDA+I), B((8-1)*LDA+I), - $ B((9-1)*LDA+I), B((10-1)*LDA+I) -* $ ,B((10-1)*LDA+I), B((11-1)*LDA+I) - END DO * RESULT( 5 ) = $ ABS( $ DLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) / $ ( DBLE( M )*DLAMCH( 'Epsilon' ) ) $ ) - - WRITE(*,*) "TEST 5: DLANGE, RESULT( 5 )", - $ DLANGE( 'One-norm', M, NRHS, B, M, RDUMMY ), - $ RESULT( 5 ) - WRITE(*,*) * * Print information about the tests that did not pass * the threshold. From 10e12a4001c1927602f8fdae63d0ca39c1812bf3 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 093/106] Intrinsic DBLE declaration from DLAQP3RK, since it is not used --- SRC/dlaqp3rk.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index e247856787..ed7296c80a 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -422,7 +422,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP * .. * .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT + INTRINSIC ABS, f, MIN, SQRT * .. * .. External Functions .. LOGICAL DISNAN From 0c440488d96fd2b915d5553952cfb24dbe05c8b6 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 094/106] changed LWORK_DORMQR into LWORK_MQR name in LIN/dchkqp3rk.f LIN/zchkqp3rk.f --- TESTING/LIN/dchkqp3rk.f | 8 ++++---- TESTING/LIN/zchkqp3rk.f | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index b93ab67683..bc5d1d1f59 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -208,7 +208,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, PARAMETER ( NTESTS = 5 ) DOUBLE PRECISION ONE, ZERO, BIGNUM PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, - $ BIGNUM = 1.0D+100 ) + $ BIGNUM = 1.0D+38 ) * .. * .. Local Scalars .. CHARACTER DIST, TYPE @@ -218,7 +218,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ IND_IN, IND_OUT, INS, INFO, $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO, $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, - $ LWORK_DORMQR, M, MINMN, MINMNB_GEN, MODE, N, + $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N, $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, $ NRUN, NX, T DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, @@ -756,10 +756,10 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * IF( MINMN.GT.0 ) THEN * - LWORK_DORMQR = MAX(1, NRHS) + LWORK_MQR = MAX(1, NRHS) CALL DORMQR( 'Left', 'Transpose', $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, - $ WORK, LWORK_DORMQR, INFO ) + $ WORK, LWORK_MQR, INFO ) * DO I = 1, NRHS * diff --git a/TESTING/LIN/zchkqp3rk.f b/TESTING/LIN/zchkqp3rk.f index 55cbdd787f..c3988bcbf6 100644 --- a/TESTING/LIN/zchkqp3rk.f +++ b/TESTING/LIN/zchkqp3rk.f @@ -212,7 +212,7 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, $ CZERO = ( 0.0D+0, 0.0D+0 ), $ CONE = ( 1.0D+0, 0.0D+0 ), - $ BIGNUM = 1.0D+100 ) + $ BIGNUM = 1.0D+38 ) * .. * .. Local Scalars .. CHARACTER DIST, TYPE @@ -222,7 +222,7 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ IND_IN, IND_OUT, INS, INFO, $ ISTEP, J, J_INC, J_FIRST_NZ, JB_ZERO, $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, - $ LWORK_ZUNMQR, M, MINMN, MINMNB_GEN, MODE, N, + $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N, $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, $ NRUN, NX, T DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, @@ -760,10 +760,10 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, * IF( MINMN.GT.0 ) THEN * - LWORK_ZUNMQR = MAX(1, NRHS) + LWORK_MQR = MAX(1, NRHS) CALL ZUNMQR( 'Left', 'Conjugate transpose', $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, - $ WORK, LWORK_ZUNMQR, INFO ) + $ WORK, LWORK_MQR, INFO ) * DO I = 1, NRHS * From 540e4eb0a91c51c716b0c0ef962bcab999f18571 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 095/106] Changed ArrayE allocation from static to dynamic --- TESTING/LIN/dchkaa.F | 24 ++++++++++++++---------- TESTING/LIN/zchkaa.F | 40 ++++++++++++++++++++++------------------ 2 files changed, 36 insertions(+), 28 deletions(-) diff --git a/TESTING/LIN/dchkaa.F b/TESTING/LIN/dchkaa.F index 915258789d..74077eb94e 100755 --- a/TESTING/LIN/dchkaa.F +++ b/TESTING/LIN/dchkaa.F @@ -150,12 +150,12 @@ PROGRAM DCHKAA $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) - DOUBLE PRECISION E( NMAX ), S( 2*NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus - DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RWORK - DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RWORK, S + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: E + DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK * .. * .. External Functions .. LOGICAL LSAME, LSAMEN @@ -165,13 +165,13 @@ PROGRAM DCHKAA * .. External Subroutines .. EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, $ DCHKORHR_COL, DCHKPB, DCHKPO, DCHKPS, DCHKPP, - $ DCHKPT, DCHKQ3, DCHKQP3RK, DCHKQL, DCHKQR, DCHKRQ, - $ DCHKSP, DCHKSY, DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, - $ DCHKTB, DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, - $ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT, - $ DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK, - $ DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, DCHKQRTP, - $ DCHKLQT,DCHKTSQR + $ DCHKPT, DCHKQ3, DCHKQP3RK, DCHKQL, DCHKQR, + $ DCHKRQ, DCHKSP, DCHKSY, DCHKSY_ROOK, DCHKSY_RK, + $ DCHKSY_AA, DCHKTB, DCHKTP, DCHKTR, DCHKTZ, + $ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO, + $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, + $ DDRVSY_RK, DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, + $ DCHKQRTP, DCHKLQT,DCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -198,6 +198,10 @@ PROGRAM DCHKAA IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( WORK( NMAX, 3*NMAX+MAXRHS+30 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( E( NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * diff --git a/TESTING/LIN/zchkaa.F b/TESTING/LIN/zchkaa.F index edbf167c58..57d71833f9 100644 --- a/TESTING/LIN/zchkaa.F +++ b/TESTING/LIN/zchkaa.F @@ -154,11 +154,11 @@ PROGRAM ZCHKAA $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) - COMPLEX*16 E( NMAX ) -* -* .. Allocatable Arrays .. +* .. +* .. Allocatable Arrays .. INTEGER AllocateStatus - DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE:: RWORK, S + DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE:: RWORK, S + COMPLEX*16, DIMENSION(:), ALLOCATABLE :: E COMPLEX*16, DIMENSION(:,:), ALLOCATABLE:: A, B, WORK * .. * .. External Functions .. @@ -170,15 +170,16 @@ PROGRAM ZCHKAA EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE, $ ZCHKHE_ROOK, ZCHKHE_RK, ZCHKHE_AA, ZCHKHP, $ ZCHKLQ, ZCHKUNHR_COL, ZCHKPB, ZCHKPO, ZCHKPS, - $ ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQP3RK, ZCHKQL, ZCHKQR, - $ ZCHKRQ, ZCHKSP, ZCHKSY, ZCHKSY_ROOK, ZCHKSY_RK, - $ ZCHKSY_AA, ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, - $ ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHE_ROOK, - $ ZDRVHE_RK, ZDRVHE_AA, ZDRVHE_AA_2STAGE, ZDRVHP, - $ ZDRVLS, ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, - $ ZDRVSP, ZDRVSY, ZDRVSY_ROOK, ZDRVSY_RK, - $ ZDRVSY_AA, ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, - $ ZCHKQRTP, ZCHKLQT, ZCHKLQTP, ZCHKTSQR + $ ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQP3RK, ZCHKQL, + $ ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY, ZCHKSY_ROOK, + $ ZCHKSY_RK, ZCHKSY_AA, ZCHKTB, ZCHKTP, ZCHKTR, + $ ZCHKTZ, ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, + $ ZDRVHE_ROOK, ZDRVHE_RK, ZDRVHE_AA, + $ ZDRVHE_AA_2STAGE, ZDRVHP, ZDRVLS, ZDRVPB, + $ ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, + $ ZDRVSY_ROOK, ZDRVSY_RK, ZDRVSY_AA, + $ ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, ZCHKQRTP, + $ ZCHKLQT, ZCHKLQTP, ZCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -197,15 +198,18 @@ PROGRAM ZCHKAA DATA THREQ / 2.0D0 / , INTSTR / '0123456789' / * * .. Allocate memory dynamically .. - ALLOCATE (A ((KDMAX+1) * NMAX, 7), STAT = AllocateStatus) +* + ALLOCATE ( A ( (KDMAX+1) * NMAX, 7 ), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (B (NMAX * MAXRHS, 4), STAT = AllocateStatus) + ALLOCATE ( B ( NMAX * MAXRHS, 4 ), STAT = AllocateStatus) + IF (AllocateStatus /= 0 ) STOP "*** Not enough memory ***" + ALLOCATE ( WORK ( NMAX, NMAX+MAXRHS+10 ), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (WORK (NMAX, NMAX+MAXRHS+10), STAT = AllocateStatus) + ALLOCATE ( E( NMAX ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (S( 2*NMAX ), STAT = AllocateStatus) + ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus) + ALLOCATE ( RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * .. * .. Executable Statements .. From 7019c6345c75617a9b06518fe3286569e0e0e131 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 096/106] added single precision ant testing for truncated QR i.e. SGEQP3RK, SLAQP2RK, SLAQP3RK --- SRC/CMakeLists.txt | 4 +- SRC/Makefile | 4 +- SRC/sgeqp3rk.f | 1070 ++++++++++++++++++++++++++++++++++++ SRC/slaqp2rk.f | 702 +++++++++++++++++++++++ SRC/slaqp3rk.f | 924 +++++++++++++++++++++++++++++++ TESTING/LIN/CMakeLists.txt | 2 +- TESTING/LIN/Makefile | 2 +- TESTING/LIN/schkaa.F | 48 +- TESTING/LIN/slatb4.f | 104 ++++ TESTING/LIN/sqpt01.f | 23 +- TESTING/LIN/sqrt11.f | 4 +- TESTING/LIN/sqrt12.f | 14 +- TESTING/stest.in | 1 + 13 files changed, 2863 insertions(+), 39 deletions(-) create mode 100755 SRC/sgeqp3rk.f create mode 100755 SRC/slaqp2rk.f create mode 100755 SRC/slaqp3rk.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index 69195463f5..4a720a4457 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -87,7 +87,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 sgeqr2.f sgeqr2p.f sgeqrf.f sgeqrfp.f sgerfs.f sgerq2.f sgerqf.f + sgeqp3.f sgeqp3rk.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 @@ -102,7 +102,7 @@ set(SLASRC slangb.f slange.f slangt.f slanhs.f slansb.f slansp.f slansy.f slantb.f slantp.f slantr.f slanv2.f slapll.f slapmt.f - slaqgb.f slaqge.f slaqp2.f slaqps.f slaqsb.f slaqsp.f slaqsy.f + slaqgb.f slaqge.f slaqp2.f slaqps.f slaqp2rk.f slaqp3rk.f slaqsb.f slaqsp.f slaqsy.f slaqr0.f slaqr1.f slaqr2.f slaqr3.f slaqr4.f slaqr5.f slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f slarf.f slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f diff --git a/SRC/Makefile b/SRC/Makefile index a98a98f6e2..b769b6351a 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 sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \ + sgeqp3.o sgeqp3rk.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 \ @@ -134,7 +134,7 @@ SLASRC = \ slangb.o slange.o slangt.o slanhs.o slansb.o slansp.o \ slansy.o slantb.o slantp.o slantr.o slanv2.o \ slapll.o slapmt.o \ - slaqgb.o slaqge.o slaqp2.o slaqps.o slaqsb.o slaqsp.o slaqsy.o \ + slaqgb.o slaqge.o slaqp2.o slaqps.o slaqp2rk.o slaqp3rk.o slaqsb.o slaqsp.o slaqsy.o \ slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \ slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \ slarf.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o \ diff --git a/SRC/sgeqp3rk.f b/SRC/sgeqp3rk.f new file mode 100755 index 0000000000..6319892fe8 --- /dev/null +++ b/SRC/sgeqp3rk.f @@ -0,0 +1,1070 @@ +*> \brief \b SGEQP3RK computes a truncated Householder QR factorization with column pivoting of a real m-by-n matrix A by using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ WORK, LWORK, IWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* REAL ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* REAL A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a real +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank of the +*> factor R, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is an N-by-N permutation matrix; +*> Q(K) is an M-by-M orthogonal matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a real M-by-NRHS +*> matrix B with Q(K)**T * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAX, the maximum number of columns +*> KMAX to factorize, i.e. the factorization rank is limited +*> to KMAX. If KMAX >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) to +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> 4) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix R22(K) is a zero matrix in some +*> factorization step K. ( This stopping criterion is implicit. ) +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> To factorize the whole matrix A, use the values +*> KMAX >= min(M,N), ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_residual); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**T * B, the matrix B with the orthogonal +*> transformation Q(K)**T applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M orthogonal matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**T, +*> +*> where 1 <= j <= K and +*> I is an M-by-M identity matrix, +*> tau is a real scalar, +*> v is a real vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e. the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M,N), then this stopping criterion +*> is not used, the routine factorizes columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL +*> +*> The second factorization stopping criterion, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. Let SAFMIN = SLAMCH('S'). +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If ABSTOL chosen above is >= MAXC2NRM, then this +*> stopping criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. The routine +*> returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL +*> +*> The third factorization stopping criterion, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. Let EPS = SLAMCH('E'). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX 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. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. +*> The routine returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend that RELTOL satisfy +*> min( max(M,N)*EPS, sqrt(EPS) ) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of the +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,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(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) If NRHS > 0, the subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**T * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> +*> NOTE: If K = 0, a) the arrays A and B are not modified; +*> b) the array TAU(1:min(M,N)) is set to ZERO, +*> if the matrix A does not contain NaN, +*> otherwise the elements TAU(1:min(M,N)) +*> are undefined; +*> c) the elements of the array JPIV are set +*> as follows: for j = 1:N, JPIV(j) = j. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix R22(K), +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK in the factorization step K would equal +*> R(K+1,K+1) 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 of the residual matrix R22(K) (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK in the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The elements of the array JPIV(1:N) are always set +*> by the routine, for example, even when no columns +*> were factorized, i.e. when K = 0, the elements are +*> set as JPIV(j) = j for j = 1:N. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= min(M,N), only the elements TAU(1:K) of +*> the array TAU are modified by the factorization. +*> After the factorization computed, if no NaN was found +*> during the factorization, the remaining elements +*> TAU(K+1:min(M,N)) are set to zero, otherwise the +*> elements TAU(K+1:min(M,N)) are not set and therefore +*> undefined. +*> ( If K = 0, all elements of TAU are set to zero, if +*> the matrix A does not contain NaN. ) +*> \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. +*. LWORK >= (3*N + NRHS - 1) +*> For optimal performance LWORK >= (2*N + NB*( N+NRHS+1 )), +*> where NB is the optimal block size for SGEQP3RK returned +*> by ILAENV. Minimal block size MINNB=2. +*> +*> NOTE: The decision, whether to use unblocked BLAS 2 +*> or blocked BLAS 3 code is based not only on the dimension +*> LWORK of the availbale workspace WORK, but also also on the +*> matrix A dimension N via crossover point NX returned +*> by ILAENV. (For N less than NX, unblocked code should be +*> used.) +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine SLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> SGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in SGEQP3 routine which uses +*> SLARFG routine to generate Householder reflectors +*> for QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ WORK, LWORK, IWORK, 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 .. + INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS + REAL ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + REAL A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + REAL ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE + INTEGER IINFO, IOFFSET, IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, N_SUB, NB, + $ NBMIN, NX + REAL EPS, HUGEVAL, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL SLAQP2RK, SLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX, ILAENV + REAL SLAMCH, SNRM2 + EXTERNAL SISNAN, SLAMCH, SNRM2, ISAMAX, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( SISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( SISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE +* +* Minimal workspace size in case of using only unblocked +* BLAS 2 code in SLAQP2RK. +* 1) SGEQP3RK and SLAQP2RK: 2*N to store full and partial +* column 2-norms. +* 2) SLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in SLARF subroutine inside SLAQP2RK to apply an +* elementary reflector from the left. +* TOTAL_WORK_SIZE = 3*N + NRHS - 1 +* + IWS = 3*N + NRHS - 1 +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'SGEQP3RK', ' ', M, N, -1, -1 ) +* +* A formula for the optimal workspace size in case of using +* both unblocked BLAS 2 in SLAQP2RK and blocked BLAS 3 code +* in SLAQP3RK. +* 1) SGEQP3RK, SLAQP2RK, SLAQP3RK: 2*N to store full and +* partial column 2-norms. +* 2) SLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in SLARF subroutine to apply an elementary reflector +* from the left. +* 3) SLAQP3RK: NB*(N+NRHS) to use in the work array F that +* is used to apply a block reflector from +* the left. +* 4) SLAQP3RK: NB to use in the auxilixary array AUX. +* Sizes (2) and ((3) + (4)) should intersect, therefore +* TOTAL_WORK_SIZE = 2*N + NB*( N+NRHS+1 ), given NBMIN=2. +* + LWKOPT = 2*N + NB*( N+NRHS+1 ) + END IF + WORK( 1 ) = REAL( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M=0 or N=0. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = REAL( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease in each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + WORK( J ) = SNRM2( M, A( 1, J ), 1 ) + WORK( N+J ) = WORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole original matrix stored in A(1:M,1:N). +* + KP1 = ISAMAX( N, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP1 ) +* +* ==================================================================. +* + IF( SISNAN( MAXC2NRM ) ) THEN +* +* Check if the matrix A contains NaN, set INFO parameter +* to the column number where the first NaN is found and return +* from the routine. +* + K = 0 + INFO = KP1 +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = MAXC2NRM +* +* Array TAU is not set and contains undefined elements. +* + WORK( 1 ) = REAL( LWKOPT ) + RETURN + END IF +* +* =================================================================== +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* +* Check is the matrix A is a zero matrix, set array TAU and +* return from the routine. +* + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = REAL( LWKOPT ) + RETURN +* + END IF +* +* =================================================================== +* + HUGEVAL = SLAMCH( 'Overflow' ) +* + IF( MAXC2NRM.GT.HUGEVAL ) THEN +* +* Check if the matrix A contains +Inf or -Inf, set INFO parameter +* to the column number, where the first +/-Inf is found plus N, +* and continue the computation. +* + INFO = N + KP1 +* + END IF +* +* ================================================================== +* +* Quick return if possible for the case when the first +* stopping criterion is satisfied, i.e. KMAX = 0. +* + IF( KMAX.EQ.0 ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = ZERO + END DO + WORK( 1 ) = REAL( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = SLAMCH('Epsilon') +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = SLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + END IF +* +* Adjust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + END IF +* +* =================================================================== +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* =================================================================== +* +* Quick return if possible for the case when the second or third +* stopping criterion for the whole original matrix is satified, +* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL +* (which is ONE <= RELTOL). +* + IF( MAXC2NRM.LE.ABSTOL .OR. ONE.LE.RELTOL ) THEN +* + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = REAL( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'SGEQP3RK', ' ', M, N, -1, -1 )) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'SGEQP3RK', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* +* ================================================================== +* +* DONE is the boolean flag to rerpresent the case when the +* factorization completed in the block factorization routine, +* before the end of the block. +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB; +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) + N_SUB = N-J+1 + IOFFSET = J-1 +* +* Factorize JB columns among the columns A(J:N). +* + CALL SLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), + $ N+NRHS-J+1, IWORK, IINFO ) +* +* Set INFO on the first occurence of Inf. +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + END IF +* + IF( DONE ) THEN +* +* Either the submatrix is zero before the end of the +* column block, or ABSTOL or RELTOL criterion is +* satisfied before the end of the column block, we can +* return from the routine. Perform the following before +* returning: +* a) Set the number of factorized columns K, +* K = IOFFSET + JBF from the last call of blocked +* routine. +* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned +* by the block factorization routine; +* 2) The remaining TAUs are set to ZERO by the +* block factorization routine. +* + K = IOFFSET + JBF +* +* Set INFO on the first occurrence of NaN, NaN takes +* prcedence over Inf. +* + IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* +* Return from the routine. +* + WORK( 1 ) = REAL( LWKOPT ) +* + RETURN +* + END IF +* + J = J + JBF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of +* columns, that is in ELSE clause we need to compute +* the MAXC2NORM and RELMAXC2NORM to return after we processed +* the blocks. +* + IF( J.LE.JMAX ) THEN +* +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + N_SUB = N-J+1 + IOFFSET = J-1 +* + CALL SLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, + $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ KF, MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), IINFO ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* +* Set INFO on the first exception occurence. +* +* Set INFO on the first exception occurence of Inf or NaN, +* (NaN takes precedence over Inf). +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + ISAMAX( N-K, WORK( K+1 ), 1 ) + MAXC2NRMK = WORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = ZERO + END DO +* + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF +* + WORK( 1 ) = REAL( LWKOPT ) +* + RETURN +* +* End of SGEQP3RK +* + END diff --git a/SRC/slaqp2rk.f b/SRC/slaqp2rk.f new file mode 100755 index 0000000000..ba5eeb204e --- /dev/null +++ b/SRC/slaqp2rk.f @@ -0,0 +1,702 @@ +*> \brief \b SLAQP2RK computes truncated QR factorization with column pivoting of a real matrix block using Level 2 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, +* $ INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS +* REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* REAL A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of a real matrix +*> block A(IOFFSET+1:M,1:N) as +*> +*> A * P(K) = Q(K) * R(K). +*> +*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides matrix block B +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**T * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine SGEQP3RK. 1 <= KP1 <= N_orig_mat. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine SGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:K) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS). +*> The left part A(IOFFSET+1:M,K+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(K)**T. +*> \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 +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is REAL array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is REAL array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (N-1) +*> Used in SLARF subroutine to apply an elementary +*> reflector from the left. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS + REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + REAL A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, + $ MINMNUPDT + REAL AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL SLARF, SLARFG, SSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX + REAL SLAMCH, SNRM2 + EXTERNAL SISNAN, SLAMCH, ISAMAX, SNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* +* MINMNUPDT is the smallest dimension +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which +* contains the submatrices A(IOFFSET+1:M,1:N) and +* B(IOFFSET+1:M,1:NRHS) as column blocks. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KMAX = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( SLAMCH( 'Epsilon' ) ) + HUGEVAL = SLAMCH( 'Overflow' ) +* +* Compute the factorization, KK is the lomn loop index. +* + DO KK = 1, KMAX +* + I = IOFFSET + KK +* + IF( I.EQ.1 ) THEN +* +* ============================================================ +* +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + + KP = KP1 +* +* ============================================================ +* + ELSE +* +* ============================================================ +* +* Determine the pivot column in KK-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( KK-1 ) + ISAMAX( N-KK+1, VN1( KK ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,KK:N) in step KK. +* RELMAXC2NRMK will be computed later, after somecondition +* checks on MAXC2NRMK. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains NaN, and set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( SISNAN( MAXC2NRMK ) ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + INFO = K + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* Array TAU(K+1:MINMNFACT) is not set and contains +* undefined elements. +* + RETURN + END IF +* +* ============================================================ +* +* Quick return, if the submatrix A(I:M,KK:N) is +* a zero matrix. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + RELMAXC2NRMK = ZERO +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + KK - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL >= ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. + + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Set K, the number of factorized columns. +* + K = KK - 1 +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,KK:N): +* 1) swap the KK-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the KK-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than KK in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.KK ) THEN + CALL SSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 ) + VN1( KP ) = VN1( KK ) + VN2( KP ) = VN2( KK ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( KK ) + JPIV( KK ) = ITEMP + END IF +* +* Generate elementary reflector H(KK) using the column A(I:M,KK), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(KK) = ZERO. +* + IF( I.LT.M ) THEN + CALL SLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, + $ TAU( KK ) ) + ELSE + TAU( KK ) = ZERO + END IF +* +* Check if TAU(KK) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(KK) for Inf, +* since SLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by SLARFG can contain Inf, which requires +* TAU(KK) to contain NaN. Therefore, this case of generating Inf +* by SLARFG is covered by checking TAU(KK) for NaN. +* + IF( SISNAN( TAU(KK) ) ) THEN + K = KK - 1 + INFO = KK +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAU( KK ) + RELMAXC2NRMK = TAU( KK ) +* +* Array TAU(KK:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(KK) = NaN. +* + RETURN + END IF +* +* Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. +* ( If M >= N, then at KK = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B. +* If M < N, then at KK = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* KK < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only KK < N+NRHS ) +* + IF( KK.LT.MINMNUPDT ) THEN + AIKK = A( I, KK ) + A( I, KK ) = ONE + CALL SLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) ) + A( I, KK ) = AIKK + END IF +* + IF( KK.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. +* when KK < min(M-IOFFSET, N). +* + DO J = KK + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = SNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* If we reached this point, all colunms have been factorized, +* i.e. no condition was triggered to exit the routine. +* Set the number of factorized columns. +* + K = KMAX +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before +* we return. +* + IF( K.LT.MINMNFACT ) THEN +* + JMAXC2NRM = K + ISAMAX( N-K, VN1( K+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, set TAUs corresponding to the columns that were +* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. +* + DO J = K + 1, MINMNFACT + TAU( J ) = ZERO + END DO +* + RETURN +* +* End of SLAQP2RK +* + END diff --git a/SRC/slaqp3rk.f b/SRC/slaqp3rk.f new file mode 100755 index 0000000000..6109c123c8 --- /dev/null +++ b/SRC/slaqp3rk.f @@ -0,0 +1,924 @@ +*> \brief \b SLAQP3RK computes a step of truncated QR factorization with column pivoting of a real m-by-n matrix A using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SLAQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, +* $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, +* $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) +* IMPLICIT NONE +* LOGICAL DONE +* INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, +* $ NB, NRHS +* REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* +* .. Scalar Arguments .. +* LOGICAL DONE +* INTEGER KB, LDA, LDF, M, N, NB, NRHS, IOFFSET +* REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* REAL A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), +* $ VN1( * ), VN2( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLAQP3RK computes a step of truncated QR factorization with column +*> pivoting of a real M-by-N matrix A block A(IOFFSET+1:M,1:N) +*> by using Level 3 BLAS as +*> +*> A * P(KB) = Q(KB) * R(KB). +*> +*> The routine tries to factorize NB columns from A starting from +*> the row IOFFSET+1 and updates the residual matrix with BLAS 3 +*> xGEMM. The number of actually factorized columns is returned +*> is smaller than NB. +*> +*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides B matrix stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**T * B. +*> +*> Cases when the number of factorized columns KB < NB: +*> +*> (1) In some cases, due to catastrophic cancellations, it cannot +*> factorize all NB columns and need to update the residual matrix. +*> Hence, the actual number of factorized columns in the block returned +*> in KB is smaller than NB. The logical DONE is returned as FALSE. +*> The factorization of the whole original matrix A_orig must proceed +*> with the next block. +*> +*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. +*> +*> (3) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix is a zero matrix in some factorization +*> step KB, the factorization of the whole original matrix A_orig is +*> stopped, the logical DONE is returned as TRUE. The number of +*> factorized columns which is smaller than NB is returned in KB. +*> +*> (4) Whenever NaN is detected in the matrix A or in the array TAU, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. The INFO +*> parameter is set to the column index of the first NaN occurrence. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Factorization block size, i.e the number of columns +*> to factorize in the matrix A. 0 <= NB +*> +*> If NB = 0, then the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine DGEQP3RK. 1 <= KP1 <= N_orig. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is REAL +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine DGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KB) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(KB) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:KB) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KB+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(KB)**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] +*> \verbatim +*> DONE is LOGICAL +*> TRUE: a) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to ABSTOL +*> or RELTOL criterion, +*> b) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to the +*> residual matrix being a ZERO matrix. +*> c) when NaN was detected in the matrix A +*> or in the array TAU. +*> FALSE: otherwise. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= KB <= min(M-IOFFSET,NB,N). +*> +*> KB also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank KB. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank KB) to the maximum column 2-norm of the +*> original matrix A_orig. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is REAL array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is REAL array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] AUXV +*> \verbatim +*> AUXV is REAL array, dimension (NB) +*> Auxiliary vector. +*> \endverbatim +*> +*> \param[out] F +*> \verbatim +*> F is REAL array, dimension (LDF,NB) +*> Matrix F**T = L*(Y**T)*A. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1,N+NRHS). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step KB+1 ( when KB columns +*> have been factorized ). +*> +*> On exit: +*> KB is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(KB+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=KB+1, TAU(KB+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the actorization +*> step KB+1 ( when KB columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp3rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE SLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, + $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary 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 DONE + INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, + $ NB, NRHS + REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + REAL A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), + $ VN1( * ), VN2( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, + $ LSTICC, KP, I, IF + REAL AIK, HUGEVAL, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL SGEMM, SGEMV, SLARFG, SSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX + REAL SLAMCH, SNRM2 + EXTERNAL SISNAN, SLAMCH, ISAMAX, SNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + NB = MIN( NB, MINMNFACT ) + TOL3Z = SQRT( SLAMCH( 'Epsilon' ) ) + HUGEVAL = SLAMCH( 'Overflow' ) +* +* Compute factorization in a while loop over NB columns, +* K is the column index in the block A(1:M,1:N). +* + K = 0 + LSTICC = 0 + DONE = .FALSE. +* + DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) + K = K + 1 + I = IOFFSET + K +* + IF( I.EQ.1 ) THEN +* +* We are at the first column of the original whole matrix A_orig, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* + ELSE +* +* Determine the pivot column in K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + ISAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) in step K. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains NaN, set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( SISNAN( MAXC2NRMK ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = KB + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. + + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL SGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check it only if the column index +* (same as row index) is larger than 1, since the condition +* for the whole original matrix A_orig is checked in the main +* routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + RELMAXC2NRMK = ZERO +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix is zero and we stop the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL SGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. +* + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + K - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third tolerance stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig; +* + KB = K - 1 + IF = I - 1 +* +* Apply the block reflector to the residual of the +* matrix A and the residual of the right hand sides B, if +* the residual matrix and and/or the residual of the right +* hand sides exist, i.e. if the submatrix +* A(I+1:M,KB+1:N+NRHS) exists. This occurs when +* KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL SGEMM( 'No transpose', 'Transpose', + $ M-IF, N+NRHS-KB, KB,-ONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = ZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = ZERO. +* + DO J = K, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) +* 3) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. (Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 4) Save the pivot interchange with the indices relative to the +* the original matrix A_orig, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL SSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + CALL SSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Apply previous Householder reflectors to column K: +* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**T. +* + IF( K.GT.1 ) THEN + CALL SGEMV( 'No transpose', M-I+1, K-1, -ONE, A( I, 1 ), + $ LDA, F( K, 1 ), LDF, ONE, A( I, K ), 1 ) + END IF +* +* Generate elementary reflector H(k) using the column A(I:M,K). +* + IF( I.LT.M ) THEN + CALL SLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) ) + ELSE + TAU( K ) = ZERO + END IF +* +* Check if TAU(K) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(K) for Inf, +* since SLARFG cannot produce TAU(K) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by SLARFG can contain Inf, which requires +* TAU(K) to contain NaN. Therefore, this case of generating Inf +* by SLARFG is covered by checking TAU(K) for NaN. +* + IF( SISNAN( TAU(K) ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = K +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAU( K ) + RELMAXC2NRMK = TAU( K ) +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**T. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL SGEMM( 'No transpose', 'Transpose', + $ M-IF, NRHS, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, ONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* =============================================================== +* + AIK = A( I, K ) + A( I, K ) = ONE +* +* =============================================================== +* +* Compute the current K-th column of F: +* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**T * A(I:M,K). +* + IF( K.LT.N+NRHS ) THEN + CALL SGEMV( 'Transpose', M-I+1, N+NRHS-K, + $ TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1, + $ ZERO, F( K+1, K ), 1 ) + END IF +* +* 2) Zero out elements above and on the diagonal of the +* column K in matrix F, i.e elements F(1:K,K). +* + DO J = 1, K + F( J, K ) = ZERO + END DO +* +* 3) Incremental updating of the K-th column of F: +* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**T +* * A(I:M,K). +* + IF( K.GT.1 ) THEN + CALL SGEMV( 'Transpose', M-I+1, K-1, -TAU( K ), + $ A( I, 1 ), LDA, A( I, K ), 1, ZERO, + $ AUXV( 1 ), 1 ) +* + CALL SGEMV( 'No transpose', N+NRHS, K-1, ONE, + $ F( 1, 1 ), LDF, AUXV( 1 ), 1, ONE, + $ F( 1, K ), 1 ) + END IF +* +* =============================================================== +* +* Update the current I-th row of A: +* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) +* - A(I,1:K)*F(K+1:N+NRHS,1:K)**T. +* + IF( K.LT.N+NRHS ) THEN + CALL SGEMV( 'No transpose', N+NRHS-K, K, -ONE, + $ F( K+1, 1 ), LDF, A( I, 1 ), LDA, ONE, + $ A( I, K+1 ), LDA ) + END IF +* + A( I, K ) = AIK +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < MINMNFACT = min( M-IOFFSET, N ). +* + IF( K.LT.MINMNFACT ) THEN +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2.LE.TOL3Z ) THEN +* +* At J-index, we have a difficult column for the +* update of the 2-norm. Save the index of the previous +* difficult column in IWORK(J-1). +* NOTE: ILSTCC > 1, threfore we can use IWORK only +* with N-1 elements, where the elements are +* shifted by 1 to the left. +* + IWORK( J-1 ) = LSTICC +* +* Set the index of the last difficult column LSTICC. +* + LSTICC = J +* + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + END DO +* + END IF +* +* End of while loop. +* + END DO +* +* Now, afler the loop: +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig, IF = IOFFSET + KB. +* + KB = K + IF = I +* +* Apply the block reflector to the residual of the matrix A +* and the residual of the right hand sides B, if the residual +* matrix and and/or the residual of the right hand sides +* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. +* This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**T. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL SGEMM( 'No transpose', 'Transpose', + $ M-IF, N+NRHS-KB, KB, -ONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, ONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. +* + DO WHILE( LSTICC.GT.0 ) +* +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. +* + ITEMP = IWORK( LSTICC-1 ) +* +* Compute the 2-norm explicilty for the last difficult column and +* save it in the partial and exact 2-norm vectors VN1 and VN2. +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* SNRM2 does not fail on vectors with norm below the value of +* SQRT(SLAMCH('S')) +* + VN1( LSTICC ) = SNRM2( M-IF, A( IF+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) +* +* Downdate the index of the last difficult column to +* the index of the previous difficult column. +* + LSTICC = ITEMP +* + END DO +* + RETURN +* +* End of SLAQP3RK +* + END diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index 5f9b2bee8b..ef65e25f5e 100755 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -9,7 +9,7 @@ set(DZLNTST dlaord.f) set(SLINTST schkaa.F schkeq.f schkgb.f schkge.f schkgt.f schklq.f schkpb.f schkpo.f schkps.f schkpp.f - schkpt.f schkq3.f schkql.f schkqr.f schkrq.f + schkpt.f schkq3.f schkqp3rk.f schkql.f schkqr.f schkrq.f schksp.f schksy.f schksy_rook.f schksy_rk.f schksy_aa.f schksy_aa_2stage.f schktb.f schktp.f schktr.f diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 65ad9c493e..6ce2d9f117 100755 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -45,7 +45,7 @@ DZLNTST = dlaord.o SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ - schkpt.o schkq3.o schkql.o schkqr.o schkrq.o \ + schkpt.o schkq3.o schkqp3rk.o schkql.o schkqr.o schkrq.o \ schksp.o schksy.o schksy_rook.o schksy_rk.o \ schksy_aa.o schksy_aa_2stage.o schktb.o schktp.o schktr.o \ schktz.o \ diff --git a/TESTING/LIN/schkaa.F b/TESTING/LIN/schkaa.F index a5b826d06e..2b9f2ea452 100644 --- a/TESTING/LIN/schkaa.F +++ b/TESTING/LIN/schkaa.F @@ -63,6 +63,7 @@ *> SLQ 8 List types on next line if 0 < NTYPES < 8 *> SQL 8 List types on next line if 0 < NTYPES < 8 *> SQP 6 List types on next line if 0 < NTYPES < 6 +*> DQK 19 List types on next line if 0 < NTYPES < 19 *> STZ 3 List types on next line if 0 < NTYPES < 3 *> SLS 6 List types on next line if 0 < NTYPES < 6 *> SEQ @@ -147,11 +148,11 @@ PROGRAM SCHKAA $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) - REAL E( NMAX ), S( 2*NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus - REAL, DIMENSION(:), ALLOCATABLE :: RWORK + REAL, DIMENSION(:), ALLOCATABLE :: RWORK, S + REAL, DIMENSION(:), ALLOCATABLE :: E REAL, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK * .. * .. External Functions .. @@ -162,13 +163,13 @@ PROGRAM SCHKAA * .. External Subroutines .. EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ, $ SCHKORHR_COL, SCHKPB, SCHKPO, SCHKPS, SCHKPP, - $ SCHKPT, SCHKQ3, SCHKQL, SCHKQR, SCHKRQ, SCHKSP, - $ SCHKSY, SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA, - $ SCHKTB, SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, - $ SDRVGT, SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, - $ SDRVSP, SDRVSY, SDRVSY_ROOK, SDRVSY_RK, - $ SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP, - $ SCHKLQT, SCHKTSQR + $ SCHKPT, SCHKQ3, SCHKQP3RK, SCHKQL, SCHKQR, + $ SCHKRQ, SCHKSP, SCHKSY, SCHKSY_ROOK, SCHKSY_RK, + $ SCHKSY_AA, SCHKTB, SCHKTP, SCHKTR, SCHKTZ, + $ SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB, SDRVPO, + $ SDRVPP, SDRVPT, SDRVSP, SDRVSY, SDRVSY_ROOK, + $ SDRVSY_RK, SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, + $ SCHKQRTP, SCHKLQT, SCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -188,13 +189,17 @@ PROGRAM SCHKAA * .. * .. Allocate memory dynamically .. * - ALLOCATE (A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus ) + ALLOCATE ( A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) + ALLOCATE ( B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (WORK( NMAX, NMAX+MAXRHS+30 ) , STAT = AllocateStatus ) + ALLOCATE ( WORK( NMAX, 3*NMAX+MAXRHS+30 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" - ALLOCATE (RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus ) + ALLOCATE ( E( NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * .. * .. Executable Statements .. @@ -920,6 +925,23 @@ PROGRAM SCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* QK: truncated QR factorization with pivoting +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ), + $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), B( 1, 4 ), + $ WORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN * diff --git a/TESTING/LIN/slatb4.f b/TESTING/LIN/slatb4.f index 6bf236aaac..72a3107278 100644 --- a/TESTING/LIN/slatb4.f +++ b/TESTING/LIN/slatb4.f @@ -224,6 +224,110 @@ SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE ANORM = ONE END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* xQK: truncated QR with pivoting. +* 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' is +* + DIST = 'S' +* +* Set the lower and upper bandwidths. +* + 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, 'GE' ) ) THEN * diff --git a/TESTING/LIN/sqpt01.f b/TESTING/LIN/sqpt01.f index de0c80e53a..f53686a657 100644 --- a/TESTING/LIN/sqpt01.f +++ b/TESTING/LIN/sqpt01.f @@ -33,7 +33,8 @@ *> Householder vectors, and the rest of AF contains a partially updated *> matrix. *> -*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) +*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) ) +*> where || . || is matrix one norm. *> \endverbatim * * Arguments: @@ -172,28 +173,28 @@ REAL FUNCTION SQPT01( M, N, K, A, AF, LDA, TAU, JPVT, * NORMA = SLANGE( 'One-norm', M, N, A, LDA, RWORK ) * - DO 30 J = 1, K - DO 10 I = 1, MIN( J, M ) + DO J = 1, K + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - DO 20 I = J + 1, M + END DO + DO I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO - 20 CONTINUE - 30 CONTINUE - DO 40 J = K + 1, N + END DO + END DO + DO J = K + 1, N CALL SCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) - 40 CONTINUE + END DO * CALL SORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * - DO 50 J = 1, N + DO J = 1, N * * Compare i-th column of QR and jpvt(i)-th column of A * CALL SAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ), $ 1 ) - 50 CONTINUE + END DO * SQPT01 = SLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) ) diff --git a/TESTING/LIN/sqrt11.f b/TESTING/LIN/sqrt11.f index d4422dacbf..a3753adcf9 100644 --- a/TESTING/LIN/sqrt11.f +++ b/TESTING/LIN/sqrt11.f @@ -157,9 +157,9 @@ REAL FUNCTION SQRT11( M, K, A, LDA, TAU, WORK, LWORK ) CALL SORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M, $ WORK( M*M+1 ), INFO ) * - DO 10 J = 1, M + DO J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE - 10 CONTINUE + END DO * SQRT11 = SLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) diff --git a/TESTING/LIN/sqrt12.f b/TESTING/LIN/sqrt12.f index 23fc94c63d..46b359e07b 100644 --- a/TESTING/LIN/sqrt12.f +++ b/TESTING/LIN/sqrt12.f @@ -26,7 +26,7 @@ *> SQRT12 computes the singular values `svlues' of the upper trapezoid *> of A(1:M,1:N) and returns the ratio *> -*> || s - svlues||/(||svlues||*eps*max(M,N)) +*> || svlues - s ||/(||s||*eps*max(M,N)) *> \endverbatim * * Arguments: @@ -144,11 +144,11 @@ REAL FUNCTION SQRT12( M, N, A, LDA, S, WORK, LWORK ) * Copy upper triangle of A into work * CALL SLASET( 'Full', M, N, ZERO, ZERO, WORK, M ) - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) + DO J = 1, N + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE + END DO + END DO * * Get machine parameters * @@ -197,9 +197,9 @@ REAL FUNCTION SQRT12( M, N, A, LDA, S, WORK, LWORK ) * ELSE * - DO 30 I = 1, MN + DO I = 1, MN WORK( M*N+I ) = ZERO - 30 CONTINUE + END DO END IF * * Compare s and singular values of work diff --git a/TESTING/stest.in b/TESTING/stest.in index 27ac30040f..7faa8b7a11 100644 --- a/TESTING/stest.in +++ b/TESTING/stest.in @@ -36,6 +36,7 @@ SRQ 8 List types on next line if 0 < NTYPES < 8 SLQ 8 List types on next line if 0 < NTYPES < 8 SQL 8 List types on next line if 0 < NTYPES < 8 SQP 6 List types on next line if 0 < NTYPES < 6 +SQK 19 List types on next line if 0 < NTYPES < 19 STZ 3 List types on next line if 0 < NTYPES < 3 SLS 6 List types on next line if 0 < NTYPES < 6 SEQ From c2228e10e1e439ea5a26a3633c1cd46522f5e669 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 097/106] forgot add in the previous commit TESTING/LIN/schkqp3rk.f, adding now --- TESTING/LIN/schkqp3rk.f | 831 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 831 insertions(+) create mode 100755 TESTING/LIN/schkqp3rk.f diff --git a/TESTING/LIN/schkqp3rk.f b/TESTING/LIN/schkqp3rk.f new file mode 100755 index 0000000000..83ec41e61c --- /dev/null +++ b/TESTING/LIN/schkqp3rk.f @@ -0,0 +1,831 @@ +*> \brief \b SCHKQP3RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, +* $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, +* $ B, COPYB, S, TAU, +* $ 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 .. +* INTEGER NM, NN, NNS, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ), +* $ NVAL( * ), NXVAL( * ) +* REAL A( * ), COPYA( * ), B( * ), COPYB( * ), +* $ S( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKQP3RK tests SGEQP3RK. +*> \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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is REAL array, dimension (MMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (MMAX*NSMAX) +*> where MMAX is the maximum value of M in MVAL and NSMAX is the +*> maximum value of NRHS in NSVAL. +*> \endverbatim +*> +*> \param[out] COPYB +*> \verbatim +*> COPYB is REAL array, dimension (MMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is REAL array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension +*> (MMAX*NMAX + 4*NMAX + MMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, + $ B, COPYB, S, TAU, + $ 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 .. + INTEGER NM, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NSVAL( * ), NXVAL( * ) + REAL A( * ), COPYA( * ), B( * ), COPYB( * ), + $ S( * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + REAL ONE, ZERO, BIGNUM + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, + $ BIGNUM = 1.0E+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE + 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, + $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, + $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, + $ NRUN, NX, T + REAL ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ), RDUMMY( 1 ) +* .. +* .. External Functions .. + REAL SLAMCH, SQPT01, SQRT11, SQRT12, SLANGE + EXTERNAL SLAMCH, SQPT01, SQRT11, SQRT12, SLANGE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SAXPY, SGEQP3RK, + $ SLACPY, SLAORD, SLASET, SLATB4, SLATMS, + $ SORMQR, SSWAP, ICOPY, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'QK' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = SLAMCH( 'Epsilon' ) + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* + DO INS = 1, NNS + NRHS = NSVAL( INS ) +* +* Set up parameters with SLATB4 and generate +* M-by-NRHS B matrix with SLATMS. +* IMAT = 14: +* Random matrix, CNDNUM = 2, NORM = ONE, +* MODE = 3 (geometric distribution of singular values). +* + CALL SLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' + CALL SLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYB, LDA, WORK, INFO ) + + +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, + $ NRHS, -1, -1, -1, 6, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + DO IMAT = 1, 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 +* 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 11. Random, Half MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM ) +* one small singular value S(N)=1/CNDNUM +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1: Zero matrix +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 ) + $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrices 2-5. +* +* Set up parameters with SLATB4 and generate a test +* matrix with SLATMS. +* + CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' + CALL SLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + CALL SLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Rectangular matrices 5-13 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 +* for matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column. +* + IF( IMAT.EQ.5 ) THEN +* +* First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* 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 +* +* First half of MINMN columns is zero. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Last columns are zero columns, +* starting from (MINMN / 2 + 1) column. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - JB_ZERO + 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Half of the columns in the middle of MINMN +* columns is zero, starting from +* MINMN/2 - (MINMN/2)/2 + 1 column. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* 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 +* +* Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL SLASET( 'Full', M, NB_ZERO, ZERO, ZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL SLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL SLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL SSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL SSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing order and add trailing zeros +* that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) +* + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF(MINMN.LT.2) skip this size for this matrix type. +* + CYCLE + END IF +* +* Initialize a copy array for a pivot array for SGEQP3RK. +* + DO I = 1, N + IWORK( I ) = 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 KMAX = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). +* Get a working copy of COPYB into into B( 1:M, 1:NRHS ). +* Get a working copy of IWORK(1:N) awith zeroes into +* which is going to be used as pivot array IWORK( N+1:2N ). +* NOTE: IWORK(2N+1:3N) is going to be used as a WORK array +* for the routine. +* + CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL SLACPY( 'All', M, NRHS, COPYB, LDA, + $ A( LDA*N + 1 ), LDA ) + CALL SLACPY( 'All', M, NRHS, COPYB, LDA, + $ B, LDA ) + CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) +* + ABSTOL = -1.0 + RELTOL = -1.0 +* +* Compute the QR factorization with pivoting of A +* + LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ), + $ 3*N + NRHS - 1 ) ) +* +* Compute SGEQP3RK factorization of A. +* + SRNAMT = 'SGEQP3RK' + CALL SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ A, LDA, KFACT, MAXC2NRMK, + $ RELMAXC2NRMK, IWORK( N+1 ), TAU, + $ WORK, LW, IWORK( 2*N+1 ), INFO ) +* +* Check error code from SGEQP3RK. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'SGEQP3RK', 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( KFACT.EQ.MINMN ) THEN +* + RESULT( 1 ) = SQRT12( M, N, A, LDA, S, WORK, + $ LWORK ) +* + DO T = 1, 1 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, NB, NX, + $ IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 1 +* + END IF +* +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = SQPT01( M, N, KFACT, COPYA, A, LDA, TAU, + $ IWORK( N+1 ), WORK, LWORK ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = SQRT11( M, KFACT, A, LDA, TAU, WORK, + $ LWORK ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 2, 3 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater than 2. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)), +* K=1:KFACT-1 +* + IF( MIN(KFACT, MINMN).GE.2 ) THEN +* + DO J = 1, KFACT-1, 1 + + DTEMP = (( ABS( A( (J-1)*M+J ) ) - + $ ABS( A( (J)*M+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 4, 4 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', + $ M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, + $ RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* Compute test 5: +* +* This test in only for matrix A with min(M,N) > 0. +* +* The test returns the ratio: +* +* 1-norm(Q**T * B - Q**T * B ) / +* ( M * EPS ) +* +* (1) Compute B:=Q**T * B in the matrix B. +* + IF( MINMN.GT.0 ) THEN +* + LWORK_MQR = MAX(1, NRHS) + CALL SORMQR( 'Left', 'Transpose', + $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, + $ WORK, LWORK_MQR, INFO ) +* + DO I = 1, NRHS +* +* Compare N+J-th column of A and J-column of B. +* + CALL SAXPY( M, -ONE, A( ( N+I-1 )*LDA+1 ), 1, + $ B( ( I-1 )*LDA+1 ), 1 ) + END DO +* + RESULT( 5 ) = + $ ABS( + $ SLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) / + $ ( DBLE( M )*SLAMCH( 'Epsilon' ) ) + $ ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 5, 5 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'SGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End compute test 5. +* + END IF +* +* 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 INS = 1, NNS +* + 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, ', NRHS =', I5, + $ ', KMAX =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of SCHKQP3RK +* + END From 0a6744177a886846a1a3621807b76648663f87bd Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 098/106] fixed comments in SLAQP3RK --- SRC/slaqp3rk.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/SRC/slaqp3rk.f b/SRC/slaqp3rk.f index 6109c123c8..4f1479174b 100755 --- a/SRC/slaqp3rk.f +++ b/SRC/slaqp3rk.f @@ -179,14 +179,14 @@ *> KP1 is INTEGER *> The index of the column with the maximum 2-norm in *> the whole original matrix A_orig determined in the -*> main routine DGEQP3RK. 1 <= KP1 <= N_orig. +*> main routine SGEQP3RK. 1 <= KP1 <= N_orig. *> \endverbatim *> *> \param[in] MAXC2NRM *> \verbatim *> MAXC2NRM is REAL *> The maximum column 2-norm of the whole original -*> matrix A_orig computed in the main routine DGEQP3RK. +*> matrix A_orig computed in the main routine SGEQP3RK. *> MAXC2NRM >= 0. *> \endverbatim *> From 036fef485fd037a594d4d6c0e2267fbc6dd48c19 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:10 -0800 Subject: [PATCH 099/106] fixed description in SRC/zlaqp2rk.f SRC/zlaqp3rk.f --- SRC/zlaqp2rk.f | 2 +- SRC/zlaqp3rk.f | 14 ++++---------- 2 files changed, 5 insertions(+), 11 deletions(-) diff --git a/SRC/zlaqp2rk.f b/SRC/zlaqp2rk.f index 54fb67f4ec..2e89254e6c 100755 --- a/SRC/zlaqp2rk.f +++ b/SRC/zlaqp2rk.f @@ -253,7 +253,7 @@ *> *> \param[out] WORK *> \verbatim -*> WORK is DOUBLE PRECISION array, dimension (N-1) +*> WORK is COMPLEX*16 array, dimension (N-1) *> Used in ZLARF subroutine to apply an elementary *> reflector from the left. *> \endverbatim diff --git a/SRC/zlaqp3rk.f b/SRC/zlaqp3rk.f index 0381e10d30..1b61faeb80 100755 --- a/SRC/zlaqp3rk.f +++ b/SRC/zlaqp3rk.f @@ -28,12 +28,6 @@ * $ NB, NRHS * DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, * $ RELTOL -* -* .. Scalar Arguments .. -* LOGICAL DONE -* INTEGER KB, LDA, LDF, M, N, NB, NRHS, IOFFSET -* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, -* $ RELTOL * .. * .. Array Arguments .. * INTEGER IWORK( * ), JPIV( * ) @@ -192,7 +186,7 @@ *> *> \param[in,out] A *> \verbatim -*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> A is COMPLEX*16 array, dimension (LDA,N+NRHS) *> On entry: *> the M-by-N matrix A and M-by-NRHS matrix B, as in *> @@ -273,7 +267,7 @@ *> *> \param[out] TAU *> \verbatim -*> TAU is DOUBLE PRECISION array, dimension (min(M-IOFFSET,N)) +*> TAU is COMPLEX*16 array, dimension (min(M-IOFFSET,N)) *> The scalar factors of the elementary reflectors. *> \endverbatim *> @@ -291,13 +285,13 @@ *> *> \param[out] AUXV *> \verbatim -*> AUXV is DOUBLE PRECISION array, dimension (NB) +*> AUXV is COMPLEX*16 array, dimension (NB) *> Auxiliary vector. *> \endverbatim *> *> \param[out] F *> \verbatim -*> F is DOUBLE PRECISION array, dimension (LDF,NB) +*> F is COMPLEX*16 array, dimension (LDF,NB) *> Matrix F**H = L*(Y**H)*A. *> \endverbatim *> From ee81706f4f5365528ee156fc5584dcf73aafcdb7 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:11 -0800 Subject: [PATCH 100/106] fxed comments in zchkqp3rk.f schkqp3rk.f --- TESTING/LIN/schkqp3rk.f | 2 +- TESTING/LIN/zchkqp3rk.f | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/TESTING/LIN/schkqp3rk.f b/TESTING/LIN/schkqp3rk.f index 83ec41e61c..e67574b1ab 100755 --- a/TESTING/LIN/schkqp3rk.f +++ b/TESTING/LIN/schkqp3rk.f @@ -174,7 +174,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup double_lin +*> \ingroup single_lin * * ===================================================================== SUBROUTINE SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, diff --git a/TESTING/LIN/zchkqp3rk.f b/TESTING/LIN/zchkqp3rk.f index c3988bcbf6..67c55d3baa 100644 --- a/TESTING/LIN/zchkqp3rk.f +++ b/TESTING/LIN/zchkqp3rk.f @@ -32,7 +32,7 @@ *> *> \verbatim *> -*> ZCHKQP3RK tests ZGEQP3. +*> ZCHKQP3RK tests ZGEQP3RK. *> \endverbatim * * Arguments: From 6a15917836df26226410a420dbf869052890fcf6 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:11 -0800 Subject: [PATCH 101/106] added declaration of intrinsics REAL or DBLE in SRC/dchkqp3rk.f zchkqp3rk.f schkqp3rk.f --- TESTING/LIN/dchkqp3rk.f | 2 +- TESTING/LIN/schkqp3rk.f | 4 ++-- TESTING/LIN/zchkqp3rk.f | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/TESTING/LIN/dchkqp3rk.f b/TESTING/LIN/dchkqp3rk.f index bc5d1d1f59..434d2067e2 100755 --- a/TESTING/LIN/dchkqp3rk.f +++ b/TESTING/LIN/dchkqp3rk.f @@ -239,7 +239,7 @@ SUBROUTINE DCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ DORMQR, DSWAP, ICOPY, XLAENV * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, MOD + INTRINSIC ABS, DBLE, MAX, MIN, MOD * .. * .. Scalars in Common .. LOGICAL LERR, OK diff --git a/TESTING/LIN/schkqp3rk.f b/TESTING/LIN/schkqp3rk.f index e67574b1ab..36cf9370ea 100755 --- a/TESTING/LIN/schkqp3rk.f +++ b/TESTING/LIN/schkqp3rk.f @@ -238,7 +238,7 @@ SUBROUTINE SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ SORMQR, SSWAP, ICOPY, XLAENV * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, MOD + INTRINSIC ABS, MAX, MIN, MOD, REAL * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -771,7 +771,7 @@ SUBROUTINE SCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, RESULT( 5 ) = $ ABS( $ SLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) / - $ ( DBLE( M )*SLAMCH( 'Epsilon' ) ) + $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) $ ) * * Print information about the tests that did not pass diff --git a/TESTING/LIN/zchkqp3rk.f b/TESTING/LIN/zchkqp3rk.f index 67c55d3baa..302c7b1a87 100644 --- a/TESTING/LIN/zchkqp3rk.f +++ b/TESTING/LIN/zchkqp3rk.f @@ -242,7 +242,7 @@ SUBROUTINE ZCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, $ ZLATMS, ZUNMQR, ZSWAP * .. * .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, MOD + INTRINSIC ABS, DBLE, MAX, MIN, MOD * .. * .. Scalars in Common .. LOGICAL LERR, OK From ea4787ca59fc81c746a160794394fbd395caba0b Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:11 -0800 Subject: [PATCH 102/106] added complex precision truncated QR and testing for CGEQP3RK, CLAQP2RK, CLAQP3RK --- SRC/CMakeLists.txt | 5 +- SRC/Makefile | 6 +- SRC/cgeqp3rk.f | 1080 ++++++++++++++++++++++++++++++++++++ SRC/claqp2rk.f | 715 ++++++++++++++++++++++++ SRC/claqp3rk.f | 936 +++++++++++++++++++++++++++++++ TESTING/LIN/CMakeLists.txt | 2 +- TESTING/LIN/Makefile | 2 +- TESTING/LIN/cchkaa.F | 43 +- TESTING/LIN/cchkqp3rk.f | 836 ++++++++++++++++++++++++++++ TESTING/LIN/clatb4.f | 104 ++++ TESTING/LIN/cqpt01.f | 23 +- TESTING/LIN/cqrt11.f | 4 +- TESTING/LIN/cqrt12.f | 14 +- TESTING/ctest.in | 1 + 14 files changed, 3733 insertions(+), 38 deletions(-) create mode 100755 SRC/cgeqp3rk.f create mode 100755 SRC/claqp2rk.f create mode 100755 SRC/claqp3rk.f create mode 100644 TESTING/LIN/cchkqp3rk.f diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt index 4a720a4457..7c767b1693 100644 --- a/SRC/CMakeLists.txt +++ b/SRC/CMakeLists.txt @@ -177,7 +177,8 @@ set(CLASRC cgbtf2.f cgbtrf.f cgbtrs.f cgebak.f cgebal.f cgebd2.f cgebrd.f cgecon.f cgeequ.f cgees.f cgeesx.f cgeev.f cgeevx.f cgehd2.f cgehrd.f cgelq2.f cgelqf.f - cgels.f cgelst.f cgelsd.f cgelss.f cgelsy.f cgeql2.f cgeqlf.f cgeqp3.f + cgels.f cgelst.f cgelsd.f cgelss.f cgelsy.f cgeql2.f cgeqlf.f + cgeqp3.f cgeqp3rk.f cgeqr2.f cgeqr2p.f cgeqrf.f cgeqrfp.f cgerfs.f cgerq2.f cgerqf.f cgesc2.f cgesdd.f cgesv.f cgesvd.f cgesvdx.f cgesvj.f cgejsv.f cgsvj0.f cgsvj1.f @@ -213,7 +214,7 @@ set(CLASRC clanhb.f clanhe.f clanhp.f clanhs.f clanht.f clansb.f clansp.f clansy.f clantb.f clantp.f clantr.f clapll.f clapmt.f clarcm.f claqgb.f claqge.f - claqhb.f claqhe.f claqhp.f claqp2.f claqps.f claqsb.f + claqhb.f claqhe.f claqhp.f claqp2.f claqps.f claqp2rk.f claqp3rk.f claqsb.f claqr0.f claqr1.f claqr2.f claqr3.f claqr4.f claqr5.f claqsp.f claqsy.f clar1v.f clar2v.f ilaclr.f ilaclc.f clarf.f clarfb.f clarfb_gett.f clarfg.f clarfgp.f clarft.f diff --git a/SRC/Makefile b/SRC/Makefile index b769b6351a..bfa4d0fdca 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -211,8 +211,8 @@ CLASRC = \ cgbtf2.o cgbtrf.o cgbtrs.o cgebak.o cgebal.o cgebd2.o cgebrd.o \ cgecon.o cgeequ.o cgees.o cgeesx.o cgeev.o cgeevx.o \ cgehd2.o cgehrd.o cgelq2.o cgelqf.o \ - cgels.o cgelst.o cgelsd.o cgelss.o cgelsy.o cgeql2.o cgeqlf.o cgeqp3.o \ - cgeqr2.o cgeqr2p.o cgeqrf.o cgeqrfp.o cgerfs.o \ + cgels.o cgelst.o cgelsd.o cgelss.o cgelsy.o cgeql2.o cgeqlf.o \ + cgeqp3.o cgeqp3rk.o cgeqr2.o cgeqr2p.o cgeqrf.o cgeqrfp.o cgerfs.o \ cgerq2.o cgerqf.o cgesc2.o cgesdd.o cgesv.o cgesvd.o cgesvdx.o \ cgesvj.o cgejsv.o cgsvj0.o cgsvj1.o \ cgesvx.o cgetc2.o cgetf2.o cgetri.o \ @@ -246,7 +246,7 @@ CLASRC = \ clanhb.o clanhe.o \ clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \ clantp.o clantr.o clapll.o clapmt.o clarcm.o claqgb.o claqge.o \ - claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqsb.o \ + claqhb.o claqhe.o claqhp.o claqp2.o claqps.o claqp2rk.o claqp3rk.o claqsb.o \ claqr0.o claqr1.o claqr2.o claqr3.o claqr4.o claqr5.o \ claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \ clarf.o clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \ diff --git a/SRC/cgeqp3rk.f b/SRC/cgeqp3rk.f new file mode 100755 index 0000000000..c67ef0c771 --- /dev/null +++ b/SRC/cgeqp3rk.f @@ -0,0 +1,1080 @@ +*> \brief \b CGEQP3RK computes a truncated Householder QR factorization with column pivoting of a complex m-by-n matrix A by using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ WORK, LWORK, RWORK, IWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* REAL ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a complex +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank of the +*> factor R, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is an N-by-N permutation matrix; +*> Q(K) is an M-by-M orthogonal matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a complex M-by-NRHS +*> matrix B with Q(K)**H * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAX, the maximum number of columns +*> KMAX to factorize, i.e. the factorization rank is limited +*> to KMAX. If KMAX >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) to +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> 4) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix R22(K) is a zero matrix in some +*> factorization step K. ( This stopping criterion is implicit. ) +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> To factorize the whole matrix A, use the values +*> KMAX >= min(M,N), ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_residual); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**H * B, the matrix B with the orthogonal +*> transformation Q(K)**H applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M orthogonal matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**H, +*> +*> where 1 <= j <= K and +*> I is an M-by-M identity matrix, +*> tau is a complex scalar, +*> v is a complex vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e. the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M,N), then this stopping criterion +*> is not used, the routine factorizes columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL +*> +*> The second factorization stopping criterion, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. Let SAFMIN = DLAMCH('S'). +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If ABSTOL chosen above is >= MAXC2NRM, then this +*> stopping criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. The routine +*> returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL +*> +*> The third factorization stopping criterion, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. Let EPS = DLAMCH('E'). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX 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. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. +*> The routine returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend that RELTOL satisfy +*> min( 10*max(M,N)*EPS, sqrt(EPS) ) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of the +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,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(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) If NRHS > 0, the subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**H * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> +*> NOTE: If K = 0, a) the arrays A and B are not modified; +*> b) the array TAU(1:min(M,N)) is set to ZERO, +*> if the matrix A does not contain NaN, +*> otherwise the elements TAU(1:min(M,N)) +*> are undefined; +*> c) the elements of the array JPIV are set +*> as follows: for j = 1:N, JPIV(j) = j. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix R22(K), +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK in the factorization step K would equal +*> R(K+1,K+1) 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 of the residual matrix R22(K) (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK in the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The elements of the array JPIV(1:N) are always set +*> by the routine, for example, even when no columns +*> were factorized, i.e. when K = 0, the elements are +*> set as JPIV(j) = j for j = 1:N. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= min(M,N), only the elements TAU(1:K) of +*> the array TAU are modified by the factorization. +*> After the factorization computed, if no NaN was found +*> during the factorization, the remaining elements +*> TAU(K+1:min(M,N)) are set to zero, otherwise the +*> elements TAU(K+1:min(M,N)) are not set and therefore +*> undefined. +*> ( If K = 0, all elements of TAU are set to zero, if +*> the matrix A does not contain NaN. ) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*. LWORK >= N+NRHS-1 +*> For optimal performance LWORK >= NB*( N+NRHS+1 ), +*> where NB is the optimal block size for CGEQP3RK returned +*> by ILAENV. Minimal block size MINNB=2. +*> +*> NOTE: The decision, whether to use unblocked BLAS 2 +*> or blocked BLAS 3 code is based not only on the dimension +*> LWORK of the availbale workspace WORK, but also also on the +*> matrix A dimension N via crossover point NX returned +*> by ILAENV. (For N less than NX, unblocked code should be +*> used.) +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine CLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> CGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in CGEQP3 routine which uses +*> CLARFG routine to generate Householder reflectors +*> for QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ WORK, LWORK, RWORK, IWORK, 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 .. + INTEGER INFO, K, KF, KMAX, LDA, LWORK, M, N, NRHS + REAL ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + REAL ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE + INTEGER IINFO, IOFFSET, IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, N_SUB, NB, + $ NBMIN, NX + REAL EPS, HUGEVAL, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL CLAQP2RK, CLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX, ILAENV + REAL SLAMCH, SCNRM2 + EXTERNAL SISNAN, SLAMCH, SCNRM2, ISAMAX, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC CMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( SISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( SISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE +* +* Minimal workspace size in case of using only unblocked +* BLAS 2 code in CLAQP2RK. +* 1) CLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in CLARF subroutine inside CLAQP2RK to apply an +* elementary reflector from the left. +* TOTAL_WORK_SIZE = 3*N + NRHS - 1 +* + IWS = N + NRHS - 1 +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'CGEQP3RK', ' ', M, N, -1, -1 ) +* +* A formula for the optimal workspace size in case of using +* both unblocked BLAS 2 in CLAQP2RK and blocked BLAS 3 code +* in CLAQP3RK. +* 1) CGEQP3RK, CLAQP2RK, CLAQP3RK: 2*N to store full and +* partial column 2-norms. +* 2) CLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in CLARF subroutine to apply an elementary reflector +* from the left. +* 3) CLAQP3RK: NB*(N+NRHS) to use in the work array F that +* is used to apply a block reflector from +* the left. +* 4) CLAQP3RK: NB to use in the auxilixary array AUX. +* Sizes (2) and ((3) + (4)) should intersect, therefore +* TOTAL_WORK_SIZE = 2*N + NB*( N+NRHS+1 ), given NBMIN=2. +* + LWKOPT = 2*N + NB*( N+NRHS+1 ) + END IF + WORK( 1 ) = CMPLX( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M=0 or N=0. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease in each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + RWORK( J ) = SCNRM2( M, A( 1, J ), 1 ) + RWORK( N+J ) = RWORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole original matrix stored in A(1:M,1:N). +* + KP1 = ISAMAX( N, RWORK( 1 ), 1 ) +* +* ==================================================================. +* + IF( SISNAN( MAXC2NRM ) ) THEN +* +* Check if the matrix A contains NaN, set INFO parameter +* to the column number where the first NaN is found and return +* from the routine. +* + K = 0 + INFO = KP1 +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = MAXC2NRM +* +* Array TAU is not set and contains undefined elements. +* + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN + END IF +* +* =================================================================== +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* +* Check is the matrix A is a zero matrix, set array TAU and +* return from the routine. +* + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = CZERO + END DO +* + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN +* + END IF +* +* =================================================================== +* + HUGEVAL = SLAMCH( 'Overflow' ) +* + IF( MAXC2NRM.GT.HUGEVAL ) THEN +* +* Check if the matrix A contains +Inf or -Inf, set INFO parameter +* to the column number, where the first +/-Inf is found plus N, +* and continue the computation. +* + INFO = N + KP1 +* + END IF +* +* ================================================================== +* +* Quick return if possible for the case when the first +* stopping criterion is satisfied, i.e. KMAX = 0. +* + IF( KMAX.EQ.0 ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = CZERO + END DO + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = SLAMCH('Epsilon') +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = SLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + END IF +* +* Adjust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + END IF +* +* =================================================================== +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* =================================================================== +* +* Quick return if possible for the case when the second or third +* stopping criterion for the whole original matrix is satified, +* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL +* (which is ONE <= RELTOL). +* + IF( MAXC2NRM.LE.ABSTOL .OR. ONE.LE.RELTOL ) THEN +* + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + DO J = 1, MINMN + TAU( J ) = CZERO + END DO +* + WORK( 1 ) = CMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'CGEQP3RK', ' ', M, N, -1, -1 ) ) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'CGEQP3RK', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* +* ================================================================== +* +* DONE is the boolean flag to rerpresent the case when the +* factorization completed in the block factorization routine, +* before the end of the block. +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB; +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) + N_SUB = N-J+1 + IOFFSET = J-1 +* +* Factorize JB columns among the columns A(J:N). +* + CALL CLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ RWORK( J ), RWORK( N+J ), + $ WORK( 1 ), WORK( JB+1 ), + $ N+NRHS-J+1, IWORK, IINFO ) +* +* Set INFO on the first occurence of Inf. +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + END IF +* + IF( DONE ) THEN +* +* Either the submatrix is zero before the end of the +* column block, or ABSTOL or RELTOL criterion is +* satisfied before the end of the column block, we can +* return from the routine. Perform the following before +* returning: +* a) Set the number of factorized columns K, +* K = IOFFSET + JBF from the last call of blocked +* routine. +* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned +* by the block factorization routine; +* 2) The remaining TAUs are set to ZERO by the +* block factorization routine. +* + K = IOFFSET + JBF +* +* Set INFO on the first occurrence of NaN, NaN takes +* prcedence over Inf. +* + IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* +* Return from the routine. +* + WORK( 1 ) = CMPLX( LWKOPT ) +* + RETURN +* + END IF +* + J = J + JBF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of +* columns, that is in ELSE clause we need to compute +* the MAXC2NORM and RELMAXC2NORM to return after we processed +* the blocks. +* + IF( J.LE.JMAX ) THEN +* +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + N_SUB = N-J+1 + IOFFSET = J-1 +* + CALL CLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, + $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ KF, MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), RWORK( J ), RWORK( N+J ), + $ WORK( 1 ), IINFO ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* +* Set INFO on the first exception occurence. +* +* Set INFO on the first exception occurence of Inf or NaN, +* (NaN takes precedence over Inf). +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + ISAMAX( N-K, RWORK( K+1 ), 1 ) + MAXC2NRMK = RWORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = CZERO + END DO +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF +* + WORK( 1 ) = CMPLX( LWKOPT ) +* + RETURN +* +* End of CGEQP3RK +* + END diff --git a/SRC/claqp2rk.f b/SRC/claqp2rk.f new file mode 100755 index 0000000000..8a79734930 --- /dev/null +++ b/SRC/claqp2rk.f @@ -0,0 +1,715 @@ +*> \brief \b CLAQP2RK computes truncated QR factorization with column pivoting of a complex matrix block using Level 2 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, +* $ INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS +* REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* REAL VN1( * ), VN2( * ) +* COMPLEX A( LDA, * ), TAU( * ), WORK( * ) +* $ +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of the complex matrix +*> block A(IOFFSET+1:M,1:N) as +*> +*> A * P(K) = Q(K) * R(K). +*> +*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides matrix block B +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**H * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine CGEQP3RK. 1 <= KP1 <= N_orig_mat. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is REAL +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine CGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:K) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS). +*> The left part A(IOFFSET+1:M,K+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(K)**H. +*> \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 +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is REAL array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is REAL array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (N-1) +*> Used in CLARF subroutine to apply an elementary +*> reflector from the left. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS + REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + REAL VN1( * ), VN2( * ) + COMPLEX A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, + $ MINMNUPDT + REAL HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z + COMPLEX AIKK +* .. +* .. External Subroutines .. + EXTERNAL CLARF, CLARFG, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, CONJG, IMAG, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX + REAL SLAMCH, SCNRM2 + EXTERNAL SISNAN, SLAMCH, ISAMAX, SCNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* +* MINMNUPDT is the smallest dimension +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which +* contains the submatrices A(IOFFSET+1:M,1:N) and +* B(IOFFSET+1:M,1:NRHS) as column blocks. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KMAX = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( SLAMCH( 'Epsilon' ) ) + HUGEVAL = SLAMCH( 'Overflow' ) +* +* Compute the factorization, KK is the lomn loop index. +* + DO KK = 1, KMAX +* + I = IOFFSET + KK +* + IF( I.EQ.1 ) THEN +* +* ============================================================ +* +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* +* ============================================================ +* + ELSE +* +* ============================================================ +* +* Determine the pivot column in KK-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( KK-1 ) + ISAMAX( N-KK+1, VN1( KK ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,KK:N) in step KK. +* RELMAXC2NRMK will be computed later, after somecondition +* checks on MAXC2NRMK. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains NaN, and set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( SISNAN( MAXC2NRMK ) ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + INFO = K + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* Array TAU(K+1:MINMNFACT) is not set and contains +* undefined elements. +* + RETURN + END IF +* +* ============================================================ +* +* Quick return, if the submatrix A(I:M,KK:N) is +* a zero matrix. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + RELMAXC2NRMK = ZERO +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + KK - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL >= ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. + + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Set K, the number of factorized columns. +* + K = KK - 1 +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,KK:N): +* 1) swap the KK-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the KK-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than KK in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.KK ) THEN + CALL CSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 ) + VN1( KP ) = VN1( KK ) + VN2( KP ) = VN2( KK ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( KK ) + JPIV( KK ) = ITEMP + END IF +* +* Generate elementary reflector H(KK) using the column A(I:M,KK), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(KK) = CZERO. +* + IF( I.LT.M ) THEN + CALL CLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, + $ TAU( KK ) ) + ELSE + TAU( KK ) = CZERO + END IF +* +* Check if TAU(KK) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(KK) for Inf, +* since CLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by CLARFG can contain Inf, which requires +* TAU(KK) to contain NaN. Therefore, this case of generating Inf +* by CLARFG is covered by checking TAU(KK) for NaN. +* + IF( SISNAN( REAL( TAU(KK) ) ) ) THEN + TAUNAN = REAL( TAU(KK) ) + ELSE IF( SISNAN( IMAG( TAU(KK) ) ) ) THEN + TAUNAN = IMAG( TAU(KK) ) + ELSE + TAUNAN = ZERO + END IF +* + IF( SISNAN( TAUNAN ) ) THEN + K = KK - 1 + INFO = KK +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAUNAN + RELMAXC2NRMK = TAUNAN +* +* Array TAU(KK:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(KK) = NaN. +* + RETURN + END IF +* +* Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. +* ( If M >= N, then at KK = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B. +* If M < N, then at KK = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* KK < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only KK < N+NRHS ) +* + IF( KK.LT.MINMNUPDT ) THEN + AIKK = A( I, KK ) + A( I, KK ) = CONE + CALL CLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ CONJG( TAU( KK ) ), A( I, KK+1 ), LDA, + $ WORK( 1 ) ) + A( I, KK ) = AIKK + END IF +* + IF( KK.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. +* when KK < min(M-IOFFSET, N). +* + DO J = KK + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = SCNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* If we reached this point, all colunms have been factorized, +* i.e. no condition was triggered to exit the routine. +* Set the number of factorized columns. +* + K = KMAX +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before +* we return. +* + IF( K.LT.MINMNFACT ) THEN +* + JMAXC2NRM = K + ISAMAX( N-K, VN1( K+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, set TAUs corresponding to the columns that were +* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. +* + DO J = K + 1, MINMNFACT + TAU( J ) = CZERO + END DO +* + RETURN +* +* End of CLAQP2RK +* + END diff --git a/SRC/claqp3rk.f b/SRC/claqp3rk.f new file mode 100755 index 0000000000..2a7d1c2ed5 --- /dev/null +++ b/SRC/claqp3rk.f @@ -0,0 +1,936 @@ +*> \brief \b CLAQP3RK computes a step of truncated QR factorization with column pivoting of a complex m-by-n matrix A using Level 3 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CLAQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, +* $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, +* $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) +* IMPLICIT NONE +* LOGICAL DONE +* INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, +* $ NB, NRHS +* REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* REAL VN1( * ), VN2( * ) +* COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLAQP3RK computes a step of truncated QR factorization with column +*> pivoting of a complex M-by-N matrix A block A(IOFFSET+1:M,1:N) +*> by using Level 3 BLAS as +*> +*> A * P(KB) = Q(KB) * R(KB). +*> +*> The routine tries to factorize NB columns from A starting from +*> the row IOFFSET+1 and updates the residual matrix with BLAS 3 +*> xGEMM. The number of actually factorized columns is returned +*> is smaller than NB. +*> +*> Block A(1:IOFFSET,1:N) is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides B matrix stored +*> in A(IOFFSET+1:M,1:N+1:N+NRHS) with Q(KB)**H * B. +*> +*> Cases when the number of factorized columns KB < NB: +*> +*> (1) In some cases, due to catastrophic cancellations, it cannot +*> factorize all NB columns and need to update the residual matrix. +*> Hence, the actual number of factorized columns in the block returned +*> in KB is smaller than NB. The logical DONE is returned as FALSE. +*> The factorization of the whole original matrix A_orig must proceed +*> with the next block. +*> +*> (2) Whenever the stopping criterion ABSTOL or RELTOL is satisfied, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. +*> +*> (3) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix is a zero matrix in some factorization +*> step KB, the factorization of the whole original matrix A_orig is +*> stopped, the logical DONE is returned as TRUE. The number of +*> factorized columns which is smaller than NB is returned in KB. +*> +*> (4) Whenever NaN is detected in the matrix A or in the array TAU, +*> the factorization of the whole original matrix A_orig is stopped, +*> the logical DONE is returned as TRUE. The number of factorized +*> columns which is smaller than NB is returned in KB. The INFO +*> parameter is set to the column index of the first NaN occurrence. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \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] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] NB +*> \verbatim +*> NB is INTEGER +*> Factorization block size, i.e the number of columns +*> to factorize in the matrix A. 0 <= NB +*> +*> If NB = 0, then the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on NB and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine CGEQP3RK. 1 <= KP1 <= N_orig. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is REAL +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine CGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:KB) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(KB) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:KB) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,KB+1:N+NRHS). +*> The left part A(IOFFSET+1:M,KB+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(KB)**H. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] +*> \verbatim +*> DONE is LOGICAL +*> TRUE: a) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to ABSTOL +*> or RELTOL criterion, +*> b) if the factorization completed before processing +*> all min(M-IOFFSET,NB,N) columns due to the +*> residual matrix being a ZERO matrix. +*> c) when NaN was detected in the matrix A +*> or in the array TAU. +*> FALSE: otherwise. +*> \endverbatim +*> +*> \param[out] KB +*> \verbatim +*> KB is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= KB <= min(M-IOFFSET,NB,N). +*> +*> KB also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank KB. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank KB) to the maximum column 2-norm of the +*> original matrix A_orig. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is REAL array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is REAL array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] AUXV +*> \verbatim +*> AUXV is COMPLEX array, dimension (NB) +*> Auxiliary vector. +*> \endverbatim +*> +*> \param[out] F +*> \verbatim +*> F is COMPLEX array, dimension (LDF,NB) +*> Matrix F**H = L*(Y**H)*A. +*> \endverbatim +*> +*> \param[in] LDF +*> \verbatim +*> LDF is INTEGER +*> The leading dimension of the array F. LDF >= max(1,N+NRHS). +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step KB+1 ( when KB columns +*> have been factorized ). +*> +*> On exit: +*> KB is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(KB+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=KB+1, TAU(KB+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the actorization +*> step KB+1 ( when KB columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp3rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> \htmlonly +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> \endhtmlonly +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> \htmlonly +*> https://doi.org/10.1137/S1064827595296732 +*> \endhtmlonly +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> \htmlonly +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> \endhtmlonly +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> \htmlonly +*> https://doi.org/10.1145/1377612.1377616 +*> \endhtmlonly +* +* ===================================================================== + SUBROUTINE CLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, + $ MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ VN1, VN2, AUXV, F, LDF, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary 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 DONE + INTEGER INFO, IOFFSET, KB, KP1, LDA, LDF, M, N, + $ NB, NRHS + REAL ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + REAL VN1( * ), VN2( * ) + COMPLEX A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER ITEMP, J, K, MINMNFACT, MINMNUPDT, + $ LSTICC, KP, I, IF + REAL HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z + COMPLEX AIK +* .. +* .. External Subroutines .. + EXTERNAL CGEMM, CGEMV, CLARFG, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, CONJG, IMAG, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL SISNAN + INTEGER ISAMAX + REAL SLAMCH, SCNRM2 + EXTERNAL SISNAN, SLAMCH, ISAMAX, SCNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + NB = MIN( NB, MINMNFACT ) + TOL3Z = SQRT( SLAMCH( 'Epsilon' ) ) + HUGEVAL = SLAMCH( 'Overflow' ) +* +* Compute factorization in a while loop over NB columns, +* K is the column index in the block A(1:M,1:N). +* + K = 0 + LSTICC = 0 + DONE = .FALSE. +* + DO WHILE ( K.LT.NB .AND. LSTICC.EQ.0 ) + K = K + 1 + I = IOFFSET + K +* + IF( I.EQ.1 ) THEN +* +* We are at the first column of the original whole matrix A_orig, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* + ELSE +* +* Determine the pivot column in K-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( K-1 ) + ISAMAX( N-K+1, VN1( K ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,K:N) in step K. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains NaN, set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( SISNAN( MAXC2NRMK ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = KB + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. + + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* Quick return, if the submatrix A(I:M,K:N) is +* a zero matrix. We need to check it only if the column index +* (same as row index) is larger than 1, since the condition +* for the whole original matrix A_orig is checked in the main +* routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + RELMAXC2NRMK = ZERO +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix is zero and we stop the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. +* + DO J = K, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,K:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + K - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third tolerance stopping criteria. +* NOTE: There is no need to test for ABSTOL.GE.ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL.GE.ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig; +* + KB = K - 1 + IF = I - 1 +* +* Apply the block reflector to the residual of the +* matrix A and the residual of the right hand sides B, if +* the residual matrix and and/or the residual of the right +* hand sides exist, i.e. if the submatrix +* A(I+1:M,KB+1:N+NRHS) exists. This occurs when +* KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, N+NRHS-KB, KB,-CONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KB+1:MINMNFACT) = CZERO, +* which is equivalent to seting TAU(K:MINMNFACT) = CZERO. +* + DO J = K, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,K:N): +* 1) swap the K-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) swap the K-th row and the KP-th row in F(1:N,1:K-1) +* 3) copy the K-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. (Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than K in the next loop step.) +* 4) Save the pivot interchange with the indices relative to the +* the original matrix A_orig, not the block A(1:M,1:N). +* + IF( KP.NE.K ) THEN + CALL CSWAP( M, A( 1, KP ), 1, A( 1, K ), 1 ) + CALL CSWAP( K-1, F( KP, 1 ), LDF, F( K, 1 ), LDF ) + VN1( KP ) = VN1( K ) + VN2( KP ) = VN2( K ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( K ) + JPIV( K ) = ITEMP + END IF +* +* Apply previous Householder reflectors to column K: +* A(I:M,K) := A(I:M,K) - A(I:M,1:K-1)*F(K,1:K-1)**H. +* + IF( K.GT.1 ) THEN + DO J = 1, K - 1 + F( K, J ) = CONJG( F( K, J ) ) + END DO + CALL CGEMV( 'No transpose', M-I+1, K-1, -CONE, A( I, 1 ), + $ LDA, F( K, 1 ), LDF, CONE, A( I, K ), 1 ) + DO J = 1, K - 1 + F( K, J ) = CONJG( F( K, J ) ) + END DO + END IF +* +* Generate elementary reflector H(k) using the column A(I:M,K). +* + IF( I.LT.M ) THEN + CALL CLARFG( M-I+1, A( I, K ), A( I+1, K ), 1, TAU( K ) ) + ELSE + TAU( K ) = CZERO + END IF +* +* Check if TAU(K) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(K) for Inf, +* since CLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by CLARFG can contain Inf, which requires +* TAU(K) to contain NaN. Therefore, this case of generating Inf +* by CLARFG is covered by checking TAU(K) for NaN. +* + IF( SISNAN( REAL( TAU(K) ) ) ) THEN + TAUNAN = REAL( TAU(K) ) + ELSE IF( SISNAN( IMAG( TAU(K) ) ) ) THEN + TAUNAN = IMAG( TAU(K) ) + ELSE + TAUNAN = ZERO + END IF +* + IF( SISNAN( TAUNAN ) ) THEN +* + DONE = .TRUE. +* +* Set KB, the number of factorized partial columns +* that are non-zero in each step in the block, +* i.e. the rank of the factor R. +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig. +* + KB = K - 1 + IF = I - 1 + INFO = K +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAUNAN + RELMAXC2NRMK = TAUNAN +* +* There is no need to apply the block reflector to the +* residual of the matrix A stored in A(KB+1:M,KB+1:N), +* since the submatrix contains NaN and we stop +* the computation. +* But, we need to apply the block reflector to the residual +* right hand sides stored in A(KB+1:M,N+1:N+NRHS), if the +* residual right hand sides exist. This occurs +* when ( NRHS != 0 AND KB <= (M-IOFFSET) ): +* +* A(I+1:M,N+1:N+NRHS) := A(I+1:M,N+1:N+NRHS) - +* A(I+1:M,1:KB) * F(N+1:N+NRHS,1:KB)**H. +* + IF( NRHS.GT.0 .AND. KB.LT.(M-IOFFSET) ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, NRHS, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( N+1, 1 ), LDF, CONE, A( IF+1, N+1 ), LDA ) + END IF +* +* There is no need to recompute the 2-norm of the +* difficult columns, since we stop the factorization. +* +* Array TAU(KF+1:MINMNFACT) is not set and contains +* undefined elements. +* +* Return from the routine. +* + RETURN + END IF +* +* =============================================================== +* + AIK = A( I, K ) + A( I, K ) = CONE +* +* =============================================================== +* +* Compute the current K-th column of F: +* 1) F(K+1:N,K) := tau(K) * A(I:M,K+1:N)**H * A(I:M,K). +* + IF( K.LT.N+NRHS ) THEN + CALL CGEMV( 'Conjugate transpose', M-I+1, N+NRHS-K, + $ TAU( K ), A( I, K+1 ), LDA, A( I, K ), 1, + $ CZERO, F( K+1, K ), 1 ) + END IF +* +* 2) Zero out elements above and on the diagonal of the +* column K in matrix F, i.e elements F(1:K,K). +* + DO J = 1, K + F( J, K ) = CZERO + END DO +* +* 3) Incremental updating of the K-th column of F: +* F(1:N,K) := F(1:N,K) - tau(K) * F(1:N,1:K-1) * A(I:M,1:K-1)**H +* * A(I:M,K). +* + IF( K.GT.1 ) THEN + CALL CGEMV( 'Conjugate Transpose', M-I+1, K-1, -TAU( K ), + $ A( I, 1 ), LDA, A( I, K ), 1, CZERO, + $ AUXV( 1 ), 1 ) +* + CALL CGEMV( 'No transpose', N+NRHS, K-1, CONE, + $ F( 1, 1 ), LDF, AUXV( 1 ), 1, CONE, + $ F( 1, K ), 1 ) + END IF +* +* =============================================================== +* +* Update the current I-th row of A: +* A(I,K+1:N+NRHS) := A(I,K+1:N+NRHS) +* - A(I,1:K)*F(K+1:N+NRHS,1:K)**H. +* + IF( K.LT.N+NRHS ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ 1, N+NRHS-K, K, -CONE, A( I, 1 ), LDA, + $ F( K+1, 1 ), LDF, CONE, A( I, K+1 ), LDA ) + END IF +* + A( I, K ) = AIK +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,K+1:N) exists, i.e. +* when K < MINMNFACT = min( M-IOFFSET, N ). +* + IF( K.LT.MINMNFACT ) THEN +* + DO J = K + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ABS( A( I, J ) ) / VN1( J ) + TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2.LE.TOL3Z ) THEN +* +* At J-index, we have a difficult column for the +* update of the 2-norm. Save the index of the previous +* difficult column in IWORK(J-1). +* NOTE: ILSTCC > 1, threfore we can use IWORK only +* with N-1 elements, where the elements are +* shifted by 1 to the left. +* + IWORK( J-1 ) = LSTICC +* +* Set the index of the last difficult column LSTICC. +* + LSTICC = J +* + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + END DO +* + END IF +* +* End of while loop. +* + END DO +* +* Now, afler the loop: +* Set KB, the number of factorized columns in the block; +* Set IF, the number of processed rows in the block, which +* is the same as the number of processed rows in +* the original whole matrix A_orig, IF = IOFFSET + KB. +* + KB = K + IF = I +* +* Apply the block reflector to the residual of the matrix A +* and the residual of the right hand sides B, if the residual +* matrix and and/or the residual of the right hand sides +* exist, i.e. if the submatrix A(I+1:M,KB+1:N+NRHS) exists. +* This occurs when KB < MINMNUPDT = min( M-IOFFSET, N+NRHS ): +* +* A(IF+1:M,K+1:N+NRHS) := A(IF+1:M,KB+1:N+NRHS) - +* A(IF+1:M,1:KB) * F(KB+1:N+NRHS,1:KB)**H. +* + IF( KB.LT.MINMNUPDT ) THEN + CALL CGEMM( 'No transpose', 'Conjugate transpose', + $ M-IF, N+NRHS-KB, KB, -CONE, A( IF+1, 1 ), LDA, + $ F( KB+1, 1 ), LDF, CONE, A( IF+1, KB+1 ), LDA ) + END IF +* +* Recompute the 2-norm of the difficult columns. +* Loop over the index of the difficult columns from the largest +* to the smallest index. +* + DO WHILE( LSTICC.GT.0 ) +* +* LSTICC is the index of the last difficult column is greater +* than 1. +* ITEMP is the index of the previous difficult column. +* + ITEMP = IWORK( LSTICC-1 ) +* +* Compute the 2-norm explicilty for the last difficult column and +* save it in the partial and exact 2-norm vectors VN1 and VN2. +* +* NOTE: The computation of VN1( LSTICC ) relies on the fact that +* SCNRM2 does not fail on vectors with norm below the value of +* SQRT(SLAMCH('S')) +* + VN1( LSTICC ) = SCNRM2( M-IF, A( IF+1, LSTICC ), 1 ) + VN2( LSTICC ) = VN1( LSTICC ) +* +* Downdate the index of the last difficult column to +* the index of the previous difficult column. +* + LSTICC = ITEMP +* + END DO +* + RETURN +* +* End of CLAQP3RK +* + END diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index ef65e25f5e..cb21ea8f50 100755 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -56,7 +56,7 @@ set(CLINTST cchkaa.F cchkhe.f cchkhe_rook.f cchkhe_rk.f cchkhe_aa.f cchkhe_aa_2stage.f cchkhp.f cchklq.f cchkpb.f - cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkql.f + cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkqp3rk.f cchkql.f cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchksy_rk.f cchksy_aa.f cchksy_aa_2stage.f cchktb.f diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 6ce2d9f117..e6bcafbb3d 100755 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -89,7 +89,7 @@ CLINTST = cchkaa.o \ cchkeq.o cchkgb.o cchkge.o cchkgt.o \ cchkhe.o cchkhe_rook.o cchkhe_rk.o \ cchkhe_aa.o cchkhe_aa_2stage.o cchkhp.o cchklq.o cchkpb.o \ - cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o \ + cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkqp3rk.o cchkql.o \ cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchksy_rk.o \ cchksy_aa.o cchksy_aa_2stage.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ diff --git a/TESTING/LIN/cchkaa.F b/TESTING/LIN/cchkaa.F index ec1534ed4e..474454a519 100644 --- a/TESTING/LIN/cchkaa.F +++ b/TESTING/LIN/cchkaa.F @@ -69,6 +69,7 @@ *> CLQ 8 List types on next line if 0 < NTYPES < 8 *> CQL 8 List types on next line if 0 < NTYPES < 8 *> CQP 6 List types on next line if 0 < NTYPES < 6 +*> ZQK 19 List types on next line if 0 < NTYPES < 19 *> CTZ 3 List types on next line if 0 < NTYPES < 3 *> CLS 6 List types on next line if 0 < NTYPES < 6 *> CEQ @@ -153,12 +154,11 @@ PROGRAM CCHKAA $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) - REAL S( 2*NMAX ) - COMPLEX E( NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus - REAL, DIMENSION(:), ALLOCATABLE :: RWORK + REAL, DIMENSION(:), ALLOCATABLE :: RWORK, S + COMPLEX, DIMENSION(:), ALLOCATABLE :: E COMPLEX, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK * .. * .. External Functions .. @@ -170,14 +170,14 @@ PROGRAM CCHKAA EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE, $ CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKHP, $ CCHKLQ, CCHKUNHR_COL, CCHKPB, CCHKPO, CCHKPS, - $ CCHKPP, CCHKPT, CCHKQ3, CCHKQL, CCHKQR, CCHKRQ, - $ CCHKSP, CCHKSY, CCHKSY_ROOK, CCHKSY_RK, - $ CCHKSY_AA, CCHKTB, CCHKTP, CCHKTR, CCHKTZ, - $ CDRVGB, CDRVGE, CDRVGT, CDRVHE, CDRVHE_ROOK, - $ CDRVHE_RK, CDRVHE_AA, CDRVHP, CDRVLS, CDRVPB, - $ CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY, - $ CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA, ILAVER, - $ CCHKQRT, CCHKQRTP + $ CCHKPP, CCHKPT, CCHKQ3, CCHKQP3RK, CCHKQL, + $ CCHKQR, CCHKRQ, CCHKSP, CCHKSY, CCHKSY_ROOK, + $ CCHKSY_RK, CCHKSY_AA, CCHKTB, CCHKTP, CCHKTR, + $ CCHKTZ, CDRVGB, CDRVGE, CDRVGT, CDRVHE, + $ CDRVHE_ROOK, CDRVHE_RK, CDRVHE_AA, CDRVHP, + $ CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP, + $ CDRVSY, CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA, + $ ILAVER, CCHKQRT, CCHKQRTP * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -203,6 +203,10 @@ PROGRAM CCHKAA IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( WORK( NMAX, NMAX+MAXRHS+10 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( E( NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( RWORK( 150*NMAX+2*MAXRHS ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * .. @@ -1109,6 +1113,23 @@ PROGRAM CCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* QK: truncated QR factorization with pivoting +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A( 1, 1 ), + $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), + $ S( 1 ), B( 1, 4 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN * diff --git a/TESTING/LIN/cchkqp3rk.f b/TESTING/LIN/cchkqp3rk.f new file mode 100644 index 0000000000..79d6add72e --- /dev/null +++ b/TESTING/LIN/cchkqp3rk.f @@ -0,0 +1,836 @@ +*> \brief \b CCHKQP3RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, +* $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, +* $ B, COPYB, S, TAU, +* $ WORK, RWORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ), +* $ NXVAL( * ) +* REAL S( * ), RWORK( * ) +* COMPLEX A( * ), COPYA( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKQP3RK tests CGEQP3RK. +*> \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] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is COMPLEX array, dimension (MMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (MMAX*NSMAX) +*> where MMAX is the maximum value of M in MVAL and NSMAX is the +*> maximum value of NRHS in NSVAL. +*> \endverbatim +*> +*> \param[out] COPYB +*> \verbatim +*> COPYB is COMPLEX array, dimension (MMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is REAL array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension +*> (max(M*max(M,N) + 4*min(M,N) + max(M,N))) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (4*NMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \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 complex_lin +* +* ===================================================================== + SUBROUTINE CCHKQP3RK( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, + $ NNB, NBVAL, NXVAL, THRESH, A, COPYA, + $ B, COPYB, S, TAU, + $ WORK, RWORK, 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 .. + INTEGER NM, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NSVAL( * ), NXVAL( * ) + REAL S( * ), RWORK( * ) + COMPLEX A( * ), COPYA( * ), B( * ), COPYB( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + REAL ONE, ZERO, BIGNUM + COMPLEX CONE, CZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, + $ CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ), + $ BIGNUM = 1.0E+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE + 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, + $ KFACT, KL, KMAX, KU, LDA, LW, LWORK, + $ LWORK_MQR, M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NB_ZERO, NERRS, NFAIL, NB_GEN, NRHS, + $ NRUN, NX, T + REAL ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ), RDUMMY( 1 ) +* .. +* .. External Functions .. + REAL SLAMCH, CQPT01, CQRT11, CQRT12, CLANGE + EXTERNAL SLAMCH, CQPT01, CQRT11, CQRT12, CLANGE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SLAORD, ICOPY, CAXPY, + $ XLAENV, CGEQP3RK, CLACPY, CLASET, CLATB4, + $ CLATMS, CUNMQR, CSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD, REAL +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT, CUNMQR_LWORK +* .. +* .. 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 ) = 'Complex precision' + PATH( 2: 3 ) = 'QK' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = SLAMCH( 'Epsilon' ) + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LWORK = MAX( 1, M*MAX( M, N )+4*MINMN+MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* + DO INS = 1, NNS + NRHS = NSVAL( INS ) +* +* Set up parameters with CLATB4 and generate +* M-by-NRHS B matrix with CLATMS. +* IMAT = 14: +* Random matrix, CNDNUM = 2, NORM = ONE, +* MODE = 3 (geometric distribution of singular values). +* + CALL CLATB4( PATH, 14, M, NRHS, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMS' + CALL CLATMS( M, NRHS, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYB, LDA, WORK, INFO ) +* +* Check error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M, + $ NRHS, -1, -1, -1, 6, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + DO IMAT = 1, 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 +* 2. Random, Diagonal, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 11. Random, Half MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 ONE 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) ONE 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS ONE 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, CNDNUM = BADC2 = 0.1/EPS ONE 2 ( one small singular value, S(N)=1/CNDNUM ) +* one small singular value S(N)=1/CNDNUM +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1: Zero matrix +* + CALL CLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA ) + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( (IMAT.GE.2 .AND. IMAT.LE.4 ) + $ .OR. (IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrices 2-5. +* +* Set up parameters with DLATB4 and generate a test +* matrix with CLATMS. +* + CALL CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMS' + CALL CLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* + CALL SLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Rectangular matrices 5-13 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 +* for matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column. +* + IF( IMAT.EQ.5 ) THEN +* +* First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* 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 +* +* First half of MINMN columns is zero. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Last columns are zero columns, +* starting from (MINMN / 2 + 1) column. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - JB_ZERO + 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Half of the columns in the middle of MINMN +* columns is zero, starting from +* MINMN/2 - (MINMN/2)/2 + 1 column. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* 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 +* +* 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 CLASET( 'Full', M, NB_ZERO, CZERO, CZERO, + $ 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 CLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL CLATMS( 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 CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', 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 CSWAP( 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 CSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing order and add trailing zeros +* that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) +* + CALL SLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) + + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF(MINMN.LT.2) skip this size for this matrix type. +* + CYCLE + END IF +* +* Initialize a copy array for a pivot array for DGEQP3RK. +* + DO I = 1, N + IWORK( I ) = 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 KMAX = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYB into A( 1:M, (N+1):NRHS ). +* Get a working copy of COPYB into into B( 1:M, 1:NRHS ). +* Get a working copy of IWORK(1:N) awith zeroes into +* which is going to be used as pivot array IWORK( N+1:2N ). +* NOTE: IWORK(2N+1:3N) is going to be used as a WORK array +* for the routine. +* + CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL CLACPY( 'All', M, NRHS, COPYB, LDA, + $ A( LDA*N + 1 ), LDA ) + CALL CLACPY( 'All', M, NRHS, COPYB, LDA, + $ B, LDA ) + CALL ICOPY( N, IWORK( 1 ), 1, IWORK( N+1 ), 1 ) +* + ABSTOL = -1.0 + RELTOl = -1.0 +* +* Compute the QR factorization with pivoting of A +* + LW = MAX( 1, MAX( 2*N + NB*( N+NRHS+1 ), + $ 3*N + NRHS - 1 ) ) +* +* Compute CGEQP3RK factorization of A. +* + SRNAMT = 'CGEQP3RK' + CALL CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ A, LDA, KFACT, MAXC2NRMK, + $ RELMAXC2NRMK, IWORK( N+1 ), TAU, + $ WORK, LW, RWORK, IWORK( 2*N+1 ), + $ INFO ) +* +* Check error code from CGEQP3RK. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'CGEQP3RK', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* + IF( KFACT.EQ.MINMN ) THEN +* +* 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 ) +* + RESULT( 1 ) = CQRT12( M, N, A, LDA, S, WORK, + $ LWORK , RWORK ) +* + DO T = 1, 1 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, NB, NX, + $ IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + 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 ) = CQPT01( M, N, KFACT, COPYA, A, LDA, TAU, + $ IWORK( N+1 ), WORK, LWORK ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = CQRT11( M, KFACT, A, LDA, TAU, WORK, + $ LWORK ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 2, 3 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater than 2. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+100 if abs(R(K+1,K+1)) > abs(R(K,K)), +* K=1:KFACT-1 +* + IF( MIN(KFACT, MINMN).GE.2 ) THEN +* + DO J = 1, KFACT-1, 1 +* + DTEMP = (( ABS( A( (J-1)*M+J ) ) - + $ ABS( A( (J)*M+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 4, 4 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', + $ M, N, NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, + $ RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* Compute test 5: +* +* This test in only for matrix A with min(M,N) > 0. +* +* The test returns the ratio: +* +* 1-norm(Q**T * B - Q**T * B ) / +* ( M * EPS ) +* +* (1) Compute B:=Q**T * B in the matrix B. +* + IF( MINMN.GT.0 ) THEN +* + LWORK_MQR = MAX(1, NRHS) + CALL CUNMQR( 'Left', 'Conjugate transpose', + $ M, NRHS, KFACT, A, LDA, TAU, B, LDA, + $ WORK, LWORK_MQR, INFO ) +* + DO I = 1, NRHS +* +* Compare N+J-th column of A and J-column of B. +* + CALL CAXPY( M, -CONE, A( ( N+I-1 )*LDA+1 ), 1, + $ B( ( I-1 )*LDA+1 ), 1 ) + END DO +* + RESULT( 5 ) = + $ ABS( + $ CLANGE( 'One-norm', M, NRHS, B, LDA, RDUMMY ) / + $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) + $ ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO T = 5, 5 + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'CGEQP3RK', M, N, + $ NRHS, KMAX, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO + NRUN = NRUN + 1 +* +* End compute test 5. +* + END IF +* +* 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 INS = 1, NNS +* + 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, ', NRHS =', I5, + $ ', KMAX =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of CCHKQP3RK +* + END diff --git a/TESTING/LIN/clatb4.f b/TESTING/LIN/clatb4.f index e04ba3dfe1..233a8631a8 100644 --- a/TESTING/LIN/clatb4.f +++ b/TESTING/LIN/clatb4.f @@ -225,6 +225,110 @@ SUBROUTINE CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE ANORM = ONE END IF +* + ELSE IF( LSAMEN( 2, C2, 'QK' ) ) THEN +* +* xQK: truncated QR with pivoting. +* 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' is +* + DIST = 'S' +* +* Set the lower and upper bandwidths. +* + 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, 'GE' ) ) THEN * diff --git a/TESTING/LIN/cqpt01.f b/TESTING/LIN/cqpt01.f index 79fc2dc66c..149c5bb7c7 100644 --- a/TESTING/LIN/cqpt01.f +++ b/TESTING/LIN/cqpt01.f @@ -33,7 +33,8 @@ *> Householder vectors, and the rest of AF contains a partially updated *> matrix. *> -*> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M) +*> This function returns ||A*P - Q*R|| / ( ||norm(A)||*eps*max(M,N) ) +*> where || . || is matrix one norm. *> \endverbatim * * Arguments: @@ -172,28 +173,28 @@ REAL FUNCTION CQPT01( M, N, K, A, AF, LDA, TAU, JPVT, * NORMA = CLANGE( 'One-norm', M, N, A, LDA, RWORK ) * - DO 30 J = 1, K - DO 10 I = 1, MIN( J, M ) + DO J = 1, K + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = AF( I, J ) - 10 CONTINUE - DO 20 I = J + 1, M + END DO + DO I = J + 1, M WORK( ( J-1 )*M+I ) = ZERO - 20 CONTINUE - 30 CONTINUE - DO 40 J = K + 1, N + END DO + END DO + DO J = K + 1, N CALL CCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 ) - 40 CONTINUE + END DO * CALL CUNMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK, $ M, WORK( M*N+1 ), LWORK-M*N, INFO ) * - DO 50 J = 1, N + DO J = 1, N * * Compare i-th column of QR and jpvt(i)-th column of A * CALL CAXPY( M, CMPLX( -ONE ), A( 1, JPVT( J ) ), 1, $ WORK( ( J-1 )*M+1 ), 1 ) - 50 CONTINUE + END DO * CQPT01 = CLANGE( 'One-norm', M, N, WORK, M, RWORK ) / $ ( REAL( MAX( M, N ) )*SLAMCH( 'Epsilon' ) ) diff --git a/TESTING/LIN/cqrt11.f b/TESTING/LIN/cqrt11.f index 494d5e9cd7..a520849737 100644 --- a/TESTING/LIN/cqrt11.f +++ b/TESTING/LIN/cqrt11.f @@ -157,9 +157,9 @@ REAL FUNCTION CQRT11( M, K, A, LDA, TAU, WORK, LWORK ) CALL CUNM2R( 'Left', 'Conjugate transpose', M, M, K, A, LDA, TAU, $ WORK, M, WORK( M*M+1 ), INFO ) * - DO 10 J = 1, M + DO J = 1, M WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE - 10 CONTINUE + END DO * CQRT11 = CLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) / $ ( REAL( M )*SLAMCH( 'Epsilon' ) ) diff --git a/TESTING/LIN/cqrt12.f b/TESTING/LIN/cqrt12.f index 80ff6dbdf9..0df2d833b9 100644 --- a/TESTING/LIN/cqrt12.f +++ b/TESTING/LIN/cqrt12.f @@ -28,7 +28,7 @@ *> CQRT12 computes the singular values `svlues' of the upper trapezoid *> of A(1:M,1:N) and returns the ratio *> -*> || s - svlues||/(||svlues||*eps*max(M,N)) +*> || svlues -s ||/( ||s||*eps*max(M,N) ) *> \endverbatim * * Arguments: @@ -153,11 +153,11 @@ REAL FUNCTION CQRT12( M, N, A, LDA, S, WORK, LWORK, * Copy upper triangle of A into work * CALL CLASET( 'Full', M, N, CMPLX( ZERO ), CMPLX( ZERO ), WORK, M ) - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) + DO J = 1, N + DO I = 1, MIN( J, M ) WORK( ( J-1 )*M+I ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE + END DO + END DO * * Get machine parameters * @@ -206,9 +206,9 @@ REAL FUNCTION CQRT12( M, N, A, LDA, S, WORK, LWORK, * ELSE * - DO 30 I = 1, MN + DO I = 1, MN RWORK( I ) = ZERO - 30 CONTINUE + END DO END IF * * Compare s and singular values of work diff --git a/TESTING/ctest.in b/TESTING/ctest.in index a3588b4a12..74ff31ab8d 100644 --- a/TESTING/ctest.in +++ b/TESTING/ctest.in @@ -42,6 +42,7 @@ CRQ 8 List types on next line if 0 < NTYPES < 8 CLQ 8 List types on next line if 0 < NTYPES < 8 CQL 8 List types on next line if 0 < NTYPES < 8 CQP 6 List types on next line if 0 < NTYPES < 6 +CQK 19 List types on next line if 0 < NTYPES < 19 CTZ 3 List types on next line if 0 < NTYPES < 3 CLS 6 List types on next line if 0 < NTYPES < 6 CEQ From 7603b627095b190e5799e8ad2eeaa301a7ed5932 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:11 -0800 Subject: [PATCH 103/106] UPDATED the descriptions of the new truncated QR routines --- SRC/cgeqp3rk.f | 11 +++++++++++ SRC/claqp2rk.f | 11 +++++++++++ SRC/claqp3rk.f | 11 +++++++++++ SRC/dgeqp3rk.f | 11 +++++++++++ SRC/dlaqp2rk.f | 11 +++++++++++ SRC/dlaqp3rk.f | 11 +++++++++++ SRC/sgeqp3rk.f | 11 +++++++++++ SRC/slaqp2rk.f | 11 +++++++++++ SRC/slaqp3rk.f | 11 +++++++++++ SRC/zgeqp3rk.f | 11 +++++++++++ SRC/zlaqp2rk.f | 11 +++++++++++ SRC/zlaqp3rk.f | 11 +++++++++++ 12 files changed, 132 insertions(+) diff --git a/SRC/cgeqp3rk.f b/SRC/cgeqp3rk.f index c67ef0c771..70789e64fb 100755 --- a/SRC/cgeqp3rk.f +++ b/SRC/cgeqp3rk.f @@ -573,6 +573,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, diff --git a/SRC/claqp2rk.f b/SRC/claqp2rk.f index 8a79734930..073ad0f88d 100755 --- a/SRC/claqp2rk.f +++ b/SRC/claqp2rk.f @@ -326,6 +326,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, diff --git a/SRC/claqp3rk.f b/SRC/claqp3rk.f index 2a7d1c2ed5..af5e856457 100755 --- a/SRC/claqp3rk.f +++ b/SRC/claqp3rk.f @@ -377,6 +377,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE CLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, diff --git a/SRC/dgeqp3rk.f b/SRC/dgeqp3rk.f index 090e276122..ace97b712b 100755 --- a/SRC/dgeqp3rk.f +++ b/SRC/dgeqp3rk.f @@ -567,6 +567,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, diff --git a/SRC/dlaqp2rk.f b/SRC/dlaqp2rk.f index 3fd29e2673..b5a84d0de1 100755 --- a/SRC/dlaqp2rk.f +++ b/SRC/dlaqp2rk.f @@ -325,6 +325,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index ed7296c80a..6e044c160f 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -383,6 +383,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, diff --git a/SRC/sgeqp3rk.f b/SRC/sgeqp3rk.f index 6319892fe8..17559c7f44 100755 --- a/SRC/sgeqp3rk.f +++ b/SRC/sgeqp3rk.f @@ -567,6 +567,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, diff --git a/SRC/slaqp2rk.f b/SRC/slaqp2rk.f index ba5eeb204e..d3dbb3d7c1 100755 --- a/SRC/slaqp2rk.f +++ b/SRC/slaqp2rk.f @@ -325,6 +325,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, diff --git a/SRC/slaqp3rk.f b/SRC/slaqp3rk.f index 4f1479174b..fa735bb9d7 100755 --- a/SRC/slaqp3rk.f +++ b/SRC/slaqp3rk.f @@ -383,6 +383,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE SLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, diff --git a/SRC/zgeqp3rk.f b/SRC/zgeqp3rk.f index 0cfc459b91..f8ef986c70 100755 --- a/SRC/zgeqp3rk.f +++ b/SRC/zgeqp3rk.f @@ -573,6 +573,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, diff --git a/SRC/zlaqp2rk.f b/SRC/zlaqp2rk.f index 2e89254e6c..f1e9f48993 100755 --- a/SRC/zlaqp2rk.f +++ b/SRC/zlaqp2rk.f @@ -326,6 +326,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, diff --git a/SRC/zlaqp3rk.f b/SRC/zlaqp3rk.f index 1b61faeb80..7a9fdfd95b 100755 --- a/SRC/zlaqp3rk.f +++ b/SRC/zlaqp3rk.f @@ -377,6 +377,17 @@ *> https://doi.org/10.1145/1377612.1377616 *> \endhtmlonly * +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> Computer Science Division, +*> University of California, Berkeley +*> +*> \endverbatim +* * ===================================================================== SUBROUTINE ZLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, $ RELTOL, KP1, MAXC2NRM, A, LDA, DONE, KB, From d64a6ca96d6477799a4efe90223d38b1fc7eb264 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 04:42:11 -0800 Subject: [PATCH 104/106] fixed a typo-bug for intrinsics in dlaqp3rk.f --- SRC/dlaqp3rk.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/SRC/dlaqp3rk.f b/SRC/dlaqp3rk.f index 6e044c160f..39e617d0e1 100755 --- a/SRC/dlaqp3rk.f +++ b/SRC/dlaqp3rk.f @@ -433,7 +433,7 @@ SUBROUTINE DLAQP3RK( M, N, NRHS, IOFFSET, NB, ABSTOL, EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP * .. * .. Intrinsic Functions .. - INTRINSIC ABS, f, MIN, SQRT + INTRINSIC ABS, MAX, MIN, SQRT * .. * .. External Functions .. LOGICAL DISNAN From 21e33bd707e087f02b8b21a04bc8d4386f3e2967 Mon Sep 17 00:00:00 2001 From: scr2016 Date: Tue, 14 Nov 2023 03:56:48 -0800 Subject: [PATCH 105/106] final trucated QR From 8d448619820f18a1749edf133eadfdbeb16b47f8 Mon Sep 17 00:00:00 2001 From: scr2016 <1015908+scr2016@users.noreply.github.com> Date: Tue, 14 Nov 2023 05:35:24 -0800 Subject: [PATCH 106/106] fixed a type for adding TESTING/LIN/zchkqp3rk.f into CMakeLists.txt --- TESTING/LIN/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index cb21ea8f50..5e691c3bd0 100755 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -158,7 +158,7 @@ set(ZLINTST zchkaa.F zchkhe.f zchkhe_rook.f zchkhe_rk.f zchkhe_aa.f zchkhe_aa_2stage.f zchkhp.f zchklq.f zchkpb.f - zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkq3rk.f zchkql.f + zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkqp3rk.f zchkql.f zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f zchksy_aa.f zchksy_aa_2stage.f zchktb.f