LAPACK 3.3.0

# dqpt01.f

Go to the documentation of this file.
```00001       DOUBLE PRECISION FUNCTION DQPT01( M, N, K, A, AF, LDA, TAU, JPVT,
00002      \$                 WORK, LWORK )
00003 *
00004 *  -- LAPACK test routine (version 3.1) --
00005 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
00006 *     November 2006
00007 *
00008 *     .. Scalar Arguments ..
00009       INTEGER            K, LDA, LWORK, M, N
00010 *     ..
00011 *     .. Array Arguments ..
00012       INTEGER            JPVT( * )
00013       DOUBLE PRECISION   A( LDA, * ), AF( LDA, * ), TAU( * ),
00014      \$                   WORK( LWORK )
00015 *     ..
00016 *
00017 *  Purpose
00018 *  =======
00019 *
00020 *  DQPT01 tests the QR-factorization with pivoting of a matrix A.  The
00021 *  array AF contains the (possibly partial) QR-factorization of A, where
00022 *  the upper triangle of AF(1:k,1:k) is a partial triangular factor,
00023 *  the entries below the diagonal in the first k columns are the
00024 *  Householder vectors, and the rest of AF contains a partially updated
00025 *  matrix.
00026 *
00027 *  This function returns ||A*P - Q*R||/(||norm(A)||*eps*M)
00028 *
00029 *  Arguments
00030 *  =========
00031 *
00032 *  M       (input) INTEGER
00033 *          The number of rows of the matrices A and AF.
00034 *
00035 *  N       (input) INTEGER
00036 *          The number of columns of the matrices A and AF.
00037 *
00038 *  K       (input) INTEGER
00039 *          The number of columns of AF that have been reduced
00040 *          to upper triangular form.
00041 *
00042 *  A       (input) DOUBLE PRECISION array, dimension (LDA, N)
00043 *          The original matrix A.
00044 *
00045 *  AF      (input) DOUBLE PRECISION array, dimension (LDA,N)
00046 *          The (possibly partial) output of DGEQPF.  The upper triangle
00047 *          of AF(1:k,1:k) is a partial triangular factor, the entries
00048 *          below the diagonal in the first k columns are the Householder
00049 *          vectors, and the rest of AF contains a partially updated
00050 *          matrix.
00051 *
00052 *  LDA     (input) INTEGER
00053 *          The leading dimension of the arrays A and AF.
00054 *
00055 *  TAU     (input) DOUBLE PRECISION array, dimension (K)
00056 *          Details of the Householder transformations as returned by
00057 *          DGEQPF.
00058 *
00059 *  JPVT    (input) INTEGER array, dimension (N)
00060 *          Pivot information as returned by DGEQPF.
00061 *
00062 *  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)
00063 *
00064 *  LWORK   (input) INTEGER
00065 *          The length of the array WORK.  LWORK >= M*N+N.
00066 *
00067 *  =====================================================================
00068 *
00069 *     .. Parameters ..
00070       DOUBLE PRECISION   ZERO, ONE
00071       PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
00072 *     ..
00073 *     .. Local Scalars ..
00074       INTEGER            I, INFO, J
00075       DOUBLE PRECISION   NORMA
00076 *     ..
00077 *     .. Local Arrays ..
00078       DOUBLE PRECISION   RWORK( 1 )
00079 *     ..
00080 *     .. External Functions ..
00081       DOUBLE PRECISION   DLAMCH, DLANGE
00082       EXTERNAL           DLAMCH, DLANGE
00083 *     ..
00084 *     .. External Subroutines ..
00085       EXTERNAL           DAXPY, DCOPY, DORMQR, XERBLA
00086 *     ..
00087 *     .. Intrinsic Functions ..
00088       INTRINSIC          DBLE, MAX, MIN
00089 *     ..
00090 *     .. Executable Statements ..
00091 *
00092       DQPT01 = ZERO
00093 *
00094 *     Test if there is enough workspace
00095 *
00096       IF( LWORK.LT.M*N+N ) THEN
00097          CALL XERBLA( 'DQPT01', 10 )
00098          RETURN
00099       END IF
00100 *
00101 *     Quick return if possible
00102 *
00103       IF( M.LE.0 .OR. N.LE.0 )
00104      \$   RETURN
00105 *
00106       NORMA = DLANGE( 'One-norm', M, N, A, LDA, RWORK )
00107 *
00108       DO 30 J = 1, K
00109          DO 10 I = 1, MIN( J, M )
00110             WORK( ( J-1 )*M+I ) = AF( I, J )
00111    10    CONTINUE
00112          DO 20 I = J + 1, M
00113             WORK( ( J-1 )*M+I ) = ZERO
00114    20    CONTINUE
00115    30 CONTINUE
00116       DO 40 J = K + 1, N
00117          CALL DCOPY( M, AF( 1, J ), 1, WORK( ( J-1 )*M+1 ), 1 )
00118    40 CONTINUE
00119 *
00120       CALL DORMQR( 'Left', 'No transpose', M, N, K, AF, LDA, TAU, WORK,
00121      \$             M, WORK( M*N+1 ), LWORK-M*N, INFO )
00122 *
00123       DO 50 J = 1, N
00124 *
00125 *        Compare i-th column of QR and jpvt(i)-th column of A
00126 *
00127          CALL DAXPY( M, -ONE, A( 1, JPVT( J ) ), 1, WORK( ( J-1 )*M+1 ),
00128      \$               1 )
00129    50 CONTINUE
00130 *
00131       DQPT01 = DLANGE( 'One-norm', M, N, WORK, M, RWORK ) /
00132      \$         ( DBLE( MAX( M, N ) )*DLAMCH( 'Epsilon' ) )
00133       IF( NORMA.NE.ZERO )
00134      \$   DQPT01 = DQPT01 / NORMA
00135 *
00136       RETURN
00137 *
00138 *     End of DQPT01
00139 *
00140       END
```