Martin Kroeker
GitHub
2 years ago
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
13 changed files with 11006 additions and 1 deletions
Split View
Diff Options
-
+1091 -0lapack-netlib/SRC/cgeqp3rk.f
-
+726 -0lapack-netlib/SRC/claqp2rk.f
-
+947 -0lapack-netlib/SRC/claqp3rk.f
-
+1081 -0lapack-netlib/SRC/dgeqp3rk.f
-
+713 -0lapack-netlib/SRC/dlaqp2rk.f
-
+935 -0lapack-netlib/SRC/dlaqp3rk.f
-
+20 -1lapack-netlib/SRC/ilaenv.f
-
+1081 -0lapack-netlib/SRC/sgeqp3rk.f
-
+713 -0lapack-netlib/SRC/slaqp2rk.f
-
+935 -0lapack-netlib/SRC/slaqp3rk.f
-
+1091 -0lapack-netlib/SRC/zgeqp3rk.f
-
+726 -0lapack-netlib/SRC/zlaqp2rk.f
-
+947 -0lapack-netlib/SRC/zlaqp3rk.f
+ 1091
- 0
lapack-netlib/SRC/cgeqp3rk.f
File diff suppressed because it is too large
View File
+ 726
- 0
lapack-netlib/SRC/claqp2rk.f
View File
| @@ -0,0 +1,726 @@ | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/claqp2rk.f"> | |||
| *> [TGZ]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/claqp2rk.f"> | |||
| *> [ZIP]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/claqp2rk.f"> | |||
| *> [TXT]</a> | |||
| *> \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 | |||
| *> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a> | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a> | |||
| *> \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, | |||
| $ 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 | |||
+ 947
- 0
lapack-netlib/SRC/claqp3rk.f
View File
| @@ -0,0 +1,947 @@ | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/claqp3rk.f"> | |||
| *> [TGZ]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/claqp3rk.f"> | |||
| *> [ZIP]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/claqp3rk.f"> | |||
| *> [TXT]</a> | |||
| *> \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 | |||
| *> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a> | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a> | |||
| *> \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, | |||
| $ 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 | |||
+ 1081
- 0
lapack-netlib/SRC/dgeqp3rk.f
File diff suppressed because it is too large
View File
+ 713
- 0
lapack-netlib/SRC/dlaqp2rk.f
View File
| @@ -0,0 +1,713 @@ | |||
| *> \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 =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| *> \htmlonly | |||
| *> Download DLAQP2RK + dependencies | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaqp2rk.f"> | |||
| *> [TGZ]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaqp2rk.f"> | |||
| *> [ZIP]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaqp2rk.f"> | |||
| *> [TXT]</a> | |||
| *> \endhtmlonly | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * SUBROUTINE DLAQP2RK( 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 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 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 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 computed in the main routine DGEQP3RK. | |||
| *> 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: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 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] WORK | |||
| *> \verbatim | |||
| *> WORK is DOUBLE PRECISION array, dimension (N-1) | |||
| *> Used in DLARF 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 | |||
| *> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a> | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a> | |||
| *> \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, | |||
| $ 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 A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), | |||
| $ WORK( * ) | |||
| * .. | |||
| * | |||
| * ===================================================================== | |||
| * | |||
| * .. Parameters .. | |||
| DOUBLE PRECISION ZERO, ONE | |||
| PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) | |||
| * .. | |||
| * .. Local Scalars .. | |||
| INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, | |||
| $ MINMNUPDT | |||
| DOUBLE PRECISION AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL DLARF, DLARFG, DSWAP | |||
| * .. | |||
| * .. Intrinsic Functions .. | |||
| INTRINSIC ABS, MAX, MIN, SQRT | |||
| * .. | |||
| * .. External Functions .. | |||
| LOGICAL DISNAN | |||
| INTEGER IDAMAX | |||
| DOUBLE PRECISION 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. | |||
| * | |||
| * 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' ) | |||
| * | |||
| * 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 ) + 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 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 DSWAP( 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 DLARFG( 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 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 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 | |||
| 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 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( 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 ) = 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 | |||
| * | |||
| * 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 + 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 ZERO. | |||
| * | |||
| DO J = K + 1, MINMNFACT | |||
| TAU( J ) = ZERO | |||
| END DO | |||
| * | |||
| RETURN | |||
| * | |||
| * End of DLAQP2RK | |||
| * | |||
| END | |||
+ 935
- 0
lapack-netlib/SRC/dlaqp3rk.f
View File
| @@ -0,0 +1,935 @@ | |||
| *> \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 =========== | |||
| * | |||
| * Online html documentation available at | |||
| * http://www.netlib.org/lapack/explore-html/ | |||
| * | |||
| *> \htmlonly | |||
| *> Download DLAQP3RK + dependencies | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlaqp3rk.f"> | |||
| *> [TGZ]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlaqp3rk.f"> | |||
| *> [ZIP]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlaqp3rk.f"> | |||
| *> [TXT]</a> | |||
| *> \endhtmlonly | |||
| * | |||
| * Definition: | |||
| * =========== | |||
| * | |||
| * 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, 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 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 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 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 DGEQP3RK. 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 DGEQP3RK. | |||
| *> 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)**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 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**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 | |||
| *> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a> | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a> | |||
| *> \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, | |||
| $ 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 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, MINMNUPDT, | |||
| $ LSTICC, KP, I, IF | |||
| DOUBLE PRECISION AIK, HUGEVAL, TEMP, TEMP2, TOL3Z | |||
| * .. | |||
| * .. External Subroutines .. | |||
| EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP | |||
| * .. | |||
| * .. Intrinsic Functions .. | |||
| INTRINSIC ABS, MAX, MIN, SQRT | |||
| * .. | |||
| * .. External Functions .. | |||
| LOGICAL DISNAN | |||
| INTEGER IDAMAX | |||
| DOUBLE PRECISION 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 ) | |||
| NB = MIN( NB, MINMNFACT ) | |||
| 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). | |||
| * | |||
| 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)**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 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 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) = 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 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) = 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 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 | |||
| * | |||
| * 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 contain 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 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 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 | |||
| * | |||
| * =============================================================== | |||
| * | |||
| * 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+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, | |||
| $ 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 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. | |||
| * | |||
| 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-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 DLAQP3RK | |||
| * | |||
| END | |||
+ 20
- 1
lapack-netlib/SRC/ilaenv.f
View File
| @@ -132,7 +132,7 @@ | |||
| *> \author Univ. of Colorado Denver | |||
| *> \author NAG Ltd. | |||
| * | |||
| *> \ingroup OTHERauxiliary | |||
| *> \ingroup ilaenv | |||
| * | |||
| *> \par Further Details: | |||
| * ===================== | |||
| @@ -355,6 +355,12 @@ | |||
| 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 @@ | |||
| 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 @@ | |||
| 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 | |||
+ 1081
- 0
lapack-netlib/SRC/sgeqp3rk.f
File diff suppressed because it is too large
View File
+ 713
- 0
lapack-netlib/SRC/slaqp2rk.f
View File
| @@ -0,0 +1,713 @@ | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slaqp2rk.f"> | |||
| *> [TGZ]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slaqp2rk.f"> | |||
| *> [ZIP]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slaqp2rk.f"> | |||
| *> [TXT]</a> | |||
| *> \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 | |||
| *> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a> | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a> | |||
| *> \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, | |||
| $ 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 | |||
+ 935
- 0
lapack-netlib/SRC/slaqp3rk.f
View File
| @@ -0,0 +1,935 @@ | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slaqp3rk.f"> | |||
| *> [TGZ]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slaqp3rk.f"> | |||
| *> [ZIP]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slaqp3rk.f"> | |||
| *> [TXT]</a> | |||
| *> \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 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 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: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 | |||
| *> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a> | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a> | |||
| *> \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, | |||
| $ 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 | |||
+ 1091
- 0
lapack-netlib/SRC/zgeqp3rk.f
File diff suppressed because it is too large
View File
+ 726
- 0
lapack-netlib/SRC/zlaqp2rk.f
View File
| @@ -0,0 +1,726 @@ | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqp2rk.f"> | |||
| *> [TGZ]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqp2rk.f"> | |||
| *> [ZIP]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqp2rk.f"> | |||
| *> [TXT]</a> | |||
| *> \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 COMPLEX*16 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 | |||
| *> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a> | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a> | |||
| *> \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, | |||
| $ 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' ) | |||
| * | |||
| * 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 ) + 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 | |||
| * | |||
| * 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 | |||
| * | |||
| * 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. | |||
| * | |||
| 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 | |||
| * | |||
| RETURN | |||
| * | |||
| * End of ZLAQP2RK | |||
| * | |||
| END | |||
+ 947
- 0
lapack-netlib/SRC/zlaqp3rk.f
View File
| @@ -0,0 +1,947 @@ | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlaqp3rk.f"> | |||
| *> [TGZ]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlaqp3rk.f"> | |||
| *> [ZIP]</a> | |||
| *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlaqp3rk.f"> | |||
| *> [TXT]</a> | |||
| *> \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 | |||
| * .. | |||
| * .. 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 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: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 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] AUXV | |||
| *> \verbatim | |||
| *> AUXV is COMPLEX*16 array, dimension (NB) | |||
| *> Auxiliary vector. | |||
| *> \endverbatim | |||
| *> | |||
| *> \param[out] F | |||
| *> \verbatim | |||
| *> F is COMPLEX*16 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 | |||
| *> <a href="https://www.netlib.org/lapack/lawnspdf/lawn114.pdf">https://www.netlib.org/lapack/lawnspdf/lawn114.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1137/S1064827595296732">https://doi.org/10.1137/S1064827595296732</a> | |||
| *> \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 | |||
| *> <a href="http://www.netlib.org/lapack/lawnspdf/lawn176.pdf">http://www.netlib.org/lapack/lawnspdf/lawn176.pdf</a> | |||
| *> \endhtmlonly | |||
| *> and in | |||
| *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. | |||
| *> \htmlonly | |||
| *> <a href="https://doi.org/10.1145/1377612.1377616">https://doi.org/10.1145/1377612.1377616</a> | |||
| *> \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, | |||
| $ 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' ) | |||
| * | |||
| * 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 | |||
| * | |||
| 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 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 | |||
| * | |||
| * 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 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 | |||
| * | |||
| * 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. | |||
| * | |||
| 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. | |||
| * | |||
| 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 | |||
| * 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 | |||
| * | |||
| RETURN | |||
| * | |||
| * End of ZLAQP3RK | |||
| * | |||
| END | |||