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