|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE DGET34( RMAX, LMAX, NINFO, KNT ) 00002 * 00003 * -- LAPACK test routine (version 3.1) -- 00004 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. 00005 * November 2006 00006 * 00007 * .. Scalar Arguments .. 00008 INTEGER KNT, LMAX 00009 DOUBLE PRECISION RMAX 00010 * .. 00011 * .. Array Arguments .. 00012 INTEGER NINFO( 2 ) 00013 * .. 00014 * 00015 * Purpose 00016 * ======= 00017 * 00018 * DGET34 tests DLAEXC, a routine for swapping adjacent blocks (either 00019 * 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form. 00020 * Thus, DLAEXC computes an orthogonal matrix Q such that 00021 * 00022 * Q' * [ A B ] * Q = [ C1 B1 ] 00023 * [ 0 C ] [ 0 A1 ] 00024 * 00025 * where C1 is similar to C and A1 is similar to A. Both A and C are 00026 * assumed to be in standard form (equal diagonal entries and 00027 * offdiagonal with differing signs) and A1 and C1 are returned with the 00028 * same properties. 00029 * 00030 * The test code verifies these last last assertions, as well as that 00031 * the residual in the above equation is small. 00032 * 00033 * Arguments 00034 * ========== 00035 * 00036 * RMAX (output) DOUBLE PRECISION 00037 * Value of the largest test ratio. 00038 * 00039 * LMAX (output) INTEGER 00040 * Example number where largest test ratio achieved. 00041 * 00042 * NINFO (output) INTEGER array, dimension (2) 00043 * NINFO(J) is the number of examples where INFO=J occurred. 00044 * 00045 * KNT (output) INTEGER 00046 * Total number of examples tested. 00047 * 00048 * ===================================================================== 00049 * 00050 * .. Parameters .. 00051 DOUBLE PRECISION ZERO, HALF, ONE 00052 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) 00053 DOUBLE PRECISION TWO, THREE 00054 PARAMETER ( TWO = 2.0D0, THREE = 3.0D0 ) 00055 INTEGER LWORK 00056 PARAMETER ( LWORK = 32 ) 00057 * .. 00058 * .. Local Scalars .. 00059 INTEGER I, IA, IA11, IA12, IA21, IA22, IAM, IB, IC, 00060 $ IC11, IC12, IC21, IC22, ICM, INFO, J 00061 DOUBLE PRECISION BIGNUM, EPS, RES, SMLNUM, TNRM 00062 * .. 00063 * .. Local Arrays .. 00064 DOUBLE PRECISION Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ), 00065 $ VAL( 9 ), VM( 2 ), WORK( LWORK ) 00066 * .. 00067 * .. External Functions .. 00068 DOUBLE PRECISION DLAMCH 00069 EXTERNAL DLAMCH 00070 * .. 00071 * .. External Subroutines .. 00072 EXTERNAL DCOPY, DHST01, DLABAD, DLAEXC 00073 * .. 00074 * .. Intrinsic Functions .. 00075 INTRINSIC ABS, DBLE, MAX, SIGN, SQRT 00076 * .. 00077 * .. Executable Statements .. 00078 * 00079 * Get machine parameters 00080 * 00081 EPS = DLAMCH( 'P' ) 00082 SMLNUM = DLAMCH( 'S' ) / EPS 00083 BIGNUM = ONE / SMLNUM 00084 CALL DLABAD( SMLNUM, BIGNUM ) 00085 * 00086 * Set up test case parameters 00087 * 00088 VAL( 1 ) = ZERO 00089 VAL( 2 ) = SQRT( SMLNUM ) 00090 VAL( 3 ) = ONE 00091 VAL( 4 ) = TWO 00092 VAL( 5 ) = SQRT( BIGNUM ) 00093 VAL( 6 ) = -SQRT( SMLNUM ) 00094 VAL( 7 ) = -ONE 00095 VAL( 8 ) = -TWO 00096 VAL( 9 ) = -SQRT( BIGNUM ) 00097 VM( 1 ) = ONE 00098 VM( 2 ) = ONE + TWO*EPS 00099 CALL DCOPY( 16, VAL( 4 ), 0, T( 1, 1 ), 1 ) 00100 * 00101 NINFO( 1 ) = 0 00102 NINFO( 2 ) = 0 00103 KNT = 0 00104 LMAX = 0 00105 RMAX = ZERO 00106 * 00107 * Begin test loop 00108 * 00109 DO 40 IA = 1, 9 00110 DO 30 IAM = 1, 2 00111 DO 20 IB = 1, 9 00112 DO 10 IC = 1, 9 00113 T( 1, 1 ) = VAL( IA )*VM( IAM ) 00114 T( 2, 2 ) = VAL( IC ) 00115 T( 1, 2 ) = VAL( IB ) 00116 T( 2, 1 ) = ZERO 00117 TNRM = MAX( ABS( T( 1, 1 ) ), ABS( T( 2, 2 ) ), 00118 $ ABS( T( 1, 2 ) ) ) 00119 CALL DCOPY( 16, T, 1, T1, 1 ) 00120 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 00121 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 00122 CALL DLAEXC( .TRUE., 2, T, 4, Q, 4, 1, 1, 1, WORK, 00123 $ INFO ) 00124 IF( INFO.NE.0 ) 00125 $ NINFO( INFO ) = NINFO( INFO ) + 1 00126 CALL DHST01( 2, 1, 2, T1, 4, T, 4, Q, 4, WORK, LWORK, 00127 $ RESULT ) 00128 RES = RESULT( 1 ) + RESULT( 2 ) 00129 IF( INFO.NE.0 ) 00130 $ RES = RES + ONE / EPS 00131 IF( T( 1, 1 ).NE.T1( 2, 2 ) ) 00132 $ RES = RES + ONE / EPS 00133 IF( T( 2, 2 ).NE.T1( 1, 1 ) ) 00134 $ RES = RES + ONE / EPS 00135 IF( T( 2, 1 ).NE.ZERO ) 00136 $ RES = RES + ONE / EPS 00137 KNT = KNT + 1 00138 IF( RES.GT.RMAX ) THEN 00139 LMAX = KNT 00140 RMAX = RES 00141 END IF 00142 10 CONTINUE 00143 20 CONTINUE 00144 30 CONTINUE 00145 40 CONTINUE 00146 * 00147 DO 110 IA = 1, 5 00148 DO 100 IAM = 1, 2 00149 DO 90 IB = 1, 5 00150 DO 80 IC11 = 1, 5 00151 DO 70 IC12 = 2, 5 00152 DO 60 IC21 = 2, 4 00153 DO 50 IC22 = -1, 1, 2 00154 T( 1, 1 ) = VAL( IA )*VM( IAM ) 00155 T( 1, 2 ) = VAL( IB ) 00156 T( 1, 3 ) = -TWO*VAL( IB ) 00157 T( 2, 1 ) = ZERO 00158 T( 2, 2 ) = VAL( IC11 ) 00159 T( 2, 3 ) = VAL( IC12 ) 00160 T( 3, 1 ) = ZERO 00161 T( 3, 2 ) = -VAL( IC21 ) 00162 T( 3, 3 ) = VAL( IC11 )*DBLE( IC22 ) 00163 TNRM = MAX( ABS( T( 1, 1 ) ), 00164 $ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ), 00165 $ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ), 00166 $ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) ) 00167 CALL DCOPY( 16, T, 1, T1, 1 ) 00168 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 00169 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 00170 CALL DLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 1, 2, 00171 $ WORK, INFO ) 00172 IF( INFO.NE.0 ) 00173 $ NINFO( INFO ) = NINFO( INFO ) + 1 00174 CALL DHST01( 3, 1, 3, T1, 4, T, 4, Q, 4, 00175 $ WORK, LWORK, RESULT ) 00176 RES = RESULT( 1 ) + RESULT( 2 ) 00177 IF( INFO.EQ.0 ) THEN 00178 IF( T1( 1, 1 ).NE.T( 3, 3 ) ) 00179 $ RES = RES + ONE / EPS 00180 IF( T( 3, 1 ).NE.ZERO ) 00181 $ RES = RES + ONE / EPS 00182 IF( T( 3, 2 ).NE.ZERO ) 00183 $ RES = RES + ONE / EPS 00184 IF( T( 2, 1 ).NE.0 .AND. 00185 $ ( T( 1, 1 ).NE.T( 2, 00186 $ 2 ) .OR. SIGN( ONE, T( 1, 00187 $ 2 ) ).EQ.SIGN( ONE, T( 2, 1 ) ) ) ) 00188 $ RES = RES + ONE / EPS 00189 END IF 00190 KNT = KNT + 1 00191 IF( RES.GT.RMAX ) THEN 00192 LMAX = KNT 00193 RMAX = RES 00194 END IF 00195 50 CONTINUE 00196 60 CONTINUE 00197 70 CONTINUE 00198 80 CONTINUE 00199 90 CONTINUE 00200 100 CONTINUE 00201 110 CONTINUE 00202 * 00203 DO 180 IA11 = 1, 5 00204 DO 170 IA12 = 2, 5 00205 DO 160 IA21 = 2, 4 00206 DO 150 IA22 = -1, 1, 2 00207 DO 140 ICM = 1, 2 00208 DO 130 IB = 1, 5 00209 DO 120 IC = 1, 5 00210 T( 1, 1 ) = VAL( IA11 ) 00211 T( 1, 2 ) = VAL( IA12 ) 00212 T( 1, 3 ) = -TWO*VAL( IB ) 00213 T( 2, 1 ) = -VAL( IA21 ) 00214 T( 2, 2 ) = VAL( IA11 )*DBLE( IA22 ) 00215 T( 2, 3 ) = VAL( IB ) 00216 T( 3, 1 ) = ZERO 00217 T( 3, 2 ) = ZERO 00218 T( 3, 3 ) = VAL( IC )*VM( ICM ) 00219 TNRM = MAX( ABS( T( 1, 1 ) ), 00220 $ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ), 00221 $ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ), 00222 $ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) ) 00223 CALL DCOPY( 16, T, 1, T1, 1 ) 00224 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 00225 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 00226 CALL DLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 2, 1, 00227 $ WORK, INFO ) 00228 IF( INFO.NE.0 ) 00229 $ NINFO( INFO ) = NINFO( INFO ) + 1 00230 CALL DHST01( 3, 1, 3, T1, 4, T, 4, Q, 4, 00231 $ WORK, LWORK, RESULT ) 00232 RES = RESULT( 1 ) + RESULT( 2 ) 00233 IF( INFO.EQ.0 ) THEN 00234 IF( T1( 3, 3 ).NE.T( 1, 1 ) ) 00235 $ RES = RES + ONE / EPS 00236 IF( T( 2, 1 ).NE.ZERO ) 00237 $ RES = RES + ONE / EPS 00238 IF( T( 3, 1 ).NE.ZERO ) 00239 $ RES = RES + ONE / EPS 00240 IF( T( 3, 2 ).NE.0 .AND. 00241 $ ( T( 2, 2 ).NE.T( 3, 00242 $ 3 ) .OR. SIGN( ONE, T( 2, 00243 $ 3 ) ).EQ.SIGN( ONE, T( 3, 2 ) ) ) ) 00244 $ RES = RES + ONE / EPS 00245 END IF 00246 KNT = KNT + 1 00247 IF( RES.GT.RMAX ) THEN 00248 LMAX = KNT 00249 RMAX = RES 00250 END IF 00251 120 CONTINUE 00252 130 CONTINUE 00253 140 CONTINUE 00254 150 CONTINUE 00255 160 CONTINUE 00256 170 CONTINUE 00257 180 CONTINUE 00258 * 00259 DO 300 IA11 = 1, 5 00260 DO 290 IA12 = 2, 5 00261 DO 280 IA21 = 2, 4 00262 DO 270 IA22 = -1, 1, 2 00263 DO 260 IB = 1, 5 00264 DO 250 IC11 = 3, 4 00265 DO 240 IC12 = 3, 4 00266 DO 230 IC21 = 3, 4 00267 DO 220 IC22 = -1, 1, 2 00268 DO 210 ICM = 5, 7 00269 IAM = 1 00270 T( 1, 1 ) = VAL( IA11 )*VM( IAM ) 00271 T( 1, 2 ) = VAL( IA12 )*VM( IAM ) 00272 T( 1, 3 ) = -TWO*VAL( IB ) 00273 T( 1, 4 ) = HALF*VAL( IB ) 00274 T( 2, 1 ) = -T( 1, 2 )*VAL( IA21 ) 00275 T( 2, 2 ) = VAL( IA11 )* 00276 $ DBLE( IA22 )*VM( IAM ) 00277 T( 2, 3 ) = VAL( IB ) 00278 T( 2, 4 ) = THREE*VAL( IB ) 00279 T( 3, 1 ) = ZERO 00280 T( 3, 2 ) = ZERO 00281 T( 3, 3 ) = VAL( IC11 )* 00282 $ ABS( VAL( ICM ) ) 00283 T( 3, 4 ) = VAL( IC12 )* 00284 $ ABS( VAL( ICM ) ) 00285 T( 4, 1 ) = ZERO 00286 T( 4, 2 ) = ZERO 00287 T( 4, 3 ) = -T( 3, 4 )*VAL( IC21 )* 00288 $ ABS( VAL( ICM ) ) 00289 T( 4, 4 ) = VAL( IC11 )* 00290 $ DBLE( IC22 )* 00291 $ ABS( VAL( ICM ) ) 00292 TNRM = ZERO 00293 DO 200 I = 1, 4 00294 DO 190 J = 1, 4 00295 TNRM = MAX( TNRM, 00296 $ ABS( T( I, J ) ) ) 00297 190 CONTINUE 00298 200 CONTINUE 00299 CALL DCOPY( 16, T, 1, T1, 1 ) 00300 CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 ) 00301 CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 ) 00302 CALL DLAEXC( .TRUE., 4, T, 4, Q, 4, 00303 $ 1, 2, 2, WORK, INFO ) 00304 IF( INFO.NE.0 ) 00305 $ NINFO( INFO ) = NINFO( INFO ) + 1 00306 CALL DHST01( 4, 1, 4, T1, 4, T, 4, 00307 $ Q, 4, WORK, LWORK, 00308 $ RESULT ) 00309 RES = RESULT( 1 ) + RESULT( 2 ) 00310 IF( INFO.EQ.0 ) THEN 00311 IF( T( 3, 1 ).NE.ZERO ) 00312 $ RES = RES + ONE / EPS 00313 IF( T( 4, 1 ).NE.ZERO ) 00314 $ RES = RES + ONE / EPS 00315 IF( T( 3, 2 ).NE.ZERO ) 00316 $ RES = RES + ONE / EPS 00317 IF( T( 4, 2 ).NE.ZERO ) 00318 $ RES = RES + ONE / EPS 00319 IF( T( 2, 1 ).NE.0 .AND. 00320 $ ( T( 1, 1 ).NE.T( 2, 00321 $ 2 ) .OR. SIGN( ONE, T( 1, 00322 $ 2 ) ).EQ.SIGN( ONE, T( 2, 00323 $ 1 ) ) ) )RES = RES + 00324 $ ONE / EPS 00325 IF( T( 4, 3 ).NE.0 .AND. 00326 $ ( T( 3, 3 ).NE.T( 4, 00327 $ 4 ) .OR. SIGN( ONE, T( 3, 00328 $ 4 ) ).EQ.SIGN( ONE, T( 4, 00329 $ 3 ) ) ) )RES = RES + 00330 $ ONE / EPS 00331 END IF 00332 KNT = KNT + 1 00333 IF( RES.GT.RMAX ) THEN 00334 LMAX = KNT 00335 RMAX = RES 00336 END IF 00337 210 CONTINUE 00338 220 CONTINUE 00339 230 CONTINUE 00340 240 CONTINUE 00341 250 CONTINUE 00342 260 CONTINUE 00343 270 CONTINUE 00344 280 CONTINUE 00345 290 CONTINUE 00346 300 CONTINUE 00347 * 00348 RETURN 00349 * 00350 * End of DGET34 00351 * 00352 END
1.7.3 
