1*> \brief \b SGET40 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 SGET40( RMAX, LMAX, NINFO, KNT, NIN ) 12* 13* .. Scalar Arguments .. 14* INTEGER KNT, LMAX, NIN 15* REAL RMAX 16* .. 17* .. Array Arguments .. 18* INTEGER NINFO( 3 ) 19* 20* 21*> \par Purpose: 22* ============= 23*> 24*> \verbatim 25*> 26*> SGET40 tests STGEXC, a routine for swapping adjacent blocks (either 27*> 1 by 1 or 2 by 2) on the diagonal of a pencil in real generalized Schur form. 28*> Thus, STGEXC computes an orthogonal matrices Q and Z such that 29*> 30*> Q' * ( [ A B ], [ D E ] ) * Z = ( [ C1 B1 ], [ F1 E1 ] ) 31*> ( [ 0 C ] [ F ] ) ( [ 0 A1 ] [ D1] ) 32*> 33*> where (C1,F1) is similar to (C,F) and (A1,D1) is similar to (A,D). 34*> Both (A,D) and (C,F) are assumed to be in standard form 35*> and (A1,D1) and (C1,F1) are returned with the 36*> same properties. 37*> \endverbatim 38* 39* Arguments: 40* ========== 41* 42*> \param[out] RMAX 43*> \verbatim 44*> RMAX is REAL 45*> Value of the largest test ratio. 46*> \endverbatim 47*> 48*> \param[out] LMAX 49*> \verbatim 50*> LMAX is INTEGER 51*> Example number where largest test ratio achieved. 52*> \endverbatim 53*> 54*> \param[out] NINFO 55*> \verbatim 56*> NINFO is INTEGER 57*> Number of examples where INFO is nonzero. 58*> \endverbatim 59*> 60*> \param[out] KNT 61*> \verbatim 62*> KNT is INTEGER 63*> Total number of examples tested. 64*> \endverbatim 65*> 66*> \param[out] NIN 67*> \verbatim 68*> NINFO is INTEGER 69*> \endverbatim 70* 71* Authors: 72* ======== 73* 74*> \author Univ. of Tennessee 75*> \author Univ. of California Berkeley 76*> \author Univ. of Colorado Denver 77*> \author NAG Ltd. 78* 79*> \ingroup double_eig 80* 81* ===================================================================== 82 SUBROUTINE SGET40( RMAX, LMAX, NINFO, KNT, NIN ) 83* 84* -- LAPACK test routine -- 85* -- LAPACK is a software package provided by Univ. of Tennessee, -- 86* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 87* 88* .. Scalar Arguments .. 89 INTEGER KNT, LMAX, NIN 90 REAL RMAX 91* .. 92* .. Array Arguments .. 93 INTEGER NINFO( 3 ) 94* .. 95* 96* ===================================================================== 97* 98* .. Parameters .. 99 REAL ZERO, ONE 100 PARAMETER ( ZERO = 0.0, ONE = 1.0 ) 101 INTEGER LDT, LWORK 102 PARAMETER ( LDT = 10, LWORK = 100 + 4*LDT + 16 ) 103* .. 104* .. Local Scalars .. 105 INTEGER I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1, 106 $ ILST2, ILSTSV, INFO1, INFO2, J, LOC, N 107 REAL EPS, RES 108* .. 109* .. Local Arrays .. 110 REAL Q( LDT, LDT ), Z( LDT, LDT ), RESULT( 4 ), 111 $ T( LDT, LDT ), T1( LDT, LDT ), T2( LDT, LDT ), 112 $ S( LDT, LDT ), S1( LDT, LDT ), S2( LDT, LDT ), 113 $ TMP( LDT, LDT ), WORK( LWORK ) 114* .. 115* .. External Functions .. 116 REAL SLAMCH 117 EXTERNAL SLAMCH 118* .. 119* .. External Subroutines .. 120 EXTERNAL SGET51, SLACPY, SLASET, STGEXC 121* .. 122* .. Intrinsic Functions .. 123 INTRINSIC ABS, SIGN 124* .. 125* .. Executable Statements .. 126* 127 EPS = SLAMCH( 'P' ) 128 RMAX = ZERO 129 LMAX = 0 130 KNT = 0 131 NINFO( 1 ) = 0 132 NINFO( 2 ) = 0 133 NINFO( 3 ) = 0 134* 135* Read input data until N=0 136* 137 10 CONTINUE 138 READ( NIN, FMT = * )N, IFST, ILST 139 IF( N.EQ.0 ) 140 $ RETURN 141 KNT = KNT + 1 142 DO 20 I = 1, N 143 READ( NIN, FMT = * )( TMP( I, J ), J = 1, N ) 144 20 CONTINUE 145 CALL SLACPY( 'F', N, N, TMP, LDT, T, LDT ) 146 CALL SLACPY( 'F', N, N, TMP, LDT, T1, LDT ) 147 CALL SLACPY( 'F', N, N, TMP, LDT, T2, LDT ) 148 DO 25 I = 1, N 149 READ( NIN, FMT = * )( TMP( I, J ), J = 1, N ) 150 25 CONTINUE 151 CALL SLACPY( 'F', N, N, TMP, LDT, S, LDT ) 152 CALL SLACPY( 'F', N, N, TMP, LDT, S1, LDT ) 153 CALL SLACPY( 'F', N, N, TMP, LDT, S2, LDT ) 154 IFSTSV = IFST 155 ILSTSV = ILST 156 IFST1 = IFST 157 ILST1 = ILST 158 IFST2 = IFST 159 ILST2 = ILST 160 RES = ZERO 161* 162* Test without accumulating Q and Z 163* 164 CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDT ) 165 CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDT ) 166 CALL STGEXC( .FALSE., .FALSE., N, T1, LDT, S1, LDT, Q, LDT, 167 $ Z, LDT, IFST1, ILST1, WORK, LWORK, INFO1 ) 168 DO 40 I = 1, N 169 DO 30 J = 1, N 170 IF( I.EQ.J .AND. Q( I, J ).NE.ONE ) 171 $ RES = RES + ONE / EPS 172 IF( I.NE.J .AND. Q( I, J ).NE.ZERO ) 173 $ RES = RES + ONE / EPS 174 IF( I.EQ.J .AND. Z( I, J ).NE.ONE ) 175 $ RES = RES + ONE / EPS 176 IF( I.NE.J .AND. Z( I, J ).NE.ZERO ) 177 $ RES = RES + ONE / EPS 178 30 CONTINUE 179 40 CONTINUE 180* 181* Test with accumulating Q 182* 183 CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDT ) 184 CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDT ) 185 CALL STGEXC( .TRUE., .TRUE., N, T2, LDT, S2, LDT, Q, LDT, 186 $ Z, LDT, IFST2, ILST2, WORK, LWORK, INFO2 ) 187* 188* Compare T1 with T2 and S1 with S2 189* 190 DO 60 I = 1, N 191 DO 50 J = 1, N 192 IF( T1( I, J ).NE.T2( I, J ) ) 193 $ RES = RES + ONE / EPS 194 IF( S1( I, J ).NE.S2( I, J ) ) 195 $ RES = RES + ONE / EPS 196 50 CONTINUE 197 60 CONTINUE 198 IF( IFST1.NE.IFST2 ) 199 $ RES = RES + ONE / EPS 200 IF( ILST1.NE.ILST2 ) 201 $ RES = RES + ONE / EPS 202 IF( INFO1.NE.INFO2 ) 203 $ RES = RES + ONE / EPS 204* 205* Test orthogonality of Q and Z and backward error on T2 and S2 206* 207 CALL SGET51( 1, N, T, LDT, T2, LDT, Q, LDT, Z, LDT, WORK, 208 $ RESULT( 1 ) ) 209 CALL SGET51( 1, N, S, LDT, S2, LDT, Q, LDT, Z, LDT, WORK, 210 $ RESULT( 2 ) ) 211 CALL SGET51( 3, N, T, LDT, T2, LDT, Q, LDT, Q, LDT, WORK, 212 $ RESULT( 3 ) ) 213 CALL SGET51( 3, N, T, LDT, T2, LDT, Z, LDT, Z, LDT, WORK, 214 $ RESULT( 4 ) ) 215 RES = RES + RESULT( 1 ) + RESULT( 2 ) + RESULT( 3 ) + RESULT( 4 ) 216* 217* Read next matrix pair 218* 219 GO TO 10 220* 221* End of SGET40 222* 223 END 224