LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 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.
Date
November 2011

Definition at line 84 of file dget34.f.

84 *
85 * -- LAPACK test routine (version 3.4.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 * November 2011
89 *
90 * .. Scalar Arguments ..
91  INTEGER knt, lmax
92  DOUBLE PRECISION rmax
93 * ..
94 * .. Array Arguments ..
95  INTEGER ninfo( 2 )
96 * ..
97 *
98 * =====================================================================
99 *
100 * .. Parameters ..
101  DOUBLE PRECISION zero, half, one
102  parameter ( zero = 0.0d0, half = 0.5d0, one = 1.0d0 )
103  DOUBLE PRECISION two, three
104  parameter ( two = 2.0d0, three = 3.0d0 )
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  DOUBLE PRECISION bignum, eps, res, smlnum, tnrm
112 * ..
113 * .. Local Arrays ..
114  DOUBLE PRECISION q( 4, 4 ), result( 2 ), t( 4, 4 ), t1( 4, 4 ),
115  $ val( 9 ), vm( 2 ), work( lwork )
116 * ..
117 * .. External Functions ..
118  DOUBLE PRECISION dlamch
119  EXTERNAL dlamch
120 * ..
121 * .. External Subroutines ..
122  EXTERNAL dcopy, dhst01, dlabad, dlaexc
123 * ..
124 * .. Intrinsic Functions ..
125  INTRINSIC abs, dble, max, sign, sqrt
126 * ..
127 * .. Executable Statements ..
128 *
129 * Get machine parameters
130 *
131  eps = dlamch( 'P' )
132  smlnum = dlamch( 'S' ) / eps
133  bignum = one / smlnum
134  CALL dlabad( 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 dcopy( 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 dcopy( 16, t, 1, t1, 1 )
170  CALL dcopy( 16, val( 1 ), 0, q, 1 )
171  CALL dcopy( 4, val( 3 ), 0, q, 5 )
172  CALL dlaexc( .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 dhst01( 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 )*dble( 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 dcopy( 16, t, 1, t1, 1 )
218  CALL dcopy( 16, val( 1 ), 0, q, 1 )
219  CALL dcopy( 4, val( 3 ), 0, q, 5 )
220  CALL dlaexc( .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 dhst01( 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 )*dble( 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 dcopy( 16, t, 1, t1, 1 )
274  CALL dcopy( 16, val( 1 ), 0, q, 1 )
275  CALL dcopy( 4, val( 3 ), 0, q, 5 )
276  CALL dlaexc( .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 dhst01( 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  $ dble( 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  $ dble( 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 dcopy( 16, t, 1, t1, 1 )
350  CALL dcopy( 16, val( 1 ), 0, q, 1 )
351  CALL dcopy( 4, val( 3 ), 0, q, 5 )
352  CALL dlaexc( .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 dhst01( 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 DGET34
401 *
dcopy
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
Definition: dcopy.f:53
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
dhst01
subroutine dhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
DHST01
Definition: dhst01.f:136
dlabad
subroutine dlabad(SMALL, LARGE)
DLABAD
Definition: dlabad.f:76
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:140

Here is the call graph for this function:

Here is the caller graph for this function: