LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
 All Classes Files Functions Variables Typedefs Macros
sget36.f
Go to the documentation of this file.
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 *> \date November 2011
85 *
86 *> \ingroup single_eig
87 *
88 * =====================================================================
89  SUBROUTINE sget36( RMAX, LMAX, NINFO, KNT, NIN )
90 *
91 * -- LAPACK test routine (version 3.4.0) --
92 * -- LAPACK is a software package provided by Univ. of Tennessee, --
93 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
94 * November 2011
95 *
96 * .. Scalar Arguments ..
97  INTEGER knt, lmax, nin
98  REAL rmax
99 * ..
100 * .. Array Arguments ..
101  INTEGER ninfo( 3 )
102 * ..
103 *
104 * =====================================================================
105 *
106 * .. Parameters ..
107  REAL zero, one
108  parameter( zero = 0.0e0, one = 1.0e0 )
109  INTEGER ldt, lwork
110  parameter( ldt = 10, lwork = 2*ldt*ldt )
111 * ..
112 * .. Local Scalars ..
113  INTEGER i, ifst, ifst1, ifst2, ifstsv, ilst, ilst1,
114  $ ilst2, ilstsv, info1, info2, j, loc, n
115  REAL eps, res
116 * ..
117 * .. Local Arrays ..
118  REAL q( ldt, ldt ), result( 2 ), t1( ldt, ldt ),
119  $ t2( ldt, ldt ), tmp( ldt, ldt ), work( lwork )
120 * ..
121 * .. External Functions ..
122  REAL slamch
123  EXTERNAL slamch
124 * ..
125 * .. External Subroutines ..
126  EXTERNAL shst01, slacpy, slaset, strexc
127 * ..
128 * .. Intrinsic Functions ..
129  INTRINSIC abs, sign
130 * ..
131 * .. Executable Statements ..
132 *
133  eps = slamch( 'P' )
134  rmax = zero
135  lmax = 0
136  knt = 0
137  ninfo( 1 ) = 0
138  ninfo( 2 ) = 0
139  ninfo( 3 ) = 0
140 *
141 * Read input data until N=0
142 *
143  10 CONTINUE
144  READ( nin, fmt = * )n, ifst, ilst
145  IF( n.EQ.0 )
146  $ RETURN
147  knt = knt + 1
148  DO 20 i = 1, n
149  READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
150  20 CONTINUE
151  CALL slacpy( 'F', n, n, tmp, ldt, t1, ldt )
152  CALL slacpy( 'F', n, n, tmp, ldt, t2, ldt )
153  ifstsv = ifst
154  ilstsv = ilst
155  ifst1 = ifst
156  ilst1 = ilst
157  ifst2 = ifst
158  ilst2 = ilst
159  res = zero
160 *
161 * Test without accumulating Q
162 *
163  CALL slaset( 'Full', n, n, zero, one, q, ldt )
164  CALL strexc( 'N', n, t1, ldt, q, ldt, ifst1, ilst1, work, info1 )
165  DO 40 i = 1, n
166  DO 30 j = 1, n
167  IF( i.EQ.j .AND. q( i, j ).NE.one )
168  $ res = res + one / eps
169  IF( i.NE.j .AND. q( i, j ).NE.zero )
170  $ res = res + one / eps
171  30 CONTINUE
172  40 CONTINUE
173 *
174 * Test with accumulating Q
175 *
176  CALL slaset( 'Full', n, n, zero, one, q, ldt )
177  CALL strexc( 'V', n, t2, ldt, q, ldt, ifst2, ilst2, work, info2 )
178 *
179 * Compare T1 with T2
180 *
181  DO 60 i = 1, n
182  DO 50 j = 1, n
183  IF( t1( i, j ).NE.t2( i, j ) )
184  $ res = res + one / eps
185  50 CONTINUE
186  60 CONTINUE
187  IF( ifst1.NE.ifst2 )
188  $ res = res + one / eps
189  IF( ilst1.NE.ilst2 )
190  $ res = res + one / eps
191  IF( info1.NE.info2 )
192  $ res = res + one / eps
193 *
194 * Test for successful reordering of T2
195 *
196  IF( info2.NE.0 ) THEN
197  ninfo( info2 ) = ninfo( info2 ) + 1
198  ELSE
199  IF( abs( ifst2-ifstsv ).GT.1 )
200  $ res = res + one / eps
201  IF( abs( ilst2-ilstsv ).GT.1 )
202  $ res = res + one / eps
203  END IF
204 *
205 * Test for small residual, and orthogonality of Q
206 *
207  CALL shst01( n, 1, n, tmp, ldt, t2, ldt, q, ldt, work, lwork,
208  $ result )
209  res = res + result( 1 ) + result( 2 )
210 *
211 * Test for T2 being in Schur form
212 *
213  loc = 1
214  70 CONTINUE
215  IF( t2( loc+1, loc ).NE.zero ) THEN
216 *
217 * 2 by 2 block
218 *
219  IF( t2( loc, loc+1 ).EQ.zero .OR. t2( loc, loc ).NE.
220  $ t2( loc+1, loc+1 ) .OR. sign( one, t2( loc, loc+1 ) ).EQ.
221  $ sign( one, t2( loc+1, loc ) ) )res = res + one / eps
222  DO 80 i = loc + 2, n
223  IF( t2( i, loc ).NE.zero )
224  $ res = res + one / res
225  IF( t2( i, loc+1 ).NE.zero )
226  $ res = res + one / res
227  80 CONTINUE
228  loc = loc + 2
229  ELSE
230 *
231 * 1 by 1 block
232 *
233  DO 90 i = loc + 1, n
234  IF( t2( i, loc ).NE.zero )
235  $ res = res + one / res
236  90 CONTINUE
237  loc = loc + 1
238  END IF
239  IF( loc.LT.n )
240  $ go to 70
241  IF( res.GT.rmax ) THEN
242  rmax = res
243  lmax = knt
244  END IF
245  go to 10
246 *
247 * End of SGET36
248 *
249  END