LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
dget34.f
Go to the documentation of this file.
1*> \brief \b DGET34
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 DGET34( RMAX, LMAX, NINFO, KNT )
12*
13* .. Scalar Arguments ..
14* INTEGER KNT, LMAX
15* DOUBLE PRECISION RMAX
16* ..
17* .. Array Arguments ..
18* INTEGER NINFO( 2 )
19* ..
20*
21*
22*> \par Purpose:
23* =============
24*>
25*> \verbatim
26*>
27*> DGET34 tests DLAEXC, 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, DLAEXC 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 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 DOUBLE PRECISION
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*> \ingroup double_eig
79*
80* =====================================================================
81 SUBROUTINE dget34( RMAX, LMAX, NINFO, KNT )
82*
83* -- LAPACK test routine --
84* -- LAPACK is a software package provided by Univ. of Tennessee, --
85* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
86*
87* .. Scalar Arguments ..
88 INTEGER KNT, LMAX
89 DOUBLE PRECISION RMAX
90* ..
91* .. Array Arguments ..
92 INTEGER NINFO( 2 )
93* ..
94*
95* =====================================================================
96*
97* .. Parameters ..
98 DOUBLE PRECISION ZERO, HALF, ONE
99 parameter( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
100 DOUBLE PRECISION TWO, THREE
101 parameter( two = 2.0d0, three = 3.0d0 )
102 INTEGER LWORK
103 parameter( lwork = 32 )
104* ..
105* .. Local Scalars ..
106 INTEGER I, IA, IA11, IA12, IA21, IA22, IAM, IB, IC,
107 $ IC11, IC12, IC21, IC22, ICM, INFO, J
108 DOUBLE PRECISION BIGNUM, EPS, RES, SMLNUM, TNRM
109* ..
110* .. Local Arrays ..
111 DOUBLE PRECISION Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ),
112 $ VAL( 9 ), VM( 2 ), WORK( LWORK )
113* ..
114* .. External Functions ..
115 DOUBLE PRECISION DLAMCH
116 EXTERNAL dlamch
117* ..
118* .. External Subroutines ..
119 EXTERNAL dcopy, dhst01, dlaexc
120* ..
121* .. Intrinsic Functions ..
122 INTRINSIC abs, dble, max, sign, sqrt
123* ..
124* .. Executable Statements ..
125*
126* Get machine parameters
127*
128 eps = dlamch( 'P' )
129 smlnum = dlamch( 'S' ) / eps
130 bignum = one / smlnum
131*
132* Set up test case parameters
133*
134 val( 1 ) = zero
135 val( 2 ) = sqrt( smlnum )
136 val( 3 ) = one
137 val( 4 ) = two
138 val( 5 ) = sqrt( bignum )
139 val( 6 ) = -sqrt( smlnum )
140 val( 7 ) = -one
141 val( 8 ) = -two
142 val( 9 ) = -sqrt( bignum )
143 vm( 1 ) = one
144 vm( 2 ) = one + two*eps
145 CALL dcopy( 16, val( 4 ), 0, t( 1, 1 ), 1 )
146*
147 ninfo( 1 ) = 0
148 ninfo( 2 ) = 0
149 knt = 0
150 lmax = 0
151 rmax = zero
152*
153* Begin test loop
154*
155 DO 40 ia = 1, 9
156 DO 30 iam = 1, 2
157 DO 20 ib = 1, 9
158 DO 10 ic = 1, 9
159 t( 1, 1 ) = val( ia )*vm( iam )
160 t( 2, 2 ) = val( ic )
161 t( 1, 2 ) = val( ib )
162 t( 2, 1 ) = zero
163 tnrm = max( abs( t( 1, 1 ) ), abs( t( 2, 2 ) ),
164 $ abs( t( 1, 2 ) ) )
165 CALL dcopy( 16, t, 1, t1, 1 )
166 CALL dcopy( 16, val( 1 ), 0, q, 1 )
167 CALL dcopy( 4, val( 3 ), 0, q, 5 )
168 CALL dlaexc( .true., 2, t, 4, q, 4, 1, 1, 1, work,
169 $ info )
170 IF( info.NE.0 )
171 $ ninfo( info ) = ninfo( info ) + 1
172 CALL dhst01( 2, 1, 2, t1, 4, t, 4, q, 4, work, lwork,
173 $ result )
174 res = result( 1 ) + result( 2 )
175 IF( info.NE.0 )
176 $ res = res + one / eps
177 IF( t( 1, 1 ).NE.t1( 2, 2 ) )
178 $ res = res + one / eps
179 IF( t( 2, 2 ).NE.t1( 1, 1 ) )
180 $ res = res + one / eps
181 IF( t( 2, 1 ).NE.zero )
182 $ res = res + one / eps
183 knt = knt + 1
184 IF( res.GT.rmax ) THEN
185 lmax = knt
186 rmax = res
187 END IF
188 10 CONTINUE
189 20 CONTINUE
190 30 CONTINUE
191 40 CONTINUE
192*
193 DO 110 ia = 1, 5
194 DO 100 iam = 1, 2
195 DO 90 ib = 1, 5
196 DO 80 ic11 = 1, 5
197 DO 70 ic12 = 2, 5
198 DO 60 ic21 = 2, 4
199 DO 50 ic22 = -1, 1, 2
200 t( 1, 1 ) = val( ia )*vm( iam )
201 t( 1, 2 ) = val( ib )
202 t( 1, 3 ) = -two*val( ib )
203 t( 2, 1 ) = zero
204 t( 2, 2 ) = val( ic11 )
205 t( 2, 3 ) = val( ic12 )
206 t( 3, 1 ) = zero
207 t( 3, 2 ) = -val( ic21 )
208 t( 3, 3 ) = val( ic11 )*dble( ic22 )
209 tnrm = max( abs( t( 1, 1 ) ),
210 $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
211 $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
212 $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
213 CALL dcopy( 16, t, 1, t1, 1 )
214 CALL dcopy( 16, val( 1 ), 0, q, 1 )
215 CALL dcopy( 4, val( 3 ), 0, q, 5 )
216 CALL dlaexc( .true., 3, t, 4, q, 4, 1, 1, 2,
217 $ work, info )
218 IF( info.NE.0 )
219 $ ninfo( info ) = ninfo( info ) + 1
220 CALL dhst01( 3, 1, 3, t1, 4, t, 4, q, 4,
221 $ work, lwork, result )
222 res = result( 1 ) + result( 2 )
223 IF( info.EQ.0 ) THEN
224 IF( t1( 1, 1 ).NE.t( 3, 3 ) )
225 $ res = res + one / eps
226 IF( t( 3, 1 ).NE.zero )
227 $ res = res + one / eps
228 IF( t( 3, 2 ).NE.zero )
229 $ res = res + one / eps
230 IF( t( 2, 1 ).NE.0 .AND.
231 $ ( t( 1, 1 ).NE.t( 2,
232 $ 2 ) .OR. sign( one, t( 1,
233 $ 2 ) ).EQ.sign( one, t( 2, 1 ) ) ) )
234 $ res = res + one / eps
235 END IF
236 knt = knt + 1
237 IF( res.GT.rmax ) THEN
238 lmax = knt
239 rmax = res
240 END IF
241 50 CONTINUE
242 60 CONTINUE
243 70 CONTINUE
244 80 CONTINUE
245 90 CONTINUE
246 100 CONTINUE
247 110 CONTINUE
248*
249 DO 180 ia11 = 1, 5
250 DO 170 ia12 = 2, 5
251 DO 160 ia21 = 2, 4
252 DO 150 ia22 = -1, 1, 2
253 DO 140 icm = 1, 2
254 DO 130 ib = 1, 5
255 DO 120 ic = 1, 5
256 t( 1, 1 ) = val( ia11 )
257 t( 1, 2 ) = val( ia12 )
258 t( 1, 3 ) = -two*val( ib )
259 t( 2, 1 ) = -val( ia21 )
260 t( 2, 2 ) = val( ia11 )*dble( ia22 )
261 t( 2, 3 ) = val( ib )
262 t( 3, 1 ) = zero
263 t( 3, 2 ) = zero
264 t( 3, 3 ) = val( ic )*vm( icm )
265 tnrm = max( abs( t( 1, 1 ) ),
266 $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
267 $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
268 $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
269 CALL dcopy( 16, t, 1, t1, 1 )
270 CALL dcopy( 16, val( 1 ), 0, q, 1 )
271 CALL dcopy( 4, val( 3 ), 0, q, 5 )
272 CALL dlaexc( .true., 3, t, 4, q, 4, 1, 2, 1,
273 $ work, info )
274 IF( info.NE.0 )
275 $ ninfo( info ) = ninfo( info ) + 1
276 CALL dhst01( 3, 1, 3, t1, 4, t, 4, q, 4,
277 $ work, lwork, result )
278 res = result( 1 ) + result( 2 )
279 IF( info.EQ.0 ) THEN
280 IF( t1( 3, 3 ).NE.t( 1, 1 ) )
281 $ res = res + one / eps
282 IF( t( 2, 1 ).NE.zero )
283 $ res = res + one / eps
284 IF( t( 3, 1 ).NE.zero )
285 $ res = res + one / eps
286 IF( t( 3, 2 ).NE.0 .AND.
287 $ ( t( 2, 2 ).NE.t( 3,
288 $ 3 ) .OR. sign( one, t( 2,
289 $ 3 ) ).EQ.sign( one, t( 3, 2 ) ) ) )
290 $ res = res + one / eps
291 END IF
292 knt = knt + 1
293 IF( res.GT.rmax ) THEN
294 lmax = knt
295 rmax = res
296 END IF
297 120 CONTINUE
298 130 CONTINUE
299 140 CONTINUE
300 150 CONTINUE
301 160 CONTINUE
302 170 CONTINUE
303 180 CONTINUE
304*
305 DO 300 ia11 = 1, 5
306 DO 290 ia12 = 2, 5
307 DO 280 ia21 = 2, 4
308 DO 270 ia22 = -1, 1, 2
309 DO 260 ib = 1, 5
310 DO 250 ic11 = 3, 4
311 DO 240 ic12 = 3, 4
312 DO 230 ic21 = 3, 4
313 DO 220 ic22 = -1, 1, 2
314 DO 210 icm = 5, 7
315 iam = 1
316 t( 1, 1 ) = val( ia11 )*vm( iam )
317 t( 1, 2 ) = val( ia12 )*vm( iam )
318 t( 1, 3 ) = -two*val( ib )
319 t( 1, 4 ) = half*val( ib )
320 t( 2, 1 ) = -t( 1, 2 )*val( ia21 )
321 t( 2, 2 ) = val( ia11 )*
322 $ dble( ia22 )*vm( iam )
323 t( 2, 3 ) = val( ib )
324 t( 2, 4 ) = three*val( ib )
325 t( 3, 1 ) = zero
326 t( 3, 2 ) = zero
327 t( 3, 3 ) = val( ic11 )*
328 $ abs( val( icm ) )
329 t( 3, 4 ) = val( ic12 )*
330 $ abs( val( icm ) )
331 t( 4, 1 ) = zero
332 t( 4, 2 ) = zero
333 t( 4, 3 ) = -t( 3, 4 )*val( ic21 )*
334 $ abs( val( icm ) )
335 t( 4, 4 ) = val( ic11 )*
336 $ dble( ic22 )*
337 $ abs( val( icm ) )
338 tnrm = zero
339 DO 200 i = 1, 4
340 DO 190 j = 1, 4
341 tnrm = max( tnrm,
342 $ abs( t( i, j ) ) )
343 190 CONTINUE
344 200 CONTINUE
345 CALL dcopy( 16, t, 1, t1, 1 )
346 CALL dcopy( 16, val( 1 ), 0, q, 1 )
347 CALL dcopy( 4, val( 3 ), 0, q, 5 )
348 CALL dlaexc( .true., 4, t, 4, q, 4,
349 $ 1, 2, 2, work, info )
350 IF( info.NE.0 )
351 $ ninfo( info ) = ninfo( info ) + 1
352 CALL dhst01( 4, 1, 4, t1, 4, t, 4,
353 $ q, 4, work, lwork,
354 $ result )
355 res = result( 1 ) + result( 2 )
356 IF( info.EQ.0 ) THEN
357 IF( t( 3, 1 ).NE.zero )
358 $ res = res + one / eps
359 IF( t( 4, 1 ).NE.zero )
360 $ res = res + one / eps
361 IF( t( 3, 2 ).NE.zero )
362 $ res = res + one / eps
363 IF( t( 4, 2 ).NE.zero )
364 $ res = res + one / eps
365 IF( t( 2, 1 ).NE.0 .AND.
366 $ ( t( 1, 1 ).NE.t( 2,
367 $ 2 ) .OR. sign( one, t( 1,
368 $ 2 ) ).EQ.sign( one, t( 2,
369 $ 1 ) ) ) )res = res +
370 $ one / eps
371 IF( t( 4, 3 ).NE.0 .AND.
372 $ ( t( 3, 3 ).NE.t( 4,
373 $ 4 ) .OR. sign( one, t( 3,
374 $ 4 ) ).EQ.sign( one, t( 4,
375 $ 3 ) ) ) )res = res +
376 $ one / eps
377 END IF
378 knt = knt + 1
379 IF( res.GT.rmax ) THEN
380 lmax = knt
381 rmax = res
382 END IF
383 210 CONTINUE
384 220 CONTINUE
385 230 CONTINUE
386 240 CONTINUE
387 250 CONTINUE
388 260 CONTINUE
389 270 CONTINUE
390 280 CONTINUE
391 290 CONTINUE
392 300 CONTINUE
393*
394 RETURN
395*
396* End of DGET34
397*
398 END
dget34
subroutine dget34(rmax, lmax, ninfo, knt)
DGET34
Definition dget34.f:82
dhst01
subroutine dhst01(n, ilo, ihi, a, lda, h, ldh, q, ldq, work, lwork, result)
DHST01
Definition dhst01.f:134
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82
dlaexc
subroutine dlaexc(wantq, n, t, ldt, q, ldq, j1, n1, n2, work, info)
DLAEXC swaps adjacent diagonal blocks of a real upper quasi-triangular matrix in Schur canonical form...
Definition dlaexc.f:138