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