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