1*> \brief \b CRQT02 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8* Definition: 9* =========== 10* 11* SUBROUTINE CRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, 12* RWORK, RESULT ) 13* 14* .. Scalar Arguments .. 15* INTEGER K, LDA, LWORK, M, N 16* .. 17* .. Array Arguments .. 18* REAL RESULT( * ), RWORK( * ) 19* COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ), 20* $ R( LDA, * ), TAU( * ), WORK( LWORK ) 21* .. 22* 23* 24*> \par Purpose: 25* ============= 26*> 27*> \verbatim 28*> 29*> CRQT02 tests CUNGRQ, which generates an m-by-n matrix Q with 30*> orthonornmal rows that is defined as the product of k elementary 31*> reflectors. 32*> 33*> Given the RQ factorization of an m-by-n matrix A, CRQT02 generates 34*> the orthogonal matrix Q defined by the factorization of the last k 35*> rows of A; it compares R(m-k+1:m,n-m+1:n) with 36*> A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are 37*> orthonormal. 38*> \endverbatim 39* 40* Arguments: 41* ========== 42* 43*> \param[in] M 44*> \verbatim 45*> M is INTEGER 46*> The number of rows of the matrix Q to be generated. M >= 0. 47*> \endverbatim 48*> 49*> \param[in] N 50*> \verbatim 51*> N is INTEGER 52*> The number of columns of the matrix Q to be generated. 53*> N >= M >= 0. 54*> \endverbatim 55*> 56*> \param[in] K 57*> \verbatim 58*> K is INTEGER 59*> The number of elementary reflectors whose product defines the 60*> matrix Q. M >= K >= 0. 61*> \endverbatim 62*> 63*> \param[in] A 64*> \verbatim 65*> A is COMPLEX array, dimension (LDA,N) 66*> The m-by-n matrix A which was factorized by CRQT01. 67*> \endverbatim 68*> 69*> \param[in] AF 70*> \verbatim 71*> AF is COMPLEX array, dimension (LDA,N) 72*> Details of the RQ factorization of A, as returned by CGERQF. 73*> See CGERQF for further details. 74*> \endverbatim 75*> 76*> \param[out] Q 77*> \verbatim 78*> Q is COMPLEX array, dimension (LDA,N) 79*> \endverbatim 80*> 81*> \param[out] R 82*> \verbatim 83*> R is COMPLEX array, dimension (LDA,M) 84*> \endverbatim 85*> 86*> \param[in] LDA 87*> \verbatim 88*> LDA is INTEGER 89*> The leading dimension of the arrays A, AF, Q and L. LDA >= N. 90*> \endverbatim 91*> 92*> \param[in] TAU 93*> \verbatim 94*> TAU is COMPLEX array, dimension (M) 95*> The scalar factors of the elementary reflectors corresponding 96*> to the RQ factorization in AF. 97*> \endverbatim 98*> 99*> \param[out] WORK 100*> \verbatim 101*> WORK is COMPLEX array, dimension (LWORK) 102*> \endverbatim 103*> 104*> \param[in] LWORK 105*> \verbatim 106*> LWORK is INTEGER 107*> The dimension of the array WORK. 108*> \endverbatim 109*> 110*> \param[out] RWORK 111*> \verbatim 112*> RWORK is REAL array, dimension (M) 113*> \endverbatim 114*> 115*> \param[out] RESULT 116*> \verbatim 117*> RESULT is REAL array, dimension (2) 118*> The test ratios: 119*> RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS ) 120*> RESULT(2) = norm( I - Q*Q' ) / ( N * EPS ) 121*> \endverbatim 122* 123* Authors: 124* ======== 125* 126*> \author Univ. of Tennessee 127*> \author Univ. of California Berkeley 128*> \author Univ. of Colorado Denver 129*> \author NAG Ltd. 130* 131*> \ingroup complex_lin 132* 133* ===================================================================== 134 SUBROUTINE CRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, 135 $ RWORK, RESULT ) 136* 137* -- LAPACK test routine -- 138* -- LAPACK is a software package provided by Univ. of Tennessee, -- 139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 140* 141* .. Scalar Arguments .. 142 INTEGER K, LDA, LWORK, M, N 143* .. 144* .. Array Arguments .. 145 REAL RESULT( * ), RWORK( * ) 146 COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ), 147 $ R( LDA, * ), TAU( * ), WORK( LWORK ) 148* .. 149* 150* ===================================================================== 151* 152* .. Parameters .. 153 REAL ZERO, ONE 154 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) 155 COMPLEX ROGUE 156 PARAMETER ( ROGUE = ( -1.0E+10, -1.0E+10 ) ) 157* .. 158* .. Local Scalars .. 159 INTEGER INFO 160 REAL ANORM, EPS, RESID 161* .. 162* .. External Functions .. 163 REAL CLANGE, CLANSY, SLAMCH 164 EXTERNAL CLANGE, CLANSY, SLAMCH 165* .. 166* .. External Subroutines .. 167 EXTERNAL CGEMM, CHERK, CLACPY, CLASET, CUNGRQ 168* .. 169* .. Intrinsic Functions .. 170 INTRINSIC CMPLX, MAX, REAL 171* .. 172* .. Scalars in Common .. 173 CHARACTER*32 SRNAMT 174* .. 175* .. Common blocks .. 176 COMMON / SRNAMC / SRNAMT 177* .. 178* .. Executable Statements .. 179* 180* Quick return if possible 181* 182 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN 183 RESULT( 1 ) = ZERO 184 RESULT( 2 ) = ZERO 185 RETURN 186 END IF 187* 188 EPS = SLAMCH( 'Epsilon' ) 189* 190* Copy the last k rows of the factorization to the array Q 191* 192 CALL CLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA ) 193 IF( K.LT.N ) 194 $ CALL CLACPY( 'Full', K, N-K, AF( M-K+1, 1 ), LDA, 195 $ Q( M-K+1, 1 ), LDA ) 196 IF( K.GT.1 ) 197 $ CALL CLACPY( 'Lower', K-1, K-1, AF( M-K+2, N-K+1 ), LDA, 198 $ Q( M-K+2, N-K+1 ), LDA ) 199* 200* Generate the last n rows of the matrix Q 201* 202 SRNAMT = 'CUNGRQ' 203 CALL CUNGRQ( M, N, K, Q, LDA, TAU( M-K+1 ), WORK, LWORK, INFO ) 204* 205* Copy R(m-k+1:m,n-m+1:n) 206* 207 CALL CLASET( 'Full', K, M, CMPLX( ZERO ), CMPLX( ZERO ), 208 $ R( M-K+1, N-M+1 ), LDA ) 209 CALL CLACPY( 'Upper', K, K, AF( M-K+1, N-K+1 ), LDA, 210 $ R( M-K+1, N-K+1 ), LDA ) 211* 212* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' 213* 214 CALL CGEMM( 'No transpose', 'Conjugate transpose', K, M, N, 215 $ CMPLX( -ONE ), A( M-K+1, 1 ), LDA, Q, LDA, 216 $ CMPLX( ONE ), R( M-K+1, N-M+1 ), LDA ) 217* 218* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . 219* 220 ANORM = CLANGE( '1', K, N, A( M-K+1, 1 ), LDA, RWORK ) 221 RESID = CLANGE( '1', K, M, R( M-K+1, N-M+1 ), LDA, RWORK ) 222 IF( ANORM.GT.ZERO ) THEN 223 RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, N ) ) ) / ANORM ) / EPS 224 ELSE 225 RESULT( 1 ) = ZERO 226 END IF 227* 228* Compute I - Q*Q' 229* 230 CALL CLASET( 'Full', M, M, CMPLX( ZERO ), CMPLX( ONE ), R, LDA ) 231 CALL CHERK( 'Upper', 'No transpose', M, N, -ONE, Q, LDA, ONE, R, 232 $ LDA ) 233* 234* Compute norm( I - Q*Q' ) / ( N * EPS ) . 235* 236 RESID = CLANSY( '1', 'Upper', M, R, LDA, RWORK ) 237* 238 RESULT( 2 ) = ( RESID / REAL( MAX( 1, N ) ) ) / EPS 239* 240 RETURN 241* 242* End of CRQT02 243* 244 END 245