LAPACK: SRC/cgeqpf.f Source File

Go to the documentation of this file.
00001       SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )
00002 *
00003 *  -- LAPACK deprecated computational routine (version 3.2.2) --
00004 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00005 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00006 *     June 2010
00007 *
00008 *     .. Scalar Arguments ..
00009       INTEGER            INFO, LDA, M, N
00010 *     ..
00011 *     .. Array Arguments ..
00012       INTEGER            JPVT( * )
00013       REAL               RWORK( * )
00014       COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
00015 *     ..
00016 *
00017 *  Purpose
00018 *  =======
00019 *
00020 *  This routine is deprecated and has been replaced by routine CGEQP3.
00021 *
00022 *  CGEQPF computes a QR factorization with column pivoting of a
00023 *  complex M-by-N matrix A: A*P = Q*R.
00024 *
00025 *  Arguments
00026 *  =========
00027 *
00028 *  M       (input) INTEGER
00029 *          The number of rows of the matrix A. M >= 0.
00030 *
00031 *  N       (input) INTEGER
00032 *          The number of columns of the matrix A. N >= 0
00033 *
00034 *  A       (input/output) COMPLEX array, dimension (LDA,N)
00035 *          On entry, the M-by-N matrix A.
00036 *          On exit, the upper triangle of the array contains the
00037 *          min(M,N)-by-N upper triangular matrix R; the elements
00038 *          below the diagonal, together with the array TAU,
00039 *          represent the unitary matrix Q as a product of
00040 *          min(m,n) elementary reflectors.
00041 *
00042 *  LDA     (input) INTEGER
00043 *          The leading dimension of the array A. LDA >= max(1,M).
00044 *
00045 *  JPVT    (input/output) INTEGER array, dimension (N)
00046 *          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
00047 *          to the front of A*P (a leading column); if JPVT(i) = 0,
00048 *          the i-th column of A is a free column.
00049 *          On exit, if JPVT(i) = k, then the i-th column of A*P
00050 *          was the k-th column of A.
00051 *
00052 *  TAU     (output) COMPLEX array, dimension (min(M,N))
00053 *          The scalar factors of the elementary reflectors.
00054 *
00055 *  WORK    (workspace) COMPLEX array, dimension (N)
00056 *
00057 *  RWORK   (workspace) REAL array, dimension (2*N)
00058 *
00059 *  INFO    (output) INTEGER
00060 *          = 0:  successful exit
00061 *          < 0:  if INFO = -i, the i-th argument had an illegal value
00062 *
00063 *  Further Details
00064 *  ===============
00065 *
00066 *  The matrix Q is represented as a product of elementary reflectors
00067 *
00068 *     Q = H(1) H(2) . . . H(n)
00069 *
00070 *  Each H(i) has the form
00071 *
00072 *     H = I - tau * v * v'
00073 *
00074 *  where tau is a complex scalar, and v is a complex vector with
00075 *  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
00076 *
00077 *  The matrix P is represented in jpvt as follows: If
00078 *     jpvt(j) = i
00079 *  then the jth column of P is the ith canonical unit vector.
00080 *
00081 *  Partial column norm updating strategy modified by
00082 *    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
00083 *    University of Zagreb, Croatia.
00084 *     June 2010
00085 *  For more details see LAPACK Working Note 176.
00086 *
00087 *  =====================================================================
00088 *
00089 *     .. Parameters ..
00090       REAL               ZERO, ONE
00091       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
00092 *     ..
00093 *     .. Local Scalars ..
00094       INTEGER            I, ITEMP, J, MA, MN, PVT
00095       REAL               TEMP, TEMP2, TOL3Z
00096       COMPLEX            AII
00097 *     ..
00098 *     .. External Subroutines ..
00099       EXTERNAL           CGEQR2, CLARF, CLARFG, CSWAP, CUNM2R, XERBLA
00100 *     ..
00101 *     .. Intrinsic Functions ..
00102       INTRINSIC          ABS, CMPLX, CONJG, MAX, MIN, SQRT
00103 *     ..
00104 *     .. External Functions ..
00105       INTEGER            ISAMAX
00106       REAL               SCNRM2, SLAMCH
00107       EXTERNAL           ISAMAX, SCNRM2, SLAMCH
00108 *     ..
00109 *     .. Executable Statements ..
00110 *
00111 *     Test the input arguments
00112 *
00113       INFO = 0
00114       IF( M.LT.0 ) THEN
00115          INFO = -1
00116       ELSE IF( N.LT.0 ) THEN
00117          INFO = -2
00118       ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
00119          INFO = -4
00120       END IF
00121       IF( INFO.NE.0 ) THEN
00122          CALL XERBLA( 'CGEQPF', -INFO )
00123          RETURN
00124       END IF
00125 *
00126       MN = MIN( M, N )
00127       TOL3Z = SQRT(SLAMCH('Epsilon'))
00128 *
00129 *     Move initial columns up front
00130 *
00131       ITEMP = 1
00132       DO 10 I = 1, N
00133          IF( JPVT( I ).NE.0 ) THEN
00134             IF( I.NE.ITEMP ) THEN
00135                CALL CSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
00136                JPVT( I ) = JPVT( ITEMP )
00137                JPVT( ITEMP ) = I
00138             ELSE
00139                JPVT( I ) = I
00140             END IF
00141             ITEMP = ITEMP + 1
00142          ELSE
00143             JPVT( I ) = I
00144          END IF
00145    10 CONTINUE
00146       ITEMP = ITEMP - 1
00147 *
00148 *     Compute the QR factorization and update remaining columns
00149 *
00150       IF( ITEMP.GT.0 ) THEN
00151          MA = MIN( ITEMP, M )
00152          CALL CGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
00153          IF( MA.LT.N ) THEN
00154             CALL CUNM2R( 'Left', 'Conjugate transpose', M, N-MA, MA, A,
00155      $                   LDA, TAU, A( 1, MA+1 ), LDA, WORK, INFO )
00156          END IF
00157       END IF
00158 *
00159       IF( ITEMP.LT.MN ) THEN
00160 *
00161 *        Initialize partial column norms. The first n elements of
00162 *        work store the exact column norms.
00163 *
00164          DO 20 I = ITEMP + 1, N
00165             RWORK( I ) = SCNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
00166             RWORK( N+I ) = RWORK( I )
00167    20    CONTINUE
00168 *
00169 *        Compute factorization
00170 *
00171          DO 40 I = ITEMP + 1, MN
00172 *
00173 *           Determine ith pivot column and swap if necessary
00174 *
00175             PVT = ( I-1 ) + ISAMAX( N-I+1, RWORK( I ), 1 )
00176 *
00177             IF( PVT.NE.I ) THEN
00178                CALL CSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
00179                ITEMP = JPVT( PVT )
00180                JPVT( PVT ) = JPVT( I )
00181                JPVT( I ) = ITEMP
00182                RWORK( PVT ) = RWORK( I )
00183                RWORK( N+PVT ) = RWORK( N+I )
00184             END IF
00185 *
00186 *           Generate elementary reflector H(i)
00187 *
00188             AII = A( I, I )
00189             CALL CLARFG( M-I+1, AII, A( MIN( I+1, M ), I ), 1,
00190      $                   TAU( I ) )
00191             A( I, I ) = AII
00192 *
00193             IF( I.LT.N ) THEN
00194 *
00195 *              Apply H(i) to A(i:m,i+1:n) from the left
00196 *
00197                AII = A( I, I )
00198                A( I, I ) = CMPLX( ONE )
00199                CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1,
00200      $                     CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK )
00201                A( I, I ) = AII
00202             END IF
00203 *
00204 *           Update partial column norms
00205 *
00206             DO 30 J = I + 1, N
00207                IF( RWORK( J ).NE.ZERO ) THEN
00208 *
00209 *                 NOTE: The following 4 lines follow from the analysis in
00210 *                 Lapack Working Note 176.
00211 *                 
00212                   TEMP = ABS( A( I, J ) ) / RWORK( J )
00213                   TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
00214                   TEMP2 = TEMP*( RWORK( J ) / RWORK( N+J ) )**2
00215                   IF( TEMP2 .LE. TOL3Z ) THEN 
00216                      IF( M-I.GT.0 ) THEN
00217                         RWORK( J ) = SCNRM2( M-I, A( I+1, J ), 1 )
00218                         RWORK( N+J ) = RWORK( J )
00219                      ELSE
00220                         RWORK( J ) = ZERO
00221                         RWORK( N+J ) = ZERO
00222                      END IF
00223                   ELSE
00224                      RWORK( J ) = RWORK( J )*SQRT( TEMP )
00225                   END IF
00226                END IF
00227    30       CONTINUE
00228 *
00229    40    CONTINUE
00230       END IF
00231       RETURN
00232 *
00233 *     End of CGEQPF
00234 *
00235       END