1*> \brief \b DLQT04 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 CLQT04(M,N,NB,RESULT) 12* 13* .. Scalar Arguments .. 14* INTEGER M, N, NB 15* .. Return values .. 16* REAL RESULT(6) 17* 18* 19*> \par Purpose: 20* ============= 21*> 22*> \verbatim 23*> 24*> CLQT04 tests CGELQT and CGEMLQT. 25*> \endverbatim 26* 27* Arguments: 28* ========== 29* 30*> \param[in] M 31*> \verbatim 32*> M is INTEGER 33*> Number of rows in test matrix. 34*> \endverbatim 35*> 36*> \param[in] N 37*> \verbatim 38*> N is INTEGER 39*> Number of columns in test matrix. 40*> \endverbatim 41*> 42*> \param[in] NB 43*> \verbatim 44*> NB is INTEGER 45*> Block size of test matrix. NB <= Min(M,N). 46*> \endverbatim 47*> 48*> \param[out] RESULT 49*> \verbatim 50*> RESULT is DOUBLE PRECISION array, dimension (6) 51*> Results of each of the six tests below. 52*> 53*> RESULT(1) = | A - L Q | 54*> RESULT(2) = | I - Q Q^H | 55*> RESULT(3) = | Q C - Q C | 56*> RESULT(4) = | Q^H C - Q^H C | 57*> RESULT(5) = | C Q - C Q | 58*> RESULT(6) = | C Q^H - C Q^H | 59*> \endverbatim 60* 61* Authors: 62* ======== 63* 64*> \author Univ. of Tennessee 65*> \author Univ. of California Berkeley 66*> \author Univ. of Colorado Denver 67*> \author NAG Ltd. 68* 69*> \date April 2012 70* 71*> \ingroup double_lin 72* 73* ===================================================================== 74 SUBROUTINE CLQT04(M,N,NB,RESULT) 75 IMPLICIT NONE 76* 77* -- LAPACK test routine (version 3.7.0) -- 78* -- LAPACK is a software package provided by Univ. of Tennessee, -- 79* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 80* April 2012 81* 82* .. Scalar Arguments .. 83 INTEGER M, N, NB 84* .. Return values .. 85 REAL RESULT(6) 86* 87* ===================================================================== 88* 89* .. 90* .. Local allocatable arrays 91 COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:), 92 $ L(:,:), RWORK(:), WORK( : ), T(:,:), 93 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:) 94* 95* .. Parameters .. 96 REAL ZERO 97 COMPLEX ONE, CZERO 98 PARAMETER( ZERO = 0.0) 99 PARAMETER( ONE = (1.0,0.0), CZERO=(0.0,0.0) ) 100* .. 101* .. Local Scalars .. 102 INTEGER INFO, J, K, LL, LWORK, LDT 103 REAL ANORM, EPS, RESID, CNORM, DNORM 104* .. 105* .. Local Arrays .. 106 INTEGER ISEED( 4 ) 107* .. 108* .. External Functions .. 109 REAL SLAMCH 110 REAL CLANGE, CLANSY 111 LOGICAL LSAME 112 EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME 113* .. 114* .. Intrinsic Functions .. 115 INTRINSIC MAX, MIN 116* .. 117* .. Data statements .. 118 DATA ISEED / 1988, 1989, 1990, 1991 / 119* 120 EPS = SLAMCH( 'Epsilon' ) 121 K = MIN(M,N) 122 LL = MAX(M,N) 123 LWORK = MAX(2,LL)*MAX(2,LL)*NB 124* 125* Dynamically allocate local arrays 126* 127 ALLOCATE ( A(M,N), AF(M,N), Q(N,N), L(LL,N), RWORK(LL), 128 $ WORK(LWORK), T(NB,N), C(M,N), CF(M,N), 129 $ D(N,M), DF(N,M) ) 130* 131* Put random numbers into A and copy to AF 132* 133 LDT=NB 134 DO J=1,N 135 CALL CLARNV( 2, ISEED, M, A( 1, J ) ) 136 END DO 137 CALL CLACPY( 'Full', M, N, A, M, AF, M ) 138* 139* Factor the matrix A in the array AF. 140* 141 CALL CGELQT( M, N, NB, AF, M, T, LDT, WORK, INFO ) 142* 143* Generate the n-by-n matrix Q 144* 145 CALL CLASET( 'Full', N, N, CZERO, ONE, Q, N ) 146 CALL CGEMLQT( 'R', 'N', N, N, K, NB, AF, M, T, LDT, Q, N, 147 $ WORK, INFO ) 148* 149* Copy L 150* 151 CALL CLASET( 'Full', LL, N, CZERO, CZERO, L, LL ) 152 CALL CLACPY( 'Lower', M, N, AF, M, L, LL ) 153* 154* Compute |L - A*Q'| / |A| and store in RESULT(1) 155* 156 CALL CGEMM( 'N', 'C', M, N, N, -ONE, A, M, Q, N, ONE, L, LL ) 157 ANORM = CLANGE( '1', M, N, A, M, RWORK ) 158 RESID = CLANGE( '1', M, N, L, LL, RWORK ) 159 IF( ANORM.GT.ZERO ) THEN 160 RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM) 161 ELSE 162 RESULT( 1 ) = ZERO 163 END IF 164* 165* Compute |I - Q'*Q| and store in RESULT(2) 166* 167 CALL CLASET( 'Full', N, N, CZERO, ONE, L, LL ) 168 CALL CHERK( 'U', 'C', N, N, REAL(-ONE), Q, N, REAL(ONE), L, LL) 169 RESID = CLANSY( '1', 'Upper', N, L, LL, RWORK ) 170 RESULT( 2 ) = RESID / (EPS*MAX(1,N)) 171* 172* Generate random m-by-n matrix C and a copy CF 173* 174 DO J=1,M 175 CALL CLARNV( 2, ISEED, N, D( 1, J ) ) 176 END DO 177 DNORM = CLANGE( '1', N, M, D, N, RWORK) 178 CALL CLACPY( 'Full', N, M, D, N, DF, N ) 179* 180* Apply Q to C as Q*C 181* 182 CALL CGEMLQT( 'L', 'N', N, M, K, NB, AF, M, T, NB, DF, N, 183 $ WORK, INFO) 184* 185* Compute |Q*D - Q*D| / |D| 186* 187 CALL CGEMM( 'N', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) 188 RESID = CLANGE( '1', N, M, DF, N, RWORK ) 189 IF( DNORM.GT.ZERO ) THEN 190 RESULT( 3 ) = RESID / (EPS*MAX(1,M)*DNORM) 191 ELSE 192 RESULT( 3 ) = ZERO 193 END IF 194* 195* Copy D into DF again 196* 197 CALL CLACPY( 'Full', N, M, D, N, DF, N ) 198* 199* Apply Q to D as QT*D 200* 201 CALL CGEMLQT( 'L', 'C', N, M, K, NB, AF, M, T, NB, DF, N, 202 $ WORK, INFO) 203* 204* Compute |QT*D - QT*D| / |D| 205* 206 CALL CGEMM( 'C', 'N', N, M, N, -ONE, Q, N, D, N, ONE, DF, N ) 207 RESID = CLANGE( '1', N, M, DF, N, RWORK ) 208 IF( DNORM.GT.ZERO ) THEN 209 RESULT( 4 ) = RESID / (EPS*MAX(1,M)*DNORM) 210 ELSE 211 RESULT( 4 ) = ZERO 212 END IF 213* 214* Generate random n-by-m matrix D and a copy DF 215* 216 DO J=1,N 217 CALL CLARNV( 2, ISEED, M, C( 1, J ) ) 218 END DO 219 CNORM = CLANGE( '1', M, N, C, M, RWORK) 220 CALL CLACPY( 'Full', M, N, C, M, CF, M ) 221* 222* Apply Q to C as C*Q 223* 224 CALL CGEMLQT( 'R', 'N', M, N, K, NB, AF, M, T, NB, CF, M, 225 $ WORK, INFO) 226* 227* Compute |C*Q - C*Q| / |C| 228* 229 CALL CGEMM( 'N', 'N', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) 230 RESID = CLANGE( '1', N, M, DF, N, RWORK ) 231 IF( CNORM.GT.ZERO ) THEN 232 RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM) 233 ELSE 234 RESULT( 5 ) = ZERO 235 END IF 236* 237* Copy C into CF again 238* 239 CALL CLACPY( 'Full', M, N, C, M, CF, M ) 240* 241* Apply Q to D as D*QT 242* 243 CALL CGEMLQT( 'R', 'C', M, N, K, NB, AF, M, T, NB, CF, M, 244 $ WORK, INFO) 245* 246* Compute |C*QT - C*QT| / |C| 247* 248 CALL CGEMM( 'N', 'C', M, N, N, -ONE, C, M, Q, N, ONE, CF, M ) 249 RESID = CLANGE( '1', M, N, CF, M, RWORK ) 250 IF( CNORM.GT.ZERO ) THEN 251 RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM) 252 ELSE 253 RESULT( 6 ) = ZERO 254 END IF 255* 256* Deallocate all arrays 257* 258 DEALLOCATE ( A, AF, Q, L, RWORK, WORK, T, C, D, CF, DF) 259* 260 RETURN 261 END 262 263