LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ 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, dlabad, 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  CALL dlabad( smlnum, bignum )
132 *
133 * Set up test case parameters
134 *
135  val( 1 ) = zero
136  val( 2 ) = sqrt( smlnum )
137  val( 3 ) = one
138  val( 4 ) = two
139  val( 5 ) = sqrt( bignum )
140  val( 6 ) = -sqrt( smlnum )
141  val( 7 ) = -one
142  val( 8 ) = -two
143  val( 9 ) = -sqrt( bignum )
144  vm( 1 ) = one
145  vm( 2 ) = one + two*eps
146  CALL dcopy( 16, val( 4 ), 0, t( 1, 1 ), 1 )
147 *
148  ninfo( 1 ) = 0
149  ninfo( 2 ) = 0
150  knt = 0
151  lmax = 0
152  rmax = zero
153 *
154 * Begin test loop
155 *
156  DO 40 ia = 1, 9
157  DO 30 iam = 1, 2
158  DO 20 ib = 1, 9
159  DO 10 ic = 1, 9
160  t( 1, 1 ) = val( ia )*vm( iam )
161  t( 2, 2 ) = val( ic )
162  t( 1, 2 ) = val( ib )
163  t( 2, 1 ) = zero
164  tnrm = max( abs( t( 1, 1 ) ), abs( t( 2, 2 ) ),
165  $ abs( t( 1, 2 ) ) )
166  CALL dcopy( 16, t, 1, t1, 1 )
167  CALL dcopy( 16, val( 1 ), 0, q, 1 )
168  CALL dcopy( 4, val( 3 ), 0, q, 5 )
169  CALL dlaexc( .true., 2, t, 4, q, 4, 1, 1, 1, work,
170  $ info )
171  IF( info.NE.0 )
172  $ ninfo( info ) = ninfo( info ) + 1
173  CALL dhst01( 2, 1, 2, t1, 4, t, 4, q, 4, work, lwork,
174  $ result )
175  res = result( 1 ) + result( 2 )
176  IF( info.NE.0 )
177  $ res = res + one / eps
178  IF( t( 1, 1 ).NE.t1( 2, 2 ) )
179  $ res = res + one / eps
180  IF( t( 2, 2 ).NE.t1( 1, 1 ) )
181  $ res = res + one / eps
182  IF( t( 2, 1 ).NE.zero )
183  $ res = res + one / eps
184  knt = knt + 1
185  IF( res.GT.rmax ) THEN
186  lmax = knt
187  rmax = res
188  END IF
189  10 CONTINUE
190  20 CONTINUE
191  30 CONTINUE
192  40 CONTINUE
193 *
194  DO 110 ia = 1, 5
195  DO 100 iam = 1, 2
196  DO 90 ib = 1, 5
197  DO 80 ic11 = 1, 5
198  DO 70 ic12 = 2, 5
199  DO 60 ic21 = 2, 4
200  DO 50 ic22 = -1, 1, 2
201  t( 1, 1 ) = val( ia )*vm( iam )
202  t( 1, 2 ) = val( ib )
203  t( 1, 3 ) = -two*val( ib )
204  t( 2, 1 ) = zero
205  t( 2, 2 ) = val( ic11 )
206  t( 2, 3 ) = val( ic12 )
207  t( 3, 1 ) = zero
208  t( 3, 2 ) = -val( ic21 )
209  t( 3, 3 ) = val( ic11 )*dble( ic22 )
210  tnrm = max( abs( t( 1, 1 ) ),
211  $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
212  $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
213  $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
214  CALL dcopy( 16, t, 1, t1, 1 )
215  CALL dcopy( 16, val( 1 ), 0, q, 1 )
216  CALL dcopy( 4, val( 3 ), 0, q, 5 )
217  CALL dlaexc( .true., 3, t, 4, q, 4, 1, 1, 2,
218  $ work, info )
219  IF( info.NE.0 )
220  $ ninfo( info ) = ninfo( info ) + 1
221  CALL dhst01( 3, 1, 3, t1, 4, t, 4, q, 4,
222  $ work, lwork, result )
223  res = result( 1 ) + result( 2 )
224  IF( info.EQ.0 ) THEN
225  IF( t1( 1, 1 ).NE.t( 3, 3 ) )
226  $ res = res + one / eps
227  IF( t( 3, 1 ).NE.zero )
228  $ res = res + one / eps
229  IF( t( 3, 2 ).NE.zero )
230  $ res = res + one / eps
231  IF( t( 2, 1 ).NE.0 .AND.
232  $ ( t( 1, 1 ).NE.t( 2,
233  $ 2 ) .OR. sign( one, t( 1,
234  $ 2 ) ).EQ.sign( one, t( 2, 1 ) ) ) )
235  $ res = res + one / eps
236  END IF
237  knt = knt + 1
238  IF( res.GT.rmax ) THEN
239  lmax = knt
240  rmax = res
241  END IF
242  50 CONTINUE
243  60 CONTINUE
244  70 CONTINUE
245  80 CONTINUE
246  90 CONTINUE
247  100 CONTINUE
248  110 CONTINUE
249 *
250  DO 180 ia11 = 1, 5
251  DO 170 ia12 = 2, 5
252  DO 160 ia21 = 2, 4
253  DO 150 ia22 = -1, 1, 2
254  DO 140 icm = 1, 2
255  DO 130 ib = 1, 5
256  DO 120 ic = 1, 5
257  t( 1, 1 ) = val( ia11 )
258  t( 1, 2 ) = val( ia12 )
259  t( 1, 3 ) = -two*val( ib )
260  t( 2, 1 ) = -val( ia21 )
261  t( 2, 2 ) = val( ia11 )*dble( ia22 )
262  t( 2, 3 ) = val( ib )
263  t( 3, 1 ) = zero
264  t( 3, 2 ) = zero
265  t( 3, 3 ) = val( ic )*vm( icm )
266  tnrm = max( abs( t( 1, 1 ) ),
267  $ abs( t( 1, 2 ) ), abs( t( 1, 3 ) ),
268  $ abs( t( 2, 2 ) ), abs( t( 2, 3 ) ),
269  $ abs( t( 3, 2 ) ), abs( t( 3, 3 ) ) )
270  CALL dcopy( 16, t, 1, t1, 1 )
271  CALL dcopy( 16, val( 1 ), 0, q, 1 )
272  CALL dcopy( 4, val( 3 ), 0, q, 5 )
273  CALL dlaexc( .true., 3, t, 4, q, 4, 1, 2, 1,
274  $ work, info )
275  IF( info.NE.0 )
276  $ ninfo( info ) = ninfo( info ) + 1
277  CALL dhst01( 3, 1, 3, t1, 4, t, 4, q, 4,
278  $ work, lwork, result )
279  res = result( 1 ) + result( 2 )
280  IF( info.EQ.0 ) THEN
281  IF( t1( 3, 3 ).NE.t( 1, 1 ) )
282  $ res = res + one / eps
283  IF( t( 2, 1 ).NE.zero )
284  $ res = res + one / eps
285  IF( t( 3, 1 ).NE.zero )
286  $ res = res + one / eps
287  IF( t( 3, 2 ).NE.0 .AND.
288  $ ( t( 2, 2 ).NE.t( 3,
289  $ 3 ) .OR. sign( one, t( 2,
290  $ 3 ) ).EQ.sign( one, t( 3, 2 ) ) ) )
291  $ res = res + one / eps
292  END IF
293  knt = knt + 1
294  IF( res.GT.rmax ) THEN
295  lmax = knt
296  rmax = res
297  END IF
298  120 CONTINUE
299  130 CONTINUE
300  140 CONTINUE
301  150 CONTINUE
302  160 CONTINUE
303  170 CONTINUE
304  180 CONTINUE
305 *
306  DO 300 ia11 = 1, 5
307  DO 290 ia12 = 2, 5
308  DO 280 ia21 = 2, 4
309  DO 270 ia22 = -1, 1, 2
310  DO 260 ib = 1, 5
311  DO 250 ic11 = 3, 4
312  DO 240 ic12 = 3, 4
313  DO 230 ic21 = 3, 4
314  DO 220 ic22 = -1, 1, 2
315  DO 210 icm = 5, 7
316  iam = 1
317  t( 1, 1 ) = val( ia11 )*vm( iam )
318  t( 1, 2 ) = val( ia12 )*vm( iam )
319  t( 1, 3 ) = -two*val( ib )
320  t( 1, 4 ) = half*val( ib )
321  t( 2, 1 ) = -t( 1, 2 )*val( ia21 )
322  t( 2, 2 ) = val( ia11 )*
323  $ dble( ia22 )*vm( iam )
324  t( 2, 3 ) = val( ib )
325  t( 2, 4 ) = three*val( ib )
326  t( 3, 1 ) = zero
327  t( 3, 2 ) = zero
328  t( 3, 3 ) = val( ic11 )*
329  $ abs( val( icm ) )
330  t( 3, 4 ) = val( ic12 )*
331  $ abs( val( icm ) )
332  t( 4, 1 ) = zero
333  t( 4, 2 ) = zero
334  t( 4, 3 ) = -t( 3, 4 )*val( ic21 )*
335  $ abs( val( icm ) )
336  t( 4, 4 ) = val( ic11 )*
337  $ dble( ic22 )*
338  $ abs( val( icm ) )
339  tnrm = zero
340  DO 200 i = 1, 4
341  DO 190 j = 1, 4
342  tnrm = max( tnrm,
343  $ abs( t( i, j ) ) )
344  190 CONTINUE
345  200 CONTINUE
346  CALL dcopy( 16, t, 1, t1, 1 )
347  CALL dcopy( 16, val( 1 ), 0, q, 1 )
348  CALL dcopy( 4, val( 3 ), 0, q, 5 )
349  CALL dlaexc( .true., 4, t, 4, q, 4,
350  $ 1, 2, 2, work, info )
351  IF( info.NE.0 )
352  $ ninfo( info ) = ninfo( info ) + 1
353  CALL dhst01( 4, 1, 4, t1, 4, t, 4,
354  $ q, 4, work, lwork,
355  $ result )
356  res = result( 1 ) + result( 2 )
357  IF( info.EQ.0 ) THEN
358  IF( t( 3, 1 ).NE.zero )
359  $ res = res + one / eps
360  IF( t( 4, 1 ).NE.zero )
361  $ res = res + one / eps
362  IF( t( 3, 2 ).NE.zero )
363  $ res = res + one / eps
364  IF( t( 4, 2 ).NE.zero )
365  $ res = res + one / eps
366  IF( t( 2, 1 ).NE.0 .AND.
367  $ ( t( 1, 1 ).NE.t( 2,
368  $ 2 ) .OR. sign( one, t( 1,
369  $ 2 ) ).EQ.sign( one, t( 2,
370  $ 1 ) ) ) )res = res +
371  $ one / eps
372  IF( t( 4, 3 ).NE.0 .AND.
373  $ ( t( 3, 3 ).NE.t( 4,
374  $ 4 ) .OR. sign( one, t( 3,
375  $ 4 ) ).EQ.sign( one, t( 4,
376  $ 3 ) ) ) )res = res +
377  $ one / eps
378  END IF
379  knt = knt + 1
380  IF( res.GT.rmax ) THEN
381  lmax = knt
382  rmax = res
383  END IF
384  210 CONTINUE
385  220 CONTINUE
386  230 CONTINUE
387  240 CONTINUE
388  250 CONTINUE
389  260 CONTINUE
390  270 CONTINUE
391  280 CONTINUE
392  290 CONTINUE
393  300 CONTINUE
394 *
395  RETURN
396 *
397 * End of DGET34
398 *
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:69
subroutine dlabad(SMALL, LARGE)
DLABAD
Definition: dlabad.f:74
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
Definition: dcopy.f:82
subroutine dhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
DHST01
Definition: dhst01.f:134
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
Here is the call graph for this function:
Here is the caller graph for this function: