Implement truncated QR with pivoting (Reference-LAPACK PR 891)

lapack-netlib/SRC/claqp2rk.f

@@ -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

lapack-netlib/SRC/claqp3rk.f

@@ -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

lapack-netlib/SRC/dlaqp2rk.f

@@ -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

lapack-netlib/SRC/dlaqp3rk.f

@@ -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

lapack-netlib/SRC/ilaenv.f

@@ -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

lapack-netlib/SRC/slaqp2rk.f

@@ -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

lapack-netlib/SRC/slaqp3rk.f

@@ -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

lapack-netlib/SRC/zlaqp2rk.f

@@ -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

lapack-netlib/SRC/zlaqp3rk.f

@@ -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