sgeqp3.f

*> \brief \b SGEQP3
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SGEQP3 + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sgeqp3.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sgeqp3.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sgeqp3.f">
*> [TXT]</a>
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LWORK, M, N
*       ..
*       .. Array Arguments ..
*       INTEGER            JPVT( * )
*       REAL               A( LDA, * ), TAU( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGEQP3 computes a QR factorization with column pivoting of a
*> matrix A:  A*P = Q*R  using Level 3 BLAS.
*> \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,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the M-by-N matrix A.
*>          On exit, the upper triangle of the array contains the
*>          min(M,N)-by-N upper trapezoidal matrix R; the elements below
*>          the diagonal, together with the array TAU, represent the
*>          orthogonal matrix Q as a product of min(M,N) elementary
*>          reflectors.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in,out] JPVT
*> \verbatim
*>          JPVT is INTEGER array, dimension (N)
*>          On entry, if JPVT(J).ne.0, the J-th column of A is permuted
*>          to the front of A*P (a leading column); if JPVT(J)=0,
*>          the J-th column of A is a free column.
*>          On exit, if JPVT(J)=K, then the J-th column of A*P was the
*>          the K-th column of A.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*>          TAU is REAL array, dimension (min(M,N))
*>          The scalar factors of the elementary reflectors.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (MAX(1,LWORK))
*>          On exit, if INFO=0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK. LWORK >= 3*N+1.
*>          For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB
*>          is the optimal blocksize.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit.
*>          < 0: if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup geqp3
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The matrix Q is represented as a product of elementary reflectors
*>
*>     Q = H(1) H(2) . . . H(k), where k = min(m,n).
*>
*>  Each H(i) has the form
*>
*>     H(i) = I - tau * v * v**T
*>
*>  where tau is a real scalar, and v is a real/complex vector
*>  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
*>  A(i+1:m,i), and tau in TAU(i).
*> \endverbatim
*
*> \par Contributors:
*  ==================
*>
*>    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
*>    X. Sun, Computer Science Dept., Duke University, USA
*>
*  =====================================================================
      SUBROUTINE sgeqp3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LWORK, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            JPVT( * )
      REAL               A( lda, * ), TAU( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            INB, INBMIN, IXOVER
      parameter( inb = 1, inbmin = 2, ixover = 3 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB,
     $                   nbmin, nfxd, nx, sm, sminmn, sn, topbmn
*     ..
*     .. External Subroutines ..
      EXTERNAL           sgeqrf, slaqp2, slaqps, sormqr, sswap, xerbla
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      REAL               SNRM2
      EXTERNAL           ilaenv, snrm2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          int, max, min
*     Test input arguments
*  ====================
*
      info = 0
      lquery = ( lwork.EQ.-1 )
      IF( m.LT.0 ) THEN
         info = -1
      ELSE IF( n.LT.0 ) THEN
         info = -2
      ELSE IF( lda.LT.max( 1, m ) ) THEN
         info = -4
      END IF
*
      IF( info.EQ.0 ) THEN
         minmn = min( m, n )
         IF( minmn.EQ.0 ) THEN
            iws = 1
            lwkopt = 1
         ELSE
            iws = 3*n + 1
            nb = ilaenv( inb, 'SGEQRF', ' ', m, n, -1, -1 )
            lwkopt = 2*n + ( n + 1 )*nb
         END IF
         work( 1 ) = lwkopt
*
         IF( ( lwork.LT.iws ) .AND. .NOT.lquery ) THEN
            info = -8
         END IF
      END IF
*
      IF( info.NE.0 ) THEN
         CALL xerbla( 'SGEQP3', -info )
         RETURN
      ELSE IF( lquery ) THEN
         RETURN
      END IF
*
*     Move initial columns up front.
*
      nfxd = 1
      DO 10 j = 1, n
         IF( jpvt( j ).NE.0 ) THEN
            IF( j.NE.nfxd ) THEN
               CALL sswap( m, a( 1, j ), 1, a( 1, nfxd ), 1 )
               jpvt( j ) = jpvt( nfxd )
               jpvt( nfxd ) = j
            ELSE
               jpvt( j ) = j
            END IF
            nfxd = nfxd + 1
         ELSE
            jpvt( j ) = j
         END IF
   10 CONTINUE
      nfxd = nfxd - 1
*
*     Factorize fixed columns
*  =======================
*
*     Compute the QR factorization of fixed columns and update
*     remaining columns.
*
      IF( nfxd.GT.0 ) THEN
         na = min( m, nfxd )
*CC      CALL SGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
         CALL sgeqrf( m, na, a, lda, tau, work, lwork, info )
         iws = max( iws, int( work( 1 ) ) )
         IF( na.LT.n ) THEN
*CC         CALL SORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
*CC  $                   TAU, A( 1, NA+1 ), LDA, WORK, INFO )
            CALL sormqr( 'Left', 'Transpose', m, n-na, na, a, lda, tau,
     $                   a( 1, na+1 ), lda, work, lwork, info )
            iws = max( iws, int( work( 1 ) ) )
         END IF
      END IF
*
*     Factorize free columns
*  ======================
*
      IF( nfxd.LT.minmn ) THEN
*
         sm = m - nfxd
         sn = n - nfxd
         sminmn = minmn - nfxd
*
*        Determine the block size.
*
         nb = ilaenv( inb, 'SGEQRF', ' ', sm, sn, -1, -1 )
         nbmin = 2
         nx = 0
*
         IF( ( nb.GT.1 ) .AND. ( nb.LT.sminmn ) ) THEN
*
*           Determine when to cross over from blocked to unblocked code.
*
            nx = max( 0, ilaenv( ixover, 'SGEQRF', ' ', sm, sn, -1,
     $           -1 ) )
*
*
            IF( nx.LT.sminmn ) THEN
*
*              Determine if workspace is large enough for blocked code.
*
               minws = 2*sn + ( sn+1 )*nb
               iws = max( iws, minws )
               IF( lwork.LT.minws ) THEN
*
*                 Not enough workspace to use optimal NB: Reduce NB and
*                 determine the minimum value of NB.
*
                  nb = ( lwork-2*sn ) / ( sn+1 )
                  nbmin = max( 2, ilaenv( inbmin, 'SGEQRF', ' ', sm, sn,
     $                    -1, -1 ) )
*
*
               END IF
            END IF
         END IF
*
*        Initialize partial column norms. The first N elements of work
*        store the exact column norms.
*
         DO 20 j = nfxd + 1, n
            work( j ) = snrm2( sm, a( nfxd+1, j ), 1 )
            work( n+j ) = work( j )
   20    CONTINUE
*
         IF( ( nb.GE.nbmin ) .AND. ( nb.LT.sminmn ) .AND.
     $       ( nx.LT.sminmn ) ) THEN
*
*           Use blocked code initially.
*
            j = nfxd + 1
*
*           Compute factorization: while loop.
*
*
            topbmn = minmn - nx
   30       CONTINUE
            IF( j.LE.topbmn ) THEN
               jb = min( nb, topbmn-j+1 )
*
*              Factorize JB columns among columns J:N.
*
               CALL slaqps( m, n-j+1, j-1, jb, fjb, a( 1, j ), lda,
     $                      jpvt( j ), tau( j ), work( j ), work( n+j ),
     $                      work( 2*n+1 ), work( 2*n+jb+1 ), n-j+1 )
*
               j = j + fjb
               GO TO 30
            END IF
         ELSE
            j = nfxd + 1
         END IF
*
*        Use unblocked code to factor the last or only block.
*
*
         IF( j.LE.minmn )
     $      CALL slaqp2( m, n-j+1, j-1, a( 1, j ), lda, jpvt( j ),
     $                   tau( j ), work( j ), work( n+j ),
     $                   work( 2*n+1 ) )
*
      END IF
*
      work( 1 ) = iws
      RETURN
*
*     End of SGEQP3
*
      END