dgeqp3()

subroutine dgeqp3	(	integer	m,
		integer	n,
		double precision, dimension( lda, * )	a,
		integer	lda,
		integer, dimension( * )	jpvt,
		double precision, dimension( * )	tau,
		double precision, dimension( * )	work,
		integer	lwork,
		integer	info )

DGEQP3

Download DGEQP3 + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DGEQP3 computes a QR factorization with column pivoting of a
!> matrix A:  A*P = Q*R  using Level 3 BLAS.
!> 

Parameters

[in]	M	!> M is INTEGER !> The number of rows of the matrix A. M >= 0. !>
[in]	N	!> N is INTEGER !> The number of columns of the matrix A. N >= 0. !>
[in,out]	A	!> A is DOUBLE PRECISION 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. !>
[in]	LDA	!> LDA is INTEGER !> The leading dimension of the array A. LDA >= max(1,M). !>
[in,out]	JPVT	!> 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. !>
[out]	TAU	!> TAU is DOUBLE PRECISION array, dimension (min(M,N)) !> The scalar factors of the elementary reflectors. !>
[out]	WORK	!> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) !> On exit, if INFO=0, WORK(1) returns the optimal LWORK. !>
[in]	LWORK	!> 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. !>
[out]	INFO	!> INFO is INTEGER !> = 0: successful exit. !> < 0: if INFO = -i, the i-th argument had an illegal value. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  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).
!> 

Contributors:

G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain X. Sun, Computer Science Dept., Duke University, USA

Definition at line 148 of file dgeqp3.f.

*
*  -- 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( * )
      DOUBLE PRECISION   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           dgeqrf, dlaqp2, dlaqps, dormqr, dswap,
     $                   xerbla
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      DOUBLE PRECISION   DNRM2
      EXTERNAL           ilaenv, dnrm2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          int, max, min
*     ..
*     .. Executable Statements ..
*
*     Test input arguments
*  ====================
*
      info = 0
      lquery = ( lwork.EQ.-1 )
      IF( m.LT.0 ) THEN
         info = -1
      ELSE IF( n.LT.0 ) THEN
         info = -2
      ELSE IF( 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, 'DGEQRF', ' ', 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( 'DGEQP3', -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 dswap( 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 DGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
         CALL dgeqrf( m, na, a, lda, tau, work, lwork, info )
         iws = max( iws, int( work( 1 ) ) )
         IF( na.LT.n ) THEN
*CC         CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
*CC  $                   TAU, A( 1, NA+1 ), LDA, WORK, INFO )
            CALL dormqr( '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, 'DGEQRF', ' ', 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, 'DGEQRF', ' ', 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, 'DGEQRF', ' ', 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 ) = dnrm2( 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 dlaqps( 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 dlaqp2( 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 DGEQP3
*

Here is the call graph for this function:

Here is the caller graph for this function: