1*> \brief \b SGET36
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 SGET36( 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*
22*> \par Purpose:
23*  =============
24*>
25*> \verbatim
26*>
27*> SGET36 tests STREXC, a routine for moving blocks (either 1 by 1 or
28*> 2 by 2) on the diagonal of a matrix in real Schur form.  Thus, SLAEXC
29*> computes an orthogonal matrix Q such that
30*>
31*>    Q' * T1 * Q  = T2
32*>
33*> and where one of the diagonal blocks of T1 (the one at row IFST) has
34*> been moved to position ILST.
35*>
36*> The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
37*> is in Schur form, and that the final position of the IFST block is
38*> ILST (within +-1).
39*>
40*> The test matrices are read from a file with logical unit number NIN.
41*> \endverbatim
42*
43*  Arguments:
44*  ==========
45*
46*> \param[out] RMAX
47*> \verbatim
48*>          RMAX is REAL
49*>          Value of the largest test ratio.
50*> \endverbatim
51*>
52*> \param[out] LMAX
53*> \verbatim
54*>          LMAX is INTEGER
55*>          Example number where largest test ratio achieved.
56*> \endverbatim
57*>
58*> \param[out] NINFO
59*> \verbatim
60*>          NINFO is INTEGER array, dimension (3)
61*>          NINFO(J) is the number of examples where INFO=J.
62*> \endverbatim
63*>
64*> \param[out] KNT
65*> \verbatim
66*>          KNT is INTEGER
67*>          Total number of examples tested.
68*> \endverbatim
69*>
70*> \param[in] NIN
71*> \verbatim
72*>          NIN is INTEGER
73*>          Input logical unit number.
74*> \endverbatim
75*
76*  Authors:
77*  ========
78*
79*> \author Univ. of Tennessee
80*> \author Univ. of California Berkeley
81*> \author Univ. of Colorado Denver
82*> \author NAG Ltd.
83*
84*> \ingroup single_eig
85*
86*  =====================================================================
87      SUBROUTINE SGET36( RMAX, LMAX, NINFO, KNT, NIN )
88*
89*  -- LAPACK test routine --
90*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
91*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
92*
93*     .. Scalar Arguments ..
94      INTEGER            KNT, LMAX, NIN
95      REAL               RMAX
96*     ..
97*     .. Array Arguments ..
98      INTEGER            NINFO( 3 )
99*     ..
100*
101*  =====================================================================
102*
103*     .. Parameters ..
104      REAL               ZERO, ONE
105      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
106      INTEGER            LDT, LWORK
107      PARAMETER          ( LDT = 10, LWORK = 2*LDT*LDT )
108*     ..
109*     .. Local Scalars ..
110      INTEGER            I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
111     $                   ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
112      REAL               EPS, RES
113*     ..
114*     .. Local Arrays ..
115      REAL               Q( LDT, LDT ), RESULT( 2 ), T1( LDT, LDT ),
116     $                   T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
117*     ..
118*     .. External Functions ..
119      REAL               SLAMCH
120      EXTERNAL           SLAMCH
121*     ..
122*     .. External Subroutines ..
123      EXTERNAL           SHST01, SLACPY, SLASET, STREXC
124*     ..
125*     .. Intrinsic Functions ..
126      INTRINSIC          ABS, SIGN
127*     ..
128*     .. Executable Statements ..
129*
130      EPS = SLAMCH( 'P' )
131      RMAX = ZERO
132      LMAX = 0
133      KNT = 0
134      NINFO( 1 ) = 0
135      NINFO( 2 ) = 0
136      NINFO( 3 ) = 0
137*
138*     Read input data until N=0
139*
140   10 CONTINUE
141      READ( NIN, FMT = * )N, IFST, ILST
142      IF( N.EQ.0 )
143     $   RETURN
144      KNT = KNT + 1
145      DO 20 I = 1, N
146         READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
147   20 CONTINUE
148      CALL SLACPY( 'F', N, N, TMP, LDT, T1, LDT )
149      CALL SLACPY( 'F', N, N, TMP, LDT, T2, LDT )
150      IFSTSV = IFST
151      ILSTSV = ILST
152      IFST1 = IFST
153      ILST1 = ILST
154      IFST2 = IFST
155      ILST2 = ILST
156      RES = ZERO
157*
158*     Test without accumulating Q
159*
160      CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
161      CALL STREXC( 'N', N, T1, LDT, Q, LDT, IFST1, ILST1, WORK, INFO1 )
162      DO 40 I = 1, N
163         DO 30 J = 1, N
164            IF( I.EQ.J .AND. Q( I, J ).NE.ONE )
165     $         RES = RES + ONE / EPS
166            IF( I.NE.J .AND. Q( I, J ).NE.ZERO )
167     $         RES = RES + ONE / EPS
168   30    CONTINUE
169   40 CONTINUE
170*
171*     Test with accumulating Q
172*
173      CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
174      CALL STREXC( 'V', N, T2, LDT, Q, LDT, IFST2, ILST2, WORK, INFO2 )
175*
176*     Compare T1 with T2
177*
178      DO 60 I = 1, N
179         DO 50 J = 1, N
180            IF( T1( I, J ).NE.T2( I, J ) )
181     $         RES = RES + ONE / EPS
182   50    CONTINUE
183   60 CONTINUE
184      IF( IFST1.NE.IFST2 )
185     $   RES = RES + ONE / EPS
186      IF( ILST1.NE.ILST2 )
187     $   RES = RES + ONE / EPS
188      IF( INFO1.NE.INFO2 )
189     $   RES = RES + ONE / EPS
190*
191*     Test for successful reordering of T2
192*
193      IF( INFO2.NE.0 ) THEN
194         NINFO( INFO2 ) = NINFO( INFO2 ) + 1
195      ELSE
196         IF( ABS( IFST2-IFSTSV ).GT.1 )
197     $      RES = RES + ONE / EPS
198         IF( ABS( ILST2-ILSTSV ).GT.1 )
199     $      RES = RES + ONE / EPS
200      END IF
201*
202*     Test for small residual, and orthogonality of Q
203*
204      CALL SHST01( N, 1, N, TMP, LDT, T2, LDT, Q, LDT, WORK, LWORK,
205     $             RESULT )
206      RES = RES + RESULT( 1 ) + RESULT( 2 )
207*
208*     Test for T2 being in Schur form
209*
210      LOC = 1
211   70 CONTINUE
212      IF( T2( LOC+1, LOC ).NE.ZERO ) THEN
213*
214*        2 by 2 block
215*
216         IF( T2( LOC, LOC+1 ).EQ.ZERO .OR. T2( LOC, LOC ).NE.
217     $       T2( LOC+1, LOC+1 ) .OR. SIGN( ONE, T2( LOC, LOC+1 ) ).EQ.
218     $       SIGN( ONE, T2( LOC+1, LOC ) ) )RES = RES + ONE / EPS
219         DO 80 I = LOC + 2, N
220            IF( T2( I, LOC ).NE.ZERO )
221     $         RES = RES + ONE / RES
222            IF( T2( I, LOC+1 ).NE.ZERO )
223     $         RES = RES + ONE / RES
224   80    CONTINUE
225         LOC = LOC + 2
226      ELSE
227*
228*        1 by 1 block
229*
230         DO 90 I = LOC + 1, N
231            IF( T2( I, LOC ).NE.ZERO )
232     $         RES = RES + ONE / RES
233   90    CONTINUE
234         LOC = LOC + 1
235      END IF
236      IF( LOC.LT.N )
237     $   GO TO 70
238      IF( RES.GT.RMAX ) THEN
239         RMAX = RES
240         LMAX = KNT
241      END IF
242      GO TO 10
243*
244*     End of SGET36
245*
246      END
247