|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 SUBROUTINE DGET33( 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, NINFO 00009 DOUBLE PRECISION RMAX 00010 * .. 00011 * 00012 * Purpose 00013 * ======= 00014 * 00015 * DGET33 tests DLANV2, a routine for putting 2 by 2 blocks into 00016 * standard form. In other words, it computes a two by two rotation 00017 * [[C,S];[-S,C]] where in 00018 * 00019 * [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ] 00020 * [-S C ][T(2,1) T(2,2)][ S C ] [ T21 T22 ] 00021 * 00022 * either 00023 * 1) T21=0 (real eigenvalues), or 00024 * 2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues). 00025 * We also verify that the residual is small. 00026 * 00027 * Arguments 00028 * ========== 00029 * 00030 * RMAX (output) DOUBLE PRECISION 00031 * Value of the largest test ratio. 00032 * 00033 * LMAX (output) INTEGER 00034 * Example number where largest test ratio achieved. 00035 * 00036 * NINFO (output) INTEGER 00037 * Number of examples returned with INFO .NE. 0. 00038 * 00039 * KNT (output) INTEGER 00040 * Total number of examples tested. 00041 * 00042 * ===================================================================== 00043 * 00044 * .. Parameters .. 00045 DOUBLE PRECISION ZERO, ONE 00046 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) 00047 DOUBLE PRECISION TWO, FOUR 00048 PARAMETER ( TWO = 2.0D0, FOUR = 4.0D0 ) 00049 * .. 00050 * .. Local Scalars .. 00051 INTEGER I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3 00052 DOUBLE PRECISION BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM, 00053 $ WI1, WI2, WR1, WR2 00054 * .. 00055 * .. Local Arrays .. 00056 DOUBLE PRECISION Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ), 00057 $ VAL( 4 ), VM( 3 ) 00058 * .. 00059 * .. External Functions .. 00060 DOUBLE PRECISION DLAMCH 00061 EXTERNAL DLAMCH 00062 * .. 00063 * .. External Subroutines .. 00064 EXTERNAL DLABAD, DLANV2 00065 * .. 00066 * .. Intrinsic Functions .. 00067 INTRINSIC ABS, MAX, SIGN 00068 * .. 00069 * .. Executable Statements .. 00070 * 00071 * Get machine parameters 00072 * 00073 EPS = DLAMCH( 'P' ) 00074 SMLNUM = DLAMCH( 'S' ) / EPS 00075 BIGNUM = ONE / SMLNUM 00076 CALL DLABAD( SMLNUM, BIGNUM ) 00077 * 00078 * Set up test case parameters 00079 * 00080 VAL( 1 ) = ONE 00081 VAL( 2 ) = ONE + TWO*EPS 00082 VAL( 3 ) = TWO 00083 VAL( 4 ) = TWO - FOUR*EPS 00084 VM( 1 ) = SMLNUM 00085 VM( 2 ) = ONE 00086 VM( 3 ) = BIGNUM 00087 * 00088 KNT = 0 00089 NINFO = 0 00090 LMAX = 0 00091 RMAX = ZERO 00092 * 00093 * Begin test loop 00094 * 00095 DO 150 I1 = 1, 4 00096 DO 140 I2 = 1, 4 00097 DO 130 I3 = 1, 4 00098 DO 120 I4 = 1, 4 00099 DO 110 IM1 = 1, 3 00100 DO 100 IM2 = 1, 3 00101 DO 90 IM3 = 1, 3 00102 DO 80 IM4 = 1, 3 00103 T( 1, 1 ) = VAL( I1 )*VM( IM1 ) 00104 T( 1, 2 ) = VAL( I2 )*VM( IM2 ) 00105 T( 2, 1 ) = -VAL( I3 )*VM( IM3 ) 00106 T( 2, 2 ) = VAL( I4 )*VM( IM4 ) 00107 TNRM = MAX( ABS( T( 1, 1 ) ), 00108 $ ABS( T( 1, 2 ) ), ABS( T( 2, 1 ) ), 00109 $ ABS( T( 2, 2 ) ) ) 00110 T1( 1, 1 ) = T( 1, 1 ) 00111 T1( 1, 2 ) = T( 1, 2 ) 00112 T1( 2, 1 ) = T( 2, 1 ) 00113 T1( 2, 2 ) = T( 2, 2 ) 00114 Q( 1, 1 ) = ONE 00115 Q( 1, 2 ) = ZERO 00116 Q( 2, 1 ) = ZERO 00117 Q( 2, 2 ) = ONE 00118 * 00119 CALL DLANV2( T( 1, 1 ), T( 1, 2 ), 00120 $ T( 2, 1 ), T( 2, 2 ), WR1, 00121 $ WI1, WR2, WI2, CS, SN ) 00122 DO 10 J1 = 1, 2 00123 RES = Q( J1, 1 )*CS + Q( J1, 2 )*SN 00124 Q( J1, 2 ) = -Q( J1, 1 )*SN + 00125 $ Q( J1, 2 )*CS 00126 Q( J1, 1 ) = RES 00127 10 CONTINUE 00128 * 00129 RES = ZERO 00130 RES = RES + ABS( Q( 1, 1 )**2+ 00131 $ Q( 1, 2 )**2-ONE ) / EPS 00132 RES = RES + ABS( Q( 2, 2 )**2+ 00133 $ Q( 2, 1 )**2-ONE ) / EPS 00134 RES = RES + ABS( Q( 1, 1 )*Q( 2, 1 )+ 00135 $ Q( 1, 2 )*Q( 2, 2 ) ) / EPS 00136 DO 40 J1 = 1, 2 00137 DO 30 J2 = 1, 2 00138 T2( J1, J2 ) = ZERO 00139 DO 20 J3 = 1, 2 00140 T2( J1, J2 ) = T2( J1, J2 ) + 00141 $ T1( J1, J3 )* 00142 $ Q( J3, J2 ) 00143 20 CONTINUE 00144 30 CONTINUE 00145 40 CONTINUE 00146 DO 70 J1 = 1, 2 00147 DO 60 J2 = 1, 2 00148 SUM = T( J1, J2 ) 00149 DO 50 J3 = 1, 2 00150 SUM = SUM - Q( J3, J1 )* 00151 $ T2( J3, J2 ) 00152 50 CONTINUE 00153 RES = RES + ABS( SUM ) / EPS / TNRM 00154 60 CONTINUE 00155 70 CONTINUE 00156 IF( T( 2, 1 ).NE.ZERO .AND. 00157 $ ( T( 1, 1 ).NE.T( 2, 00158 $ 2 ) .OR. SIGN( ONE, T( 1, 00159 $ 2 ) )*SIGN( ONE, T( 2, 00160 $ 1 ) ).GT.ZERO ) )RES = RES + ONE / EPS 00161 KNT = KNT + 1 00162 IF( RES.GT.RMAX ) THEN 00163 LMAX = KNT 00164 RMAX = RES 00165 END IF 00166 80 CONTINUE 00167 90 CONTINUE 00168 100 CONTINUE 00169 110 CONTINUE 00170 120 CONTINUE 00171 130 CONTINUE 00172 140 CONTINUE 00173 150 CONTINUE 00174 * 00175 RETURN 00176 * 00177 * End of DGET33 00178 * 00179 END
1.7.3 
