1*> \brief \b DGET34 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 DGET34( RMAX, LMAX, NINFO, KNT ) 12* 13* .. Scalar Arguments .. 14* INTEGER KNT, LMAX 15* DOUBLE PRECISION RMAX 16* .. 17* .. Array Arguments .. 18* INTEGER NINFO( 2 ) 19* .. 20* 21* 22*> \par Purpose: 23* ============= 24*> 25*> \verbatim 26*> 27*> DGET34 tests DLAEXC, a routine for swapping adjacent blocks (either 28*> 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form. 29*> Thus, DLAEXC computes an orthogonal matrix Q such that 30*> 31*> Q' * [ A B ] * Q = [ C1 B1 ] 32*> [ 0 C ] [ 0 A1 ] 33*> 34*> where C1 is similar to C and A1 is similar to A. Both A and C are 35*> assumed to be in standard form (equal diagonal entries and 36*> offdiagonal with differing signs) and A1 and C1 are returned with the 37*> same properties. 38*> 39*> The test code verifies these last assertions, as well as that 40*> the residual in the above equation is small. 41*> \endverbatim 42* 43* Arguments: 44* ========== 45* 46*> \param[out] RMAX 47*> \verbatim 48*> RMAX is DOUBLE PRECISION 49*> Value of the largest test ratio. 50*> \endverbatim 51*> 52*> \param[out] LMAX 53*> \verbatim 54*> LMAX is INTEGER 55*> Example number where largest test ratio achieved. 56*> \endverbatim 57*> 58*> \param[out] NINFO 59*> \verbatim 60*> NINFO is INTEGER array, dimension (2) 61*> NINFO(J) is the number of examples where INFO=J occurred. 62*> \endverbatim 63*> 64*> \param[out] KNT 65*> \verbatim 66*> KNT is INTEGER 67*> Total number of examples tested. 68*> \endverbatim 69* 70* Authors: 71* ======== 72* 73*> \author Univ. of Tennessee 74*> \author Univ. of California Berkeley 75*> \author Univ. of Colorado Denver 76*> \author NAG Ltd. 77* 78*> \ingroup double_eig 79* 80* ===================================================================== 81 SUBROUTINE DGET34( RMAX, LMAX, NINFO, KNT ) 82* 83* -- LAPACK test routine -- 84* -- LAPACK is a software package provided by Univ. of Tennessee, -- 85* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 86* 87* .. Scalar Arguments .. 88 INTEGER KNT, LMAX 89 DOUBLE PRECISION RMAX 90* .. 91* .. Array Arguments .. 92 INTEGER NINFO( 2 ) 93* .. 94* 95* ===================================================================== 96* 97* .. Parameters .. 98 DOUBLE PRECISION ZERO, HALF, ONE 99 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) 100 DOUBLE PRECISION TWO, THREE 101 PARAMETER ( TWO = 2.0D0, THREE = 3.0D0 ) 102 INTEGER LWORK 103 PARAMETER ( LWORK = 32 ) 104* .. 105* .. Local Scalars .. 106 INTEGER I, IA, IA11, IA12, IA21, IA22, IAM, IB, IC, 107 $ IC11, IC12, IC21, IC22, ICM, INFO, J 108 DOUBLE PRECISION BIGNUM, EPS, RES, SMLNUM, TNRM 109* .. 110* .. Local Arrays .. 111 DOUBLE PRECISION Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ), 112 $ VAL( 9 ), VM( 2 ), WORK( LWORK ) 113* .. 114* .. External Functions .. 115 DOUBLE PRECISION DLAMCH 116 EXTERNAL DLAMCH 117* .. 118* .. External Subroutines .. 119 EXTERNAL DCOPY, DHST01, DLABAD, DLAEXC 120* .. 121* .. Intrinsic Functions .. 122 INTRINSIC ABS, DBLE, MAX, SIGN, SQRT 123* .. 124* .. Executable Statements .. 125* 126* Get machine parameters 127* 128 EPS = DLAMCH( 'P' ) 129 SMLNUM = DLAMCH( 'S' ) / EPS 130 BIGNUM = ONE / SMLNUM 131 CALL DLABAD( SMLNUM, BIGNUM ) 132* 133* Set up test case parameters 134* 135 VAL( 1 ) = ZERO 136 VAL( 2 ) = SQRT( SMLNUM ) 137 VAL( 3 ) = ONE 138 VAL( 4 ) = TWO 139 VAL( 5 ) = SQRT( BIGNUM ) 140 VAL( 6 ) = -SQRT( SMLNUM ) 141 VAL( 7 ) = -ONE 142 VAL( 8 ) = -TWO 143 VAL( 9 ) = -SQRT( BIGNUM ) 144 VM( 1 ) = ONE 145 VM( 2 ) = ONE + TWO*EPS 146 CALL DCOPY( 16, VAL( 4 ), 0, T( 1, 1 ), 1 ) 147* 148 NINFO( 1 ) = 0 149 NINFO( 2 ) = 0 150 KNT = 0 151 LMAX = 0 152 RMAX = ZERO 153* 154* Begin test loop 155* 156 DO 40 IA = 1, 9 157 DO 30 IAM = 1, 2 158 DO 20 IB = 1, 9 159 DO 10 IC = 1, 9 160 T( 1, 1 ) = VAL( IA )*VM( IAM ) 161 T( 2, 2 ) = VAL( IC ) 162 T( 1, 2 ) = VAL( IB ) 163 T( 2, 1 ) = ZERO 164 TNRM = MAX( ABS( T( 1, 1 ) ), ABS( T( 2, 2 ) ), 165 $ ABS( T( 1, 2 ) ) ) 166 CALL DCOPY( 16, T, 1, T1, 1 ) 167 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 168 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 169 CALL DLAEXC( .TRUE., 2, T, 4, Q, 4, 1, 1, 1, WORK, 170 $ INFO ) 171 IF( INFO.NE.0 ) 172 $ NINFO( INFO ) = NINFO( INFO ) + 1 173 CALL DHST01( 2, 1, 2, T1, 4, T, 4, Q, 4, WORK, LWORK, 174 $ RESULT ) 175 RES = RESULT( 1 ) + RESULT( 2 ) 176 IF( INFO.NE.0 ) 177 $ RES = RES + ONE / EPS 178 IF( T( 1, 1 ).NE.T1( 2, 2 ) ) 179 $ RES = RES + ONE / EPS 180 IF( T( 2, 2 ).NE.T1( 1, 1 ) ) 181 $ RES = RES + ONE / EPS 182 IF( T( 2, 1 ).NE.ZERO ) 183 $ RES = RES + ONE / EPS 184 KNT = KNT + 1 185 IF( RES.GT.RMAX ) THEN 186 LMAX = KNT 187 RMAX = RES 188 END IF 189 10 CONTINUE 190 20 CONTINUE 191 30 CONTINUE 192 40 CONTINUE 193* 194 DO 110 IA = 1, 5 195 DO 100 IAM = 1, 2 196 DO 90 IB = 1, 5 197 DO 80 IC11 = 1, 5 198 DO 70 IC12 = 2, 5 199 DO 60 IC21 = 2, 4 200 DO 50 IC22 = -1, 1, 2 201 T( 1, 1 ) = VAL( IA )*VM( IAM ) 202 T( 1, 2 ) = VAL( IB ) 203 T( 1, 3 ) = -TWO*VAL( IB ) 204 T( 2, 1 ) = ZERO 205 T( 2, 2 ) = VAL( IC11 ) 206 T( 2, 3 ) = VAL( IC12 ) 207 T( 3, 1 ) = ZERO 208 T( 3, 2 ) = -VAL( IC21 ) 209 T( 3, 3 ) = VAL( IC11 )*DBLE( IC22 ) 210 TNRM = MAX( ABS( T( 1, 1 ) ), 211 $ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ), 212 $ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ), 213 $ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) ) 214 CALL DCOPY( 16, T, 1, T1, 1 ) 215 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 216 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 217 CALL DLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 1, 2, 218 $ WORK, INFO ) 219 IF( INFO.NE.0 ) 220 $ NINFO( INFO ) = NINFO( INFO ) + 1 221 CALL DHST01( 3, 1, 3, T1, 4, T, 4, Q, 4, 222 $ WORK, LWORK, RESULT ) 223 RES = RESULT( 1 ) + RESULT( 2 ) 224 IF( INFO.EQ.0 ) THEN 225 IF( T1( 1, 1 ).NE.T( 3, 3 ) ) 226 $ RES = RES + ONE / EPS 227 IF( T( 3, 1 ).NE.ZERO ) 228 $ RES = RES + ONE / EPS 229 IF( T( 3, 2 ).NE.ZERO ) 230 $ RES = RES + ONE / EPS 231 IF( T( 2, 1 ).NE.0 .AND. 232 $ ( T( 1, 1 ).NE.T( 2, 233 $ 2 ) .OR. SIGN( ONE, T( 1, 234 $ 2 ) ).EQ.SIGN( ONE, T( 2, 1 ) ) ) ) 235 $ RES = RES + ONE / EPS 236 END IF 237 KNT = KNT + 1 238 IF( RES.GT.RMAX ) THEN 239 LMAX = KNT 240 RMAX = RES 241 END IF 242 50 CONTINUE 243 60 CONTINUE 244 70 CONTINUE 245 80 CONTINUE 246 90 CONTINUE 247 100 CONTINUE 248 110 CONTINUE 249* 250 DO 180 IA11 = 1, 5 251 DO 170 IA12 = 2, 5 252 DO 160 IA21 = 2, 4 253 DO 150 IA22 = -1, 1, 2 254 DO 140 ICM = 1, 2 255 DO 130 IB = 1, 5 256 DO 120 IC = 1, 5 257 T( 1, 1 ) = VAL( IA11 ) 258 T( 1, 2 ) = VAL( IA12 ) 259 T( 1, 3 ) = -TWO*VAL( IB ) 260 T( 2, 1 ) = -VAL( IA21 ) 261 T( 2, 2 ) = VAL( IA11 )*DBLE( IA22 ) 262 T( 2, 3 ) = VAL( IB ) 263 T( 3, 1 ) = ZERO 264 T( 3, 2 ) = ZERO 265 T( 3, 3 ) = VAL( IC )*VM( ICM ) 266 TNRM = MAX( ABS( T( 1, 1 ) ), 267 $ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ), 268 $ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ), 269 $ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) ) 270 CALL DCOPY( 16, T, 1, T1, 1 ) 271 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 272 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 273 CALL DLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 2, 1, 274 $ WORK, INFO ) 275 IF( INFO.NE.0 ) 276 $ NINFO( INFO ) = NINFO( INFO ) + 1 277 CALL DHST01( 3, 1, 3, T1, 4, T, 4, Q, 4, 278 $ WORK, LWORK, RESULT ) 279 RES = RESULT( 1 ) + RESULT( 2 ) 280 IF( INFO.EQ.0 ) THEN 281 IF( T1( 3, 3 ).NE.T( 1, 1 ) ) 282 $ RES = RES + ONE / EPS 283 IF( T( 2, 1 ).NE.ZERO ) 284 $ RES = RES + ONE / EPS 285 IF( T( 3, 1 ).NE.ZERO ) 286 $ RES = RES + ONE / EPS 287 IF( T( 3, 2 ).NE.0 .AND. 288 $ ( T( 2, 2 ).NE.T( 3, 289 $ 3 ) .OR. SIGN( ONE, T( 2, 290 $ 3 ) ).EQ.SIGN( ONE, T( 3, 2 ) ) ) ) 291 $ RES = RES + ONE / EPS 292 END IF 293 KNT = KNT + 1 294 IF( RES.GT.RMAX ) THEN 295 LMAX = KNT 296 RMAX = RES 297 END IF 298 120 CONTINUE 299 130 CONTINUE 300 140 CONTINUE 301 150 CONTINUE 302 160 CONTINUE 303 170 CONTINUE 304 180 CONTINUE 305* 306 DO 300 IA11 = 1, 5 307 DO 290 IA12 = 2, 5 308 DO 280 IA21 = 2, 4 309 DO 270 IA22 = -1, 1, 2 310 DO 260 IB = 1, 5 311 DO 250 IC11 = 3, 4 312 DO 240 IC12 = 3, 4 313 DO 230 IC21 = 3, 4 314 DO 220 IC22 = -1, 1, 2 315 DO 210 ICM = 5, 7 316 IAM = 1 317 T( 1, 1 ) = VAL( IA11 )*VM( IAM ) 318 T( 1, 2 ) = VAL( IA12 )*VM( IAM ) 319 T( 1, 3 ) = -TWO*VAL( IB ) 320 T( 1, 4 ) = HALF*VAL( IB ) 321 T( 2, 1 ) = -T( 1, 2 )*VAL( IA21 ) 322 T( 2, 2 ) = VAL( IA11 )* 323 $ DBLE( IA22 )*VM( IAM ) 324 T( 2, 3 ) = VAL( IB ) 325 T( 2, 4 ) = THREE*VAL( IB ) 326 T( 3, 1 ) = ZERO 327 T( 3, 2 ) = ZERO 328 T( 3, 3 ) = VAL( IC11 )* 329 $ ABS( VAL( ICM ) ) 330 T( 3, 4 ) = VAL( IC12 )* 331 $ ABS( VAL( ICM ) ) 332 T( 4, 1 ) = ZERO 333 T( 4, 2 ) = ZERO 334 T( 4, 3 ) = -T( 3, 4 )*VAL( IC21 )* 335 $ ABS( VAL( ICM ) ) 336 T( 4, 4 ) = VAL( IC11 )* 337 $ DBLE( IC22 )* 338 $ ABS( VAL( ICM ) ) 339 TNRM = ZERO 340 DO 200 I = 1, 4 341 DO 190 J = 1, 4 342 TNRM = MAX( TNRM, 343 $ ABS( T( I, J ) ) ) 344 190 CONTINUE 345 200 CONTINUE 346 CALL DCOPY( 16, T, 1, T1, 1 ) 347 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 348 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 349 CALL DLAEXC( .TRUE., 4, T, 4, Q, 4, 350 $ 1, 2, 2, WORK, INFO ) 351 IF( INFO.NE.0 ) 352 $ NINFO( INFO ) = NINFO( INFO ) + 1 353 CALL DHST01( 4, 1, 4, T1, 4, T, 4, 354 $ Q, 4, WORK, LWORK, 355 $ RESULT ) 356 RES = RESULT( 1 ) + RESULT( 2 ) 357 IF( INFO.EQ.0 ) THEN 358 IF( T( 3, 1 ).NE.ZERO ) 359 $ RES = RES + ONE / EPS 360 IF( T( 4, 1 ).NE.ZERO ) 361 $ RES = RES + ONE / EPS 362 IF( T( 3, 2 ).NE.ZERO ) 363 $ RES = RES + ONE / EPS 364 IF( T( 4, 2 ).NE.ZERO ) 365 $ RES = RES + ONE / EPS 366 IF( T( 2, 1 ).NE.0 .AND. 367 $ ( T( 1, 1 ).NE.T( 2, 368 $ 2 ) .OR. SIGN( ONE, T( 1, 369 $ 2 ) ).EQ.SIGN( ONE, T( 2, 370 $ 1 ) ) ) )RES = RES + 371 $ ONE / EPS 372 IF( T( 4, 3 ).NE.0 .AND. 373 $ ( T( 3, 3 ).NE.T( 4, 374 $ 4 ) .OR. SIGN( ONE, T( 3, 375 $ 4 ) ).EQ.SIGN( ONE, T( 4, 376 $ 3 ) ) ) )RES = RES + 377 $ ONE / EPS 378 END IF 379 KNT = KNT + 1 380 IF( RES.GT.RMAX ) THEN 381 LMAX = KNT 382 RMAX = RES 383 END IF 384 210 CONTINUE 385 220 CONTINUE 386 230 CONTINUE 387 240 CONTINUE 388 250 CONTINUE 389 260 CONTINUE 390 270 CONTINUE 391 280 CONTINUE 392 290 CONTINUE 393 300 CONTINUE 394* 395 RETURN 396* 397* End of DGET34 398* 399 END 400