LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine zget37 ( double precision, dimension( 3 )  RMAX,
integer, dimension( 3 )  LMAX,
integer, dimension( 3 )  NINFO,
integer  KNT,
integer  NIN 
)

ZGET37

Purpose: 
 ZGET37 tests ZTRSNA, a routine for estimating condition numbers of
 eigenvalues and/or right eigenvectors of a matrix.

 The test matrices are read from a file with logical unit number NIN.
Parameters
[out]RMAX
          RMAX is DOUBLE PRECISION array, dimension (3)
          Value of the largest test ratio.
          RMAX(1) = largest ratio comparing different calls to ZTRSNA
          RMAX(2) = largest error in reciprocal condition
                    numbers taking their conditioning into account
          RMAX(3) = largest error in reciprocal condition
                    numbers not taking their conditioning into
                    account (may be larger than RMAX(2))
[out]LMAX
          LMAX is INTEGER array, dimension (3)
          LMAX(i) is example number where largest test ratio
          RMAX(i) is achieved. Also:
          If ZGEHRD returns INFO nonzero on example i, LMAX(1)=i
          If ZHSEQR returns INFO nonzero on example i, LMAX(2)=i
          If ZTRSNA returns INFO nonzero on example i, LMAX(3)=i
[out]NINFO
          NINFO is INTEGER array, dimension (3)
          NINFO(1) = No. of times ZGEHRD returned INFO nonzero
          NINFO(2) = No. of times ZHSEQR returned INFO nonzero
          NINFO(3) = No. of times ZTRSNA returned INFO nonzero
[out]KNT
          KNT is INTEGER
          Total number of examples tested.
[in]NIN
          NIN is INTEGER
          Input logical unit number
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2011

Definition at line 92 of file zget37.f.

92 *
93 * -- LAPACK test routine (version 3.4.0) --
94 * -- LAPACK is a software package provided by Univ. of Tennessee, --
95 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
96 * November 2011
97 *
98 * .. Scalar Arguments ..
99  INTEGER knt, nin
100 * ..
101 * .. Array Arguments ..
102  INTEGER lmax( 3 ), ninfo( 3 )
103  DOUBLE PRECISION rmax( 3 )
104 * ..
105 *
106 * =====================================================================
107 *
108 * .. Parameters ..
109  DOUBLE PRECISION zero, one, two
110  parameter ( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
111  DOUBLE PRECISION epsin
112  parameter ( epsin = 5.9605d-8 )
113  INTEGER ldt, lwork
114  parameter ( ldt = 20, lwork = 2*ldt*( 10+ldt ) )
115 * ..
116 * .. Local Scalars ..
117  INTEGER i, icmp, info, iscl, isrt, j, kmin, m, n
118  DOUBLE PRECISION bignum, eps, smlnum, tnrm, tol, tolin, v,
119  $ vcmin, vmax, vmin, vmul
120 * ..
121 * .. Local Arrays ..
122  LOGICAL select( ldt )
123  INTEGER lcmp( 3 )
124  DOUBLE PRECISION dum( 1 ), rwork( 2*ldt ), s( ldt ), sep( ldt ),
125  $ sepin( ldt ), septmp( ldt ), sin( ldt ),
126  $ stmp( ldt ), val( 3 ), wiin( ldt ),
127  $ wrin( ldt ), wsrt( ldt )
128  COMPLEX*16 cdum( 1 ), le( ldt, ldt ), re( ldt, ldt ),
129  $ t( ldt, ldt ), tmp( ldt, ldt ), w( ldt ),
130  $ work( lwork ), wtmp( ldt )
131 * ..
132 * .. External Functions ..
133  DOUBLE PRECISION dlamch, zlange
134  EXTERNAL dlamch, zlange
135 * ..
136 * .. External Subroutines ..
137  EXTERNAL dcopy, dlabad, dscal, zcopy, zdscal, zgehrd,
138  $ zhseqr, zlacpy, ztrevc, ztrsna
139 * ..
140 * .. Intrinsic Functions ..
141  INTRINSIC dble, dimag, max, sqrt
142 * ..
143 * .. Executable Statements ..
144 *
145  eps = dlamch( 'P' )
146  smlnum = dlamch( 'S' ) / eps
147  bignum = one / smlnum
148  CALL dlabad( smlnum, bignum )
149 *
150 * EPSIN = 2**(-24) = precision to which input data computed
151 *
152  eps = max( eps, epsin )
153  rmax( 1 ) = zero
154  rmax( 2 ) = zero
155  rmax( 3 ) = zero
156  lmax( 1 ) = 0
157  lmax( 2 ) = 0
158  lmax( 3 ) = 0
159  knt = 0
160  ninfo( 1 ) = 0
161  ninfo( 2 ) = 0
162  ninfo( 3 ) = 0
163  val( 1 ) = sqrt( smlnum )
164  val( 2 ) = one
165  val( 3 ) = sqrt( bignum )
166 *
167 * Read input data until N=0. Assume input eigenvalues are sorted
168 * lexicographically (increasing by real part if ISRT = 0,
169 * increasing by imaginary part if ISRT = 1)
170 *
171  10 CONTINUE
172  READ( nin, fmt = * )n, isrt
173  IF( n.EQ.0 )
174  $ RETURN
175  DO 20 i = 1, n
176  READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
177  20 CONTINUE
178  DO 30 i = 1, n
179  READ( nin, fmt = * )wrin( i ), wiin( i ), sin( i ), sepin( i )
180  30 CONTINUE
181  tnrm = zlange( 'M', n, n, tmp, ldt, rwork )
182  DO 260 iscl = 1, 3
183 *
184 * Scale input matrix
185 *
186  knt = knt + 1
187  CALL zlacpy( 'F', n, n, tmp, ldt, t, ldt )
188  vmul = val( iscl )
189  DO 40 i = 1, n
190  CALL zdscal( n, vmul, t( 1, i ), 1 )
191  40 CONTINUE
192  IF( tnrm.EQ.zero )
193  $ vmul = one
194 *
195 * Compute eigenvalues and eigenvectors
196 *
197  CALL zgehrd( n, 1, n, t, ldt, work( 1 ), work( n+1 ), lwork-n,
198  $ info )
199  IF( info.NE.0 ) THEN
200  lmax( 1 ) = knt
201  ninfo( 1 ) = ninfo( 1 ) + 1
202  GO TO 260
203  END IF
204  DO 60 j = 1, n - 2
205  DO 50 i = j + 2, n
206  t( i, j ) = zero
207  50 CONTINUE
208  60 CONTINUE
209 *
210 * Compute Schur form
211 *
212  CALL zhseqr( 'S', 'N', n, 1, n, t, ldt, w, cdum, 1, work,
213  $ lwork, info )
214  IF( info.NE.0 ) THEN
215  lmax( 2 ) = knt
216  ninfo( 2 ) = ninfo( 2 ) + 1
217  GO TO 260
218  END IF
219 *
220 * Compute eigenvectors
221 *
222  DO 70 i = 1, n
223  SELECT( i ) = .true.
224  70 CONTINUE
225  CALL ztrevc( 'B', 'A', SELECT, n, t, ldt, le, ldt, re, ldt, n,
226  $ m, work, rwork, info )
227 *
228 * Compute condition numbers
229 *
230  CALL ztrsna( 'B', 'A', SELECT, n, t, ldt, le, ldt, re, ldt, s,
231  $ sep, n, m, work, n, rwork, info )
232  IF( info.NE.0 ) THEN
233  lmax( 3 ) = knt
234  ninfo( 3 ) = ninfo( 3 ) + 1
235  GO TO 260
236  END IF
237 *
238 * Sort eigenvalues and condition numbers lexicographically
239 * to compare with inputs
240 *
241  CALL zcopy( n, w, 1, wtmp, 1 )
242  IF( isrt.EQ.0 ) THEN
243 *
244 * Sort by increasing real part
245 *
246  DO 80 i = 1, n
247  wsrt( i ) = dble( w( i ) )
248  80 CONTINUE
249  ELSE
250 *
251 * Sort by increasing imaginary part
252 *
253  DO 90 i = 1, n
254  wsrt( i ) = dimag( w( i ) )
255  90 CONTINUE
256  END IF
257  CALL dcopy( n, s, 1, stmp, 1 )
258  CALL dcopy( n, sep, 1, septmp, 1 )
259  CALL dscal( n, one / vmul, septmp, 1 )
260  DO 110 i = 1, n - 1
261  kmin = i
262  vmin = wsrt( i )
263  DO 100 j = i + 1, n
264  IF( wsrt( j ).LT.vmin ) THEN
265  kmin = j
266  vmin = wsrt( j )
267  END IF
268  100 CONTINUE
269  wsrt( kmin ) = wsrt( i )
270  wsrt( i ) = vmin
271  vcmin = wtmp( i )
272  wtmp( i ) = w( kmin )
273  wtmp( kmin ) = vcmin
274  vmin = stmp( kmin )
275  stmp( kmin ) = stmp( i )
276  stmp( i ) = vmin
277  vmin = septmp( kmin )
278  septmp( kmin ) = septmp( i )
279  septmp( i ) = vmin
280  110 CONTINUE
281 *
282 * Compare condition numbers for eigenvalues
283 * taking their condition numbers into account
284 *
285  v = max( two*dble( n )*eps*tnrm, smlnum )
286  IF( tnrm.EQ.zero )
287  $ v = one
288  DO 120 i = 1, n
289  IF( v.GT.septmp( i ) ) THEN
290  tol = one
291  ELSE
292  tol = v / septmp( i )
293  END IF
294  IF( v.GT.sepin( i ) ) THEN
295  tolin = one
296  ELSE
297  tolin = v / sepin( i )
298  END IF
299  tol = max( tol, smlnum / eps )
300  tolin = max( tolin, smlnum / eps )
301  IF( eps*( sin( i )-tolin ).GT.stmp( i )+tol ) THEN
302  vmax = one / eps
303  ELSE IF( sin( i )-tolin.GT.stmp( i )+tol ) THEN
304  vmax = ( sin( i )-tolin ) / ( stmp( i )+tol )
305  ELSE IF( sin( i )+tolin.LT.eps*( stmp( i )-tol ) ) THEN
306  vmax = one / eps
307  ELSE IF( sin( i )+tolin.LT.stmp( i )-tol ) THEN
308  vmax = ( stmp( i )-tol ) / ( sin( i )+tolin )
309  ELSE
310  vmax = one
311  END IF
312  IF( vmax.GT.rmax( 2 ) ) THEN
313  rmax( 2 ) = vmax
314  IF( ninfo( 2 ).EQ.0 )
315  $ lmax( 2 ) = knt
316  END IF
317  120 CONTINUE
318 *
319 * Compare condition numbers for eigenvectors
320 * taking their condition numbers into account
321 *
322  DO 130 i = 1, n
323  IF( v.GT.septmp( i )*stmp( i ) ) THEN
324  tol = septmp( i )
325  ELSE
326  tol = v / stmp( i )
327  END IF
328  IF( v.GT.sepin( i )*sin( i ) ) THEN
329  tolin = sepin( i )
330  ELSE
331  tolin = v / sin( i )
332  END IF
333  tol = max( tol, smlnum / eps )
334  tolin = max( tolin, smlnum / eps )
335  IF( eps*( sepin( i )-tolin ).GT.septmp( i )+tol ) THEN
336  vmax = one / eps
337  ELSE IF( sepin( i )-tolin.GT.septmp( i )+tol ) THEN
338  vmax = ( sepin( i )-tolin ) / ( septmp( i )+tol )
339  ELSE IF( sepin( i )+tolin.LT.eps*( septmp( i )-tol ) ) THEN
340  vmax = one / eps
341  ELSE IF( sepin( i )+tolin.LT.septmp( i )-tol ) THEN
342  vmax = ( septmp( i )-tol ) / ( sepin( i )+tolin )
343  ELSE
344  vmax = one
345  END IF
346  IF( vmax.GT.rmax( 2 ) ) THEN
347  rmax( 2 ) = vmax
348  IF( ninfo( 2 ).EQ.0 )
349  $ lmax( 2 ) = knt
350  END IF
351  130 CONTINUE
352 *
353 * Compare condition numbers for eigenvalues
354 * without taking their condition numbers into account
355 *
356  DO 140 i = 1, n
357  IF( sin( i ).LE.dble( 2*n )*eps .AND. stmp( i ).LE.
358  $ dble( 2*n )*eps ) THEN
359  vmax = one
360  ELSE IF( eps*sin( i ).GT.stmp( i ) ) THEN
361  vmax = one / eps
362  ELSE IF( sin( i ).GT.stmp( i ) ) THEN
363  vmax = sin( i ) / stmp( i )
364  ELSE IF( sin( i ).LT.eps*stmp( i ) ) THEN
365  vmax = one / eps
366  ELSE IF( sin( i ).LT.stmp( i ) ) THEN
367  vmax = stmp( i ) / sin( i )
368  ELSE
369  vmax = one
370  END IF
371  IF( vmax.GT.rmax( 3 ) ) THEN
372  rmax( 3 ) = vmax
373  IF( ninfo( 3 ).EQ.0 )
374  $ lmax( 3 ) = knt
375  END IF
376  140 CONTINUE
377 *
378 * Compare condition numbers for eigenvectors
379 * without taking their condition numbers into account
380 *
381  DO 150 i = 1, n
382  IF( sepin( i ).LE.v .AND. septmp( i ).LE.v ) THEN
383  vmax = one
384  ELSE IF( eps*sepin( i ).GT.septmp( i ) ) THEN
385  vmax = one / eps
386  ELSE IF( sepin( i ).GT.septmp( i ) ) THEN
387  vmax = sepin( i ) / septmp( i )
388  ELSE IF( sepin( i ).LT.eps*septmp( i ) ) THEN
389  vmax = one / eps
390  ELSE IF( sepin( i ).LT.septmp( i ) ) THEN
391  vmax = septmp( i ) / sepin( i )
392  ELSE
393  vmax = one
394  END IF
395  IF( vmax.GT.rmax( 3 ) ) THEN
396  rmax( 3 ) = vmax
397  IF( ninfo( 3 ).EQ.0 )
398  $ lmax( 3 ) = knt
399  END IF
400  150 CONTINUE
401 *
402 * Compute eigenvalue condition numbers only and compare
403 *
404  vmax = zero
405  dum( 1 ) = -one
406  CALL dcopy( n, dum, 0, stmp, 1 )
407  CALL dcopy( n, dum, 0, septmp, 1 )
408  CALL ztrsna( 'E', 'A', SELECT, n, t, ldt, le, ldt, re, ldt,
409  $ stmp, septmp, n, m, work, n, rwork, info )
410  IF( info.NE.0 ) THEN
411  lmax( 3 ) = knt
412  ninfo( 3 ) = ninfo( 3 ) + 1
413  GO TO 260
414  END IF
415  DO 160 i = 1, n
416  IF( stmp( i ).NE.s( i ) )
417  $ vmax = one / eps
418  IF( septmp( i ).NE.dum( 1 ) )
419  $ vmax = one / eps
420  160 CONTINUE
421 *
422 * Compute eigenvector condition numbers only and compare
423 *
424  CALL dcopy( n, dum, 0, stmp, 1 )
425  CALL dcopy( n, dum, 0, septmp, 1 )
426  CALL ztrsna( 'V', 'A', SELECT, n, t, ldt, le, ldt, re, ldt,
427  $ stmp, septmp, n, m, work, n, rwork, info )
428  IF( info.NE.0 ) THEN
429  lmax( 3 ) = knt
430  ninfo( 3 ) = ninfo( 3 ) + 1
431  GO TO 260
432  END IF
433  DO 170 i = 1, n
434  IF( stmp( i ).NE.dum( 1 ) )
435  $ vmax = one / eps
436  IF( septmp( i ).NE.sep( i ) )
437  $ vmax = one / eps
438  170 CONTINUE
439 *
440 * Compute all condition numbers using SELECT and compare
441 *
442  DO 180 i = 1, n
443  SELECT( i ) = .true.
444  180 CONTINUE
445  CALL dcopy( n, dum, 0, stmp, 1 )
446  CALL dcopy( n, dum, 0, septmp, 1 )
447  CALL ztrsna( 'B', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
448  $ stmp, septmp, n, m, work, n, rwork, info )
449  IF( info.NE.0 ) THEN
450  lmax( 3 ) = knt
451  ninfo( 3 ) = ninfo( 3 ) + 1
452  GO TO 260
453  END IF
454  DO 190 i = 1, n
455  IF( septmp( i ).NE.sep( i ) )
456  $ vmax = one / eps
457  IF( stmp( i ).NE.s( i ) )
458  $ vmax = one / eps
459  190 CONTINUE
460 *
461 * Compute eigenvalue condition numbers using SELECT and compare
462 *
463  CALL dcopy( n, dum, 0, stmp, 1 )
464  CALL dcopy( n, dum, 0, septmp, 1 )
465  CALL ztrsna( 'E', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
466  $ stmp, septmp, n, m, work, n, rwork, info )
467  IF( info.NE.0 ) THEN
468  lmax( 3 ) = knt
469  ninfo( 3 ) = ninfo( 3 ) + 1
470  GO TO 260
471  END IF
472  DO 200 i = 1, n
473  IF( stmp( i ).NE.s( i ) )
474  $ vmax = one / eps
475  IF( septmp( i ).NE.dum( 1 ) )
476  $ vmax = one / eps
477  200 CONTINUE
478 *
479 * Compute eigenvector condition numbers using SELECT and compare
480 *
481  CALL dcopy( n, dum, 0, stmp, 1 )
482  CALL dcopy( n, dum, 0, septmp, 1 )
483  CALL ztrsna( 'V', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
484  $ stmp, septmp, n, m, work, n, rwork, info )
485  IF( info.NE.0 ) THEN
486  lmax( 3 ) = knt
487  ninfo( 3 ) = ninfo( 3 ) + 1
488  GO TO 260
489  END IF
490  DO 210 i = 1, n
491  IF( stmp( i ).NE.dum( 1 ) )
492  $ vmax = one / eps
493  IF( septmp( i ).NE.sep( i ) )
494  $ vmax = one / eps
495  210 CONTINUE
496  IF( vmax.GT.rmax( 1 ) ) THEN
497  rmax( 1 ) = vmax
498  IF( ninfo( 1 ).EQ.0 )
499  $ lmax( 1 ) = knt
500  END IF
501 *
502 * Select second and next to last eigenvalues
503 *
504  DO 220 i = 1, n
505  SELECT( i ) = .false.
506  220 CONTINUE
507  icmp = 0
508  IF( n.GT.1 ) THEN
509  icmp = 1
510  lcmp( 1 ) = 2
511  SELECT( 2 ) = .true.
512  CALL zcopy( n, re( 1, 2 ), 1, re( 1, 1 ), 1 )
513  CALL zcopy( n, le( 1, 2 ), 1, le( 1, 1 ), 1 )
514  END IF
515  IF( n.GT.3 ) THEN
516  icmp = 2
517  lcmp( 2 ) = n - 1
518  SELECT( n-1 ) = .true.
519  CALL zcopy( n, re( 1, n-1 ), 1, re( 1, 2 ), 1 )
520  CALL zcopy( n, le( 1, n-1 ), 1, le( 1, 2 ), 1 )
521  END IF
522 *
523 * Compute all selected condition numbers
524 *
525  CALL dcopy( icmp, dum, 0, stmp, 1 )
526  CALL dcopy( icmp, dum, 0, septmp, 1 )
527  CALL ztrsna( 'B', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
528  $ stmp, septmp, n, m, work, n, rwork, info )
529  IF( info.NE.0 ) THEN
530  lmax( 3 ) = knt
531  ninfo( 3 ) = ninfo( 3 ) + 1
532  GO TO 260
533  END IF
534  DO 230 i = 1, icmp
535  j = lcmp( i )
536  IF( septmp( i ).NE.sep( j ) )
537  $ vmax = one / eps
538  IF( stmp( i ).NE.s( j ) )
539  $ vmax = one / eps
540  230 CONTINUE
541 *
542 * Compute selected eigenvalue condition numbers
543 *
544  CALL dcopy( icmp, dum, 0, stmp, 1 )
545  CALL dcopy( icmp, dum, 0, septmp, 1 )
546  CALL ztrsna( 'E', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
547  $ stmp, septmp, n, m, work, n, rwork, info )
548  IF( info.NE.0 ) THEN
549  lmax( 3 ) = knt
550  ninfo( 3 ) = ninfo( 3 ) + 1
551  GO TO 260
552  END IF
553  DO 240 i = 1, icmp
554  j = lcmp( i )
555  IF( stmp( i ).NE.s( j ) )
556  $ vmax = one / eps
557  IF( septmp( i ).NE.dum( 1 ) )
558  $ vmax = one / eps
559  240 CONTINUE
560 *
561 * Compute selected eigenvector condition numbers
562 *
563  CALL dcopy( icmp, dum, 0, stmp, 1 )
564  CALL dcopy( icmp, dum, 0, septmp, 1 )
565  CALL ztrsna( 'V', 'S', SELECT, n, t, ldt, le, ldt, re, ldt,
566  $ stmp, septmp, n, m, work, n, rwork, info )
567  IF( info.NE.0 ) THEN
568  lmax( 3 ) = knt
569  ninfo( 3 ) = ninfo( 3 ) + 1
570  GO TO 260
571  END IF
572  DO 250 i = 1, icmp
573  j = lcmp( i )
574  IF( stmp( i ).NE.dum( 1 ) )
575  $ vmax = one / eps
576  IF( septmp( i ).NE.sep( j ) )
577  $ vmax = one / eps
578  250 CONTINUE
579  IF( vmax.GT.rmax( 1 ) ) THEN
580  rmax( 1 ) = vmax
581  IF( ninfo( 1 ).EQ.0 )
582  $ lmax( 1 ) = knt
583  END IF
584  260 CONTINUE
585  GO TO 10
586 *
587 * End of ZGET37
588 *
zlacpy
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
Definition: zlacpy.f:105
dcopy
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
Definition: dcopy.f:53
zcopy
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:52
dlamch
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:65
zgehrd
subroutine zgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
ZGEHRD
Definition: zgehrd.f:169
ztrevc
subroutine ztrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
ZTREVC
Definition: ztrevc.f:220
dlabad
subroutine dlabad(SMALL, LARGE)
DLABAD
Definition: dlabad.f:76
zlange
double precision function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: zlange.f:117
dscal
subroutine dscal(N, DA, DX, INCX)
DSCAL
Definition: dscal.f:55
zhseqr
subroutine zhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO)
ZHSEQR
Definition: zhseqr.f:301
zdscal
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
Definition: zdscal.f:54
ztrsna
subroutine ztrsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO)
ZTRSNA
Definition: ztrsna.f:251

Here is the call graph for this function:

Here is the caller graph for this function: