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*> \date December 2016 132* 133*> \ingroup complex_lin 134* 135* ===================================================================== 136 SUBROUTINE CRQT02( M, N, K, A, AF, Q, R, LDA, TAU, WORK, LWORK, 137 $ RWORK, RESULT ) 138* 139* -- LAPACK test routine (version 3.7.0) -- 140* -- LAPACK is a software package provided by Univ. of Tennessee, -- 141* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 142* December 2016 143* 144* .. Scalar Arguments .. 145 INTEGER K, LDA, LWORK, M, N 146* .. 147* .. Array Arguments .. 148 REAL RESULT( * ), RWORK( * ) 149 COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ), 150 $ R( LDA, * ), TAU( * ), WORK( LWORK ) 151* .. 152* 153* ===================================================================== 154* 155* .. Parameters .. 156 REAL ZERO, ONE 157 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) 158 COMPLEX ROGUE 159 PARAMETER ( ROGUE = ( -1.0E+10, -1.0E+10 ) ) 160* .. 161* .. Local Scalars .. 162 INTEGER INFO 163 REAL ANORM, EPS, RESID 164* .. 165* .. External Functions .. 166 REAL CLANGE, CLANSY, SLAMCH 167 EXTERNAL CLANGE, CLANSY, SLAMCH 168* .. 169* .. External Subroutines .. 170 EXTERNAL CGEMM, CHERK, CLACPY, CLASET, CUNGRQ 171* .. 172* .. Intrinsic Functions .. 173 INTRINSIC CMPLX, MAX, REAL 174* .. 175* .. Scalars in Common .. 176 CHARACTER*32 SRNAMT 177* .. 178* .. Common blocks .. 179 COMMON / SRNAMC / SRNAMT 180* .. 181* .. Executable Statements .. 182* 183* Quick return if possible 184* 185 IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN 186 RESULT( 1 ) = ZERO 187 RESULT( 2 ) = ZERO 188 RETURN 189 END IF 190* 191 EPS = SLAMCH( 'Epsilon' ) 192* 193* Copy the last k rows of the factorization to the array Q 194* 195 CALL CLASET( 'Full', M, N, ROGUE, ROGUE, Q, LDA ) 196 IF( K.LT.N ) 197 $ CALL CLACPY( 'Full', K, N-K, AF( M-K+1, 1 ), LDA, 198 $ Q( M-K+1, 1 ), LDA ) 199 IF( K.GT.1 ) 200 $ CALL CLACPY( 'Lower', K-1, K-1, AF( M-K+2, N-K+1 ), LDA, 201 $ Q( M-K+2, N-K+1 ), LDA ) 202* 203* Generate the last n rows of the matrix Q 204* 205 SRNAMT = 'CUNGRQ' 206 CALL CUNGRQ( M, N, K, Q, LDA, TAU( M-K+1 ), WORK, LWORK, INFO ) 207* 208* Copy R(m-k+1:m,n-m+1:n) 209* 210 CALL CLASET( 'Full', K, M, CMPLX( ZERO ), CMPLX( ZERO ), 211 $ R( M-K+1, N-M+1 ), LDA ) 212 CALL CLACPY( 'Upper', K, K, AF( M-K+1, N-K+1 ), LDA, 213 $ R( M-K+1, N-K+1 ), LDA ) 214* 215* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)' 216* 217 CALL CGEMM( 'No transpose', 'Conjugate transpose', K, M, N, 218 $ CMPLX( -ONE ), A( M-K+1, 1 ), LDA, Q, LDA, 219 $ CMPLX( ONE ), R( M-K+1, N-M+1 ), LDA ) 220* 221* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) . 222* 223 ANORM = CLANGE( '1', K, N, A( M-K+1, 1 ), LDA, RWORK ) 224 RESID = CLANGE( '1', K, M, R( M-K+1, N-M+1 ), LDA, RWORK ) 225 IF( ANORM.GT.ZERO ) THEN 226 RESULT( 1 ) = ( ( RESID / REAL( MAX( 1, N ) ) ) / ANORM ) / EPS 227 ELSE 228 RESULT( 1 ) = ZERO 229 END IF 230* 231* Compute I - Q*Q' 232* 233 CALL CLASET( 'Full', M, M, CMPLX( ZERO ), CMPLX( ONE ), R, LDA ) 234 CALL CHERK( 'Upper', 'No transpose', M, N, -ONE, Q, LDA, ONE, R, 235 $ LDA ) 236* 237* Compute norm( I - Q*Q' ) / ( N * EPS ) . 238* 239 RESID = CLANSY( '1', 'Upper', M, R, LDA, RWORK ) 240* 241 RESULT( 2 ) = ( RESID / REAL( MAX( 1, N ) ) ) / EPS 242* 243 RETURN 244* 245* End of CRQT02 246* 247 END 248