LAPACK  3.7.1
LAPACK: Linear Algebra PACKage
sget34.f
Go to the documentation of this file.
1 *> \brief \b SGET34
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 SGET34( RMAX, LMAX, NINFO, KNT )
12 *
13 * .. Scalar Arguments ..
14 * INTEGER KNT, LMAX
15 * REAL RMAX
16 * ..
17 * .. Array Arguments ..
18 * INTEGER NINFO( 2 )
19 * ..
20 *
21 *
22 *> \par Purpose:
23 * =============
24 *>
25 *> \verbatim
26 *>
27 *> SGET34 tests SLAEXC, a routine for swapping adjacent blocks (either
28 *> 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form.
29 *> Thus, SLAEXC computes an orthogonal matrix Q such that
30 *>
31 *> Q' * [ A B ] * Q = [ C1 B1 ]
32 *> [ 0 C ] [ 0 A1 ]
33 *>
34 *> where C1 is similar to C and A1 is similar to A. Both A and C are
35 *> assumed to be in standard form (equal diagonal entries and
36 *> offdiagonal with differing signs) and A1 and C1 are returned with the
37 *> same properties.
38 *>
39 *> The test code verifies these last last assertions, as well as that
40 *> the residual in the above equation is small.
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 (2)
61 *> NINFO(J) is the number of examples where INFO=J occurred.
62 *> \endverbatim
63 *>
64 *> \param[out] KNT
65 *> \verbatim
66 *> KNT is INTEGER
67 *> Total number of examples tested.
68 *> \endverbatim
69 *
70 * Authors:
71 * ========
72 *
73 *> \author Univ. of Tennessee
74 *> \author Univ. of California Berkeley
75 *> \author Univ. of Colorado Denver
76 *> \author NAG Ltd.
77 *
78 *> \date December 2016
79 *
80 *> \ingroup single_eig
81 *
82 * =====================================================================
83  SUBROUTINE sget34( RMAX, LMAX, NINFO, KNT )
84 *
85 * -- LAPACK test routine (version 3.7.0) --
86 * -- LAPACK is a software package provided by Univ. of Tennessee, --
87 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
88 * December 2016
89 *
90 * .. Scalar Arguments ..
91  INTEGER KNT, LMAX
92  REAL RMAX
93 * ..
94 * .. Array Arguments ..
95  INTEGER NINFO( 2 )
96 * ..
97 *
98 * =====================================================================
99 *
100 * .. Parameters ..
101  REAL ZERO, HALF, ONE
102  parameter( zero = 0.0e0, half = 0.5e0, one = 1.0e0 )
103  REAL TWO, THREE
104  parameter( two = 2.0e0, three = 3.0e0 )
105  INTEGER LWORK
106  parameter( lwork = 32 )
107 * ..
108 * .. Local Scalars ..
109  INTEGER I, IA, IA11, IA12, IA21, IA22, IAM, IB, IC,
110  $ ic11, ic12, ic21, ic22, icm, info, j
111  REAL BIGNUM, EPS, RES, SMLNUM, TNRM
112 * ..
113 * .. Local Arrays ..
114  REAL Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ),
115  $ val( 9 ), vm( 2 ), work( lwork )
116 * ..
117 * .. External Functions ..
118  REAL SLAMCH
119  EXTERNAL slamch
120 * ..
121 * .. External Subroutines ..
122  EXTERNAL scopy, slaexc
123 * ..
124 * .. Intrinsic Functions ..
125  INTRINSIC abs, max, REAL, SIGN, SQRT
126 * ..
127 * .. Executable Statements ..
128 *
129 * Get machine parameters
130 *
131  eps = slamch( 'P' )
132  smlnum = slamch( 'S' ) / eps
133  bignum = one / smlnum
134  CALL slabad( smlnum, bignum )
135 *
136 * Set up test case parameters
137 *
138  val( 1 ) = zero
139  val( 2 ) = sqrt( smlnum )
140  val( 3 ) = one
141  val( 4 ) = two
142  val( 5 ) = sqrt( bignum )
143  val( 6 ) = -sqrt( smlnum )
144  val( 7 ) = -one
145  val( 8 ) = -two
146  val( 9 ) = -sqrt( bignum )
147  vm( 1 ) = one
148  vm( 2 ) = one + two*eps
149  CALL scopy( 16, val( 4 ), 0, t( 1, 1 ), 1 )
150 *
151  ninfo( 1 ) = 0
152  ninfo( 2 ) = 0
153  knt = 0
154  lmax = 0
155  rmax = zero
156 *
157 * Begin test loop
158 *
159  DO 40 ia = 1, 9
160  DO 30 iam = 1, 2
161  DO 20 ib = 1, 9
162  DO 10 ic = 1, 9
163  t( 1, 1 ) = val( ia )*vm( iam )
164  t( 2, 2 ) = val( ic )
165  t( 1, 2 ) = val( ib )
166  t( 2, 1 ) = zero
167  tnrm = max( abs( t( 1, 1 ) ), abs( t( 2, 2 ) ),
168  $ abs( t( 1, 2 ) ) )
169  CALL scopy( 16, t, 1, t1, 1 )
170  CALL scopy( 16, val( 1 ), 0, q, 1 )
171  CALL scopy( 4, val( 3 ), 0, q, 5 )
172  CALL slaexc( .true., 2, t, 4, q, 4, 1, 1, 1, work,
173  $ info )
174  IF( info.NE.0 )
175  $ ninfo( info ) = ninfo( info ) + 1
176  CALL shst01( 2, 1, 2, t1, 4, t, 4, q, 4, work, lwork,
177  $ result )
178  res = result( 1 ) + result( 2 )
179  IF( info.NE.0 )
180  $ res = res + one / eps
181  IF( t( 1, 1 ).NE.t1( 2, 2 ) )
182  $ res = res + one / eps
183  IF( t( 2, 2 ).NE.t1( 1, 1 ) )
184  $ res = res + one / eps
185  IF( t( 2, 1 ).NE.zero )
186  $ res = res + one / eps
187  knt = knt + 1
188  IF( res.GT.rmax ) THEN
189  lmax = knt
190  rmax = res
191  END IF
192  10 CONTINUE
193  20 CONTINUE
194  30 CONTINUE
195  40 CONTINUE
196 *
197  DO 110 ia = 1, 5
198  DO 100 iam = 1, 2
199  DO 90 ib = 1, 5
200  DO 80 ic11 = 1, 5
201  DO 70 ic12 = 2, 5
202  DO 60 ic21 = 2, 4
203  DO 50 ic22 = -1, 1, 2
204  t( 1, 1 ) = val( ia )*vm( iam )
205  t( 1, 2 ) = val( ib )
206  t( 1, 3 ) = -two*val( ib )
207  t( 2, 1 ) = zero
208  t( 2, 2 ) = val( ic11 )
209  t( 2, 3 ) = val( ic12 )
210  t( 3, 1 ) = zero
211  t( 3, 2 ) = -val( ic21 )
212  t( 3, 3 ) = val( ic11 )*REAL( ic22 )
213  tnrm = max( abs( t( 1, 1 ) ),
214  $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
215  $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
216  $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
217  CALL scopy( 16, t, 1, t1, 1 )
218  CALL scopy( 16, val( 1 ), 0, q, 1 )
219  CALL scopy( 4, val( 3 ), 0, q, 5 )
220  CALL slaexc( .true., 3, t, 4, q, 4, 1, 1, 2,
221  $ work, info )
222  IF( info.NE.0 )
223  $ ninfo( info ) = ninfo( info ) + 1
224  CALL shst01( 3, 1, 3, t1, 4, t, 4, q, 4,
225  $ work, lwork, result )
226  res = result( 1 ) + result( 2 )
227  IF( info.EQ.0 ) THEN
228  IF( t1( 1, 1 ).NE.t( 3, 3 ) )
229  $ res = res + one / eps
230  IF( t( 3, 1 ).NE.zero )
231  $ res = res + one / eps
232  IF( t( 3, 2 ).NE.zero )
233  $ res = res + one / eps
234  IF( t( 2, 1 ).NE.0 .AND.
235  $ ( t( 1, 1 ).NE.t( 2,
236  $ 2 ) .OR. sign( one, t( 1,
237  $ 2 ) ).EQ.sign( one, t( 2, 1 ) ) ) )
238  $ res = res + one / eps
239  END IF
240  knt = knt + 1
241  IF( res.GT.rmax ) THEN
242  lmax = knt
243  rmax = res
244  END IF
245  50 CONTINUE
246  60 CONTINUE
247  70 CONTINUE
248  80 CONTINUE
249  90 CONTINUE
250  100 CONTINUE
251  110 CONTINUE
252 *
253  DO 180 ia11 = 1, 5
254  DO 170 ia12 = 2, 5
255  DO 160 ia21 = 2, 4
256  DO 150 ia22 = -1, 1, 2
257  DO 140 icm = 1, 2
258  DO 130 ib = 1, 5
259  DO 120 ic = 1, 5
260  t( 1, 1 ) = val( ia11 )
261  t( 1, 2 ) = val( ia12 )
262  t( 1, 3 ) = -two*val( ib )
263  t( 2, 1 ) = -val( ia21 )
264  t( 2, 2 ) = val( ia11 )*REAL( ia22 )
265  t( 2, 3 ) = val( ib )
266  t( 3, 1 ) = zero
267  t( 3, 2 ) = zero
268  t( 3, 3 ) = val( ic )*vm( icm )
269  tnrm = max( abs( t( 1, 1 ) ),
270  $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
271  $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
272  $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
273  CALL scopy( 16, t, 1, t1, 1 )
274  CALL scopy( 16, val( 1 ), 0, q, 1 )
275  CALL scopy( 4, val( 3 ), 0, q, 5 )
276  CALL slaexc( .true., 3, t, 4, q, 4, 1, 2, 1,
277  $ work, info )
278  IF( info.NE.0 )
279  $ ninfo( info ) = ninfo( info ) + 1
280  CALL shst01( 3, 1, 3, t1, 4, t, 4, q, 4,
281  $ work, lwork, result )
282  res = result( 1 ) + result( 2 )
283  IF( info.EQ.0 ) THEN
284  IF( t1( 3, 3 ).NE.t( 1, 1 ) )
285  $ res = res + one / eps
286  IF( t( 2, 1 ).NE.zero )
287  $ res = res + one / eps
288  IF( t( 3, 1 ).NE.zero )
289  $ res = res + one / eps
290  IF( t( 3, 2 ).NE.0 .AND.
291  $ ( t( 2, 2 ).NE.t( 3,
292  $ 3 ) .OR. sign( one, t( 2,
293  $ 3 ) ).EQ.sign( one, t( 3, 2 ) ) ) )
294  $ res = res + one / eps
295  END IF
296  knt = knt + 1
297  IF( res.GT.rmax ) THEN
298  lmax = knt
299  rmax = res
300  END IF
301  120 CONTINUE
302  130 CONTINUE
303  140 CONTINUE
304  150 CONTINUE
305  160 CONTINUE
306  170 CONTINUE
307  180 CONTINUE
308 *
309  DO 300 ia11 = 1, 5
310  DO 290 ia12 = 2, 5
311  DO 280 ia21 = 2, 4
312  DO 270 ia22 = -1, 1, 2
313  DO 260 ib = 1, 5
314  DO 250 ic11 = 3, 4
315  DO 240 ic12 = 3, 4
316  DO 230 ic21 = 3, 4
317  DO 220 ic22 = -1, 1, 2
318  DO 210 icm = 5, 7
319  iam = 1
320  t( 1, 1 ) = val( ia11 )*vm( iam )
321  t( 1, 2 ) = val( ia12 )*vm( iam )
322  t( 1, 3 ) = -two*val( ib )
323  t( 1, 4 ) = half*val( ib )
324  t( 2, 1 ) = -t( 1, 2 )*val( ia21 )
325  t( 2, 2 ) = val( ia11 )*
326  $ REAL( ia22 )*VM( iam )
327  t( 2, 3 ) = val( ib )
328  t( 2, 4 ) = three*val( ib )
329  t( 3, 1 ) = zero
330  t( 3, 2 ) = zero
331  t( 3, 3 ) = val( ic11 )*
332  $ abs( val( icm ) )
333  t( 3, 4 ) = val( ic12 )*
334  $ abs( val( icm ) )
335  t( 4, 1 ) = zero
336  t( 4, 2 ) = zero
337  t( 4, 3 ) = -t( 3, 4 )*val( ic21 )*
338  $ abs( val( icm ) )
339  t( 4, 4 ) = val( ic11 )*
340  $ REAL( ic22 )*
341  $ abs( val( icm ) )
342  tnrm = zero
343  DO 200 i = 1, 4
344  DO 190 j = 1, 4
345  tnrm = max( tnrm,
346  $ abs( t( i, j ) ) )
347  190 CONTINUE
348  200 CONTINUE
349  CALL scopy( 16, t, 1, t1, 1 )
350  CALL scopy( 16, val( 1 ), 0, q, 1 )
351  CALL scopy( 4, val( 3 ), 0, q, 5 )
352  CALL slaexc( .true., 4, t, 4, q, 4,
353  $ 1, 2, 2, work, info )
354  IF( info.NE.0 )
355  $ ninfo( info ) = ninfo( info ) + 1
356  CALL shst01( 4, 1, 4, t1, 4, t, 4,
357  $ q, 4, work, lwork,
358  $ result )
359  res = result( 1 ) + result( 2 )
360  IF( info.EQ.0 ) THEN
361  IF( t( 3, 1 ).NE.zero )
362  $ res = res + one / eps
363  IF( t( 4, 1 ).NE.zero )
364  $ res = res + one / eps
365  IF( t( 3, 2 ).NE.zero )
366  $ res = res + one / eps
367  IF( t( 4, 2 ).NE.zero )
368  $ res = res + one / eps
369  IF( t( 2, 1 ).NE.0 .AND.
370  $ ( t( 1, 1 ).NE.t( 2,
371  $ 2 ) .OR. sign( one, t( 1,
372  $ 2 ) ).EQ.sign( one, t( 2,
373  $ 1 ) ) ) )res = res +
374  $ one / eps
375  IF( t( 4, 3 ).NE.0 .AND.
376  $ ( t( 3, 3 ).NE.t( 4,
377  $ 4 ) .OR. sign( one, t( 3,
378  $ 4 ) ).EQ.sign( one, t( 4,
379  $ 3 ) ) ) )res = res +
380  $ one / eps
381  END IF
382  knt = knt + 1
383  IF( res.GT.rmax ) THEN
384  lmax = knt
385  rmax = res
386  END IF
387  210 CONTINUE
388  220 CONTINUE
389  230 CONTINUE
390  240 CONTINUE
391  250 CONTINUE
392  260 CONTINUE
393  270 CONTINUE
394  280 CONTINUE
395  290 CONTINUE
396  300 CONTINUE
397 *
398  RETURN
399 *
400 * End of SGET34
401 *
402  END
shst01
subroutine shst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
SHST01
Definition: shst01.f:136
slaexc
subroutine slaexc(WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO)
SLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form...
Definition: slaexc.f:140
slabad
subroutine slabad(SMALL, LARGE)
SLABAD
Definition: slabad.f:76
sget34
subroutine sget34(RMAX, LMAX, NINFO, KNT)
SGET34
Definition: sget34.f:84
scopy
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:84