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 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*> \date December 2016 79* 80*> \ingroup double_eig 81* 82* ===================================================================== 83 SUBROUTINE DGET34( RMAX, LMAX, NINFO, KNT ) 84* 85* -- LAPACK test routine (version 3.7.0) -- 86* -- LAPACK is a software package provided by Univ. of Tennessee, -- 87* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 88* December 2016 89* 90* .. Scalar Arguments .. 91 INTEGER KNT, LMAX 92 DOUBLE PRECISION RMAX 93* .. 94* .. Array Arguments .. 95 INTEGER NINFO( 2 ) 96* .. 97* 98* ===================================================================== 99* 100* .. Parameters .. 101 DOUBLE PRECISION ZERO, HALF, ONE 102 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) 103 DOUBLE PRECISION TWO, THREE 104 PARAMETER ( TWO = 2.0D0, THREE = 3.0D0 ) 105 INTEGER LWORK 106 PARAMETER ( LWORK = 32 ) 107* .. 108* .. Local Scalars .. 109 INTEGER I, IA, IA11, IA12, IA21, IA22, IAM, IB, IC, 110 $ IC11, IC12, IC21, IC22, ICM, INFO, J 111 DOUBLE PRECISION BIGNUM, EPS, RES, SMLNUM, TNRM 112* .. 113* .. Local Arrays .. 114 DOUBLE PRECISION Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ), 115 $ VAL( 9 ), VM( 2 ), WORK( LWORK ) 116* .. 117* .. External Functions .. 118 DOUBLE PRECISION DLAMCH 119 EXTERNAL DLAMCH 120* .. 121* .. External Subroutines .. 122 EXTERNAL DCOPY, DHST01, DLABAD, DLAEXC 123* .. 124* .. Intrinsic Functions .. 125 INTRINSIC ABS, DBLE, MAX, SIGN, SQRT 126* .. 127* .. Executable Statements .. 128* 129* Get machine parameters 130* 131 EPS = DLAMCH( 'P' ) 132 SMLNUM = DLAMCH( 'S' ) / EPS 133 BIGNUM = ONE / SMLNUM 134 CALL DLABAD( SMLNUM, BIGNUM ) 135* 136* Set up test case parameters 137* 138 VAL( 1 ) = ZERO 139 VAL( 2 ) = SQRT( SMLNUM ) 140 VAL( 3 ) = ONE 141 VAL( 4 ) = TWO 142 VAL( 5 ) = SQRT( BIGNUM ) 143 VAL( 6 ) = -SQRT( SMLNUM ) 144 VAL( 7 ) = -ONE 145 VAL( 8 ) = -TWO 146 VAL( 9 ) = -SQRT( BIGNUM ) 147 VM( 1 ) = ONE 148 VM( 2 ) = ONE + TWO*EPS 149 CALL DCOPY( 16, VAL( 4 ), 0, T( 1, 1 ), 1 ) 150* 151 NINFO( 1 ) = 0 152 NINFO( 2 ) = 0 153 KNT = 0 154 LMAX = 0 155 RMAX = ZERO 156* 157* Begin test loop 158* 159 DO 40 IA = 1, 9 160 DO 30 IAM = 1, 2 161 DO 20 IB = 1, 9 162 DO 10 IC = 1, 9 163 T( 1, 1 ) = VAL( IA )*VM( IAM ) 164 T( 2, 2 ) = VAL( IC ) 165 T( 1, 2 ) = VAL( IB ) 166 T( 2, 1 ) = ZERO 167 TNRM = MAX( ABS( T( 1, 1 ) ), ABS( T( 2, 2 ) ), 168 $ ABS( T( 1, 2 ) ) ) 169 CALL DCOPY( 16, T, 1, T1, 1 ) 170 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 171 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 172 CALL DLAEXC( .TRUE., 2, T, 4, Q, 4, 1, 1, 1, WORK, 173 $ INFO ) 174 IF( INFO.NE.0 ) 175 $ NINFO( INFO ) = NINFO( INFO ) + 1 176 CALL DHST01( 2, 1, 2, T1, 4, T, 4, Q, 4, WORK, LWORK, 177 $ RESULT ) 178 RES = RESULT( 1 ) + RESULT( 2 ) 179 IF( INFO.NE.0 ) 180 $ RES = RES + ONE / EPS 181 IF( T( 1, 1 ).NE.T1( 2, 2 ) ) 182 $ RES = RES + ONE / EPS 183 IF( T( 2, 2 ).NE.T1( 1, 1 ) ) 184 $ RES = RES + ONE / EPS 185 IF( T( 2, 1 ).NE.ZERO ) 186 $ RES = RES + ONE / EPS 187 KNT = KNT + 1 188 IF( RES.GT.RMAX ) THEN 189 LMAX = KNT 190 RMAX = RES 191 END IF 192 10 CONTINUE 193 20 CONTINUE 194 30 CONTINUE 195 40 CONTINUE 196* 197 DO 110 IA = 1, 5 198 DO 100 IAM = 1, 2 199 DO 90 IB = 1, 5 200 DO 80 IC11 = 1, 5 201 DO 70 IC12 = 2, 5 202 DO 60 IC21 = 2, 4 203 DO 50 IC22 = -1, 1, 2 204 T( 1, 1 ) = VAL( IA )*VM( IAM ) 205 T( 1, 2 ) = VAL( IB ) 206 T( 1, 3 ) = -TWO*VAL( IB ) 207 T( 2, 1 ) = ZERO 208 T( 2, 2 ) = VAL( IC11 ) 209 T( 2, 3 ) = VAL( IC12 ) 210 T( 3, 1 ) = ZERO 211 T( 3, 2 ) = -VAL( IC21 ) 212 T( 3, 3 ) = VAL( IC11 )*DBLE( IC22 ) 213 TNRM = MAX( ABS( T( 1, 1 ) ), 214 $ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ), 215 $ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ), 216 $ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) ) 217 CALL DCOPY( 16, T, 1, T1, 1 ) 218 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 219 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 220 CALL DLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 1, 2, 221 $ WORK, INFO ) 222 IF( INFO.NE.0 ) 223 $ NINFO( INFO ) = NINFO( INFO ) + 1 224 CALL DHST01( 3, 1, 3, T1, 4, T, 4, Q, 4, 225 $ WORK, LWORK, RESULT ) 226 RES = RESULT( 1 ) + RESULT( 2 ) 227 IF( INFO.EQ.0 ) THEN 228 IF( T1( 1, 1 ).NE.T( 3, 3 ) ) 229 $ RES = RES + ONE / EPS 230 IF( T( 3, 1 ).NE.ZERO ) 231 $ RES = RES + ONE / EPS 232 IF( T( 3, 2 ).NE.ZERO ) 233 $ RES = RES + ONE / EPS 234 IF( T( 2, 1 ).NE.0 .AND. 235 $ ( T( 1, 1 ).NE.T( 2, 236 $ 2 ) .OR. SIGN( ONE, T( 1, 237 $ 2 ) ).EQ.SIGN( ONE, T( 2, 1 ) ) ) ) 238 $ RES = RES + ONE / EPS 239 END IF 240 KNT = KNT + 1 241 IF( RES.GT.RMAX ) THEN 242 LMAX = KNT 243 RMAX = RES 244 END IF 245 50 CONTINUE 246 60 CONTINUE 247 70 CONTINUE 248 80 CONTINUE 249 90 CONTINUE 250 100 CONTINUE 251 110 CONTINUE 252* 253 DO 180 IA11 = 1, 5 254 DO 170 IA12 = 2, 5 255 DO 160 IA21 = 2, 4 256 DO 150 IA22 = -1, 1, 2 257 DO 140 ICM = 1, 2 258 DO 130 IB = 1, 5 259 DO 120 IC = 1, 5 260 T( 1, 1 ) = VAL( IA11 ) 261 T( 1, 2 ) = VAL( IA12 ) 262 T( 1, 3 ) = -TWO*VAL( IB ) 263 T( 2, 1 ) = -VAL( IA21 ) 264 T( 2, 2 ) = VAL( IA11 )*DBLE( IA22 ) 265 T( 2, 3 ) = VAL( IB ) 266 T( 3, 1 ) = ZERO 267 T( 3, 2 ) = ZERO 268 T( 3, 3 ) = VAL( IC )*VM( ICM ) 269 TNRM = MAX( ABS( T( 1, 1 ) ), 270 $ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ), 271 $ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ), 272 $ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) ) 273 CALL DCOPY( 16, T, 1, T1, 1 ) 274 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 275 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 276 CALL DLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 2, 1, 277 $ WORK, INFO ) 278 IF( INFO.NE.0 ) 279 $ NINFO( INFO ) = NINFO( INFO ) + 1 280 CALL DHST01( 3, 1, 3, T1, 4, T, 4, Q, 4, 281 $ WORK, LWORK, RESULT ) 282 RES = RESULT( 1 ) + RESULT( 2 ) 283 IF( INFO.EQ.0 ) THEN 284 IF( T1( 3, 3 ).NE.T( 1, 1 ) ) 285 $ RES = RES + ONE / EPS 286 IF( T( 2, 1 ).NE.ZERO ) 287 $ RES = RES + ONE / EPS 288 IF( T( 3, 1 ).NE.ZERO ) 289 $ RES = RES + ONE / EPS 290 IF( T( 3, 2 ).NE.0 .AND. 291 $ ( T( 2, 2 ).NE.T( 3, 292 $ 3 ) .OR. SIGN( ONE, T( 2, 293 $ 3 ) ).EQ.SIGN( ONE, T( 3, 2 ) ) ) ) 294 $ RES = RES + ONE / EPS 295 END IF 296 KNT = KNT + 1 297 IF( RES.GT.RMAX ) THEN 298 LMAX = KNT 299 RMAX = RES 300 END IF 301 120 CONTINUE 302 130 CONTINUE 303 140 CONTINUE 304 150 CONTINUE 305 160 CONTINUE 306 170 CONTINUE 307 180 CONTINUE 308* 309 DO 300 IA11 = 1, 5 310 DO 290 IA12 = 2, 5 311 DO 280 IA21 = 2, 4 312 DO 270 IA22 = -1, 1, 2 313 DO 260 IB = 1, 5 314 DO 250 IC11 = 3, 4 315 DO 240 IC12 = 3, 4 316 DO 230 IC21 = 3, 4 317 DO 220 IC22 = -1, 1, 2 318 DO 210 ICM = 5, 7 319 IAM = 1 320 T( 1, 1 ) = VAL( IA11 )*VM( IAM ) 321 T( 1, 2 ) = VAL( IA12 )*VM( IAM ) 322 T( 1, 3 ) = -TWO*VAL( IB ) 323 T( 1, 4 ) = HALF*VAL( IB ) 324 T( 2, 1 ) = -T( 1, 2 )*VAL( IA21 ) 325 T( 2, 2 ) = VAL( IA11 )* 326 $ DBLE( IA22 )*VM( IAM ) 327 T( 2, 3 ) = VAL( IB ) 328 T( 2, 4 ) = THREE*VAL( IB ) 329 T( 3, 1 ) = ZERO 330 T( 3, 2 ) = ZERO 331 T( 3, 3 ) = VAL( IC11 )* 332 $ ABS( VAL( ICM ) ) 333 T( 3, 4 ) = VAL( IC12 )* 334 $ ABS( VAL( ICM ) ) 335 T( 4, 1 ) = ZERO 336 T( 4, 2 ) = ZERO 337 T( 4, 3 ) = -T( 3, 4 )*VAL( IC21 )* 338 $ ABS( VAL( ICM ) ) 339 T( 4, 4 ) = VAL( IC11 )* 340 $ DBLE( IC22 )* 341 $ ABS( VAL( ICM ) ) 342 TNRM = ZERO 343 DO 200 I = 1, 4 344 DO 190 J = 1, 4 345 TNRM = MAX( TNRM, 346 $ ABS( T( I, J ) ) ) 347 190 CONTINUE 348 200 CONTINUE 349 CALL DCOPY( 16, T, 1, T1, 1 ) 350 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 351 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 352 CALL DLAEXC( .TRUE., 4, T, 4, Q, 4, 353 $ 1, 2, 2, WORK, INFO ) 354 IF( INFO.NE.0 ) 355 $ NINFO( INFO ) = NINFO( INFO ) + 1 356 CALL DHST01( 4, 1, 4, T1, 4, T, 4, 357 $ Q, 4, WORK, LWORK, 358 $ RESULT ) 359 RES = RESULT( 1 ) + RESULT( 2 ) 360 IF( INFO.EQ.0 ) THEN 361 IF( T( 3, 1 ).NE.ZERO ) 362 $ RES = RES + ONE / EPS 363 IF( T( 4, 1 ).NE.ZERO ) 364 $ RES = RES + ONE / EPS 365 IF( T( 3, 2 ).NE.ZERO ) 366 $ RES = RES + ONE / EPS 367 IF( T( 4, 2 ).NE.ZERO ) 368 $ RES = RES + ONE / EPS 369 IF( T( 2, 1 ).NE.0 .AND. 370 $ ( T( 1, 1 ).NE.T( 2, 371 $ 2 ) .OR. SIGN( ONE, T( 1, 372 $ 2 ) ).EQ.SIGN( ONE, T( 2, 373 $ 1 ) ) ) )RES = RES + 374 $ ONE / EPS 375 IF( T( 4, 3 ).NE.0 .AND. 376 $ ( T( 3, 3 ).NE.T( 4, 377 $ 4 ) .OR. SIGN( ONE, T( 3, 378 $ 4 ) ).EQ.SIGN( ONE, T( 4, 379 $ 3 ) ) ) )RES = RES + 380 $ ONE / EPS 381 END IF 382 KNT = KNT + 1 383 IF( RES.GT.RMAX ) THEN 384 LMAX = KNT 385 RMAX = RES 386 END IF 387 210 CONTINUE 388 220 CONTINUE 389 230 CONTINUE 390 240 CONTINUE 391 250 CONTINUE 392 260 CONTINUE 393 270 CONTINUE 394 280 CONTINUE 395 290 CONTINUE 396 300 CONTINUE 397* 398 RETURN 399* 400* End of DGET34 401* 402 END 403