LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ dget34()

subroutine dget34 ( double precision  rmax,
integer  lmax,
integer, dimension( 2 )  ninfo,
integer  knt 
)

DGET34

Purpose:
 DGET34 tests DLAEXC, a routine for swapping adjacent blocks (either
 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form.
 Thus, DLAEXC computes an orthogonal matrix Q such that

     Q' * [ A B ] * Q  = [ C1 B1 ]
          [ 0 C ]        [ 0  A1 ]

 where C1 is similar to C and A1 is similar to A.  Both A and C are
 assumed to be in standard form (equal diagonal entries and
 offdiagonal with differing signs) and A1 and C1 are returned with the
 same properties.

 The test code verifies these last assertions, as well as that
 the residual in the above equation is small.
Parameters
[out]RMAX
          RMAX is DOUBLE PRECISION
          Value of the largest test ratio.
[out]LMAX
          LMAX is INTEGER
          Example number where largest test ratio achieved.
[out]NINFO
          NINFO is INTEGER array, dimension (2)
          NINFO(J) is the number of examples where INFO=J occurred.
[out]KNT
          KNT is INTEGER
          Total number of examples tested.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 81 of file dget34.f.

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*
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
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
Here is the call graph for this function:
Here is the caller graph for this function: