89 SUBROUTINE zget37( RMAX, LMAX, NINFO, KNT, NIN )
99 INTEGER LMAX( 3 ), NINFO( 3 )
100 DOUBLE PRECISION RMAX( 3 )
106 DOUBLE PRECISION ZERO, ONE, TWO
107 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
108 DOUBLE PRECISION EPSIN
109 parameter( epsin = 5.9605d-8 )
111 parameter( ldt = 20, lwork = 2*ldt*( 10+ldt ) )
114 INTEGER I, ICMP, INFO, ISCL, ISRT, J, KMIN, M, N
115 DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TNRM, TOL, TOLIN, V,
116 $ VCMIN, VMAX, VMIN, VMUL
119 LOGICAL SELECT( LDT )
121 DOUBLE PRECISION DUM( 1 ), RWORK( 2*LDT ), S( LDT ), SEP( LDT ),
122 $ SEPIN( LDT ), SEPTMP( LDT ), SIN( LDT ),
123 $ STMP( LDT ), VAL( 3 ), WIIN( LDT ),
124 $ WRIN( LDT ), WSRT( LDT )
125 COMPLEX*16 CDUM( 1 ), LE( LDT, LDT ), RE( LDT, LDT ),
126 $ T( LDT, LDT ), TMP( LDT, LDT ), W( LDT ),
127 $ WORK( LWORK ), WTMP( LDT )
130 DOUBLE PRECISION DLAMCH, ZLANGE
131 EXTERNAL dlamch, zlange
138 INTRINSIC dble, dimag, max, sqrt
143 smlnum = dlamch(
'S' ) / eps
144 bignum = one / smlnum
145 CALL dlabad( smlnum, bignum )
149 eps = max( eps, epsin )
160 val( 1 ) = sqrt( smlnum )
162 val( 3 ) = sqrt( bignum )
169 READ( nin, fmt = * )n, isrt
173 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
176 READ( nin, fmt = * )wrin( i ), wiin( i ), sin( i ), sepin( i )
178 tnrm = zlange(
'M', n, n, tmp, ldt, rwork )
184 CALL zlacpy(
'F', n, n, tmp, ldt, t, ldt )
187 CALL zdscal( n, vmul, t( 1, i ), 1 )
194 CALL zgehrd( n, 1, n, t, ldt, work( 1 ), work( n+1 ), lwork-n,
198 ninfo( 1 ) = ninfo( 1 ) + 1
209 CALL zhseqr(
'S',
'N', n, 1, n, t, ldt, w, cdum, 1, work,
213 ninfo( 2 ) = ninfo( 2 ) + 1
222 CALL ztrevc(
'B',
'A',
SELECT, n, t, ldt, le, ldt, re, ldt, n,
223 $ m, work, rwork, info )
227 CALL ztrsna(
'B',
'A',
SELECT, n, t, ldt, le, ldt, re, ldt, s,
228 $ sep, n, m, work, n, rwork, info )
231 ninfo( 3 ) = ninfo( 3 ) + 1
238 CALL zcopy( n, w, 1, wtmp, 1 )
244 wsrt( i ) = dble( w( i ) )
251 wsrt( i ) = dimag( w( i ) )
254 CALL dcopy( n, s, 1, stmp, 1 )
255 CALL dcopy( n, sep, 1, septmp, 1 )
256 CALL dscal( n, one / vmul, septmp, 1 )
261 IF( wsrt( j ).LT.vmin )
THEN
266 wsrt( kmin ) = wsrt( i )
269 wtmp( i ) = w( kmin )
272 stmp( kmin ) = stmp( i )
274 vmin = septmp( kmin )
275 septmp( kmin ) = septmp( i )
282 v = max( two*dble( n )*eps*tnrm, smlnum )
286 IF( v.GT.septmp( i ) )
THEN
289 tol = v / septmp( i )
291 IF( v.GT.sepin( i ) )
THEN
294 tolin = v / sepin( i )
296 tol = max( tol, smlnum / eps )
297 tolin = max( tolin, smlnum / eps )
298 IF( eps*( sin( i )-tolin ).GT.stmp( i )+tol )
THEN
300 ELSE IF( sin( i )-tolin.GT.stmp( i )+tol )
THEN
301 vmax = ( sin( i )-tolin ) / ( stmp( i )+tol )
302 ELSE IF( sin( i )+tolin.LT.eps*( stmp( i )-tol ) )
THEN
304 ELSE IF( sin( i )+tolin.LT.stmp( i )-tol )
THEN
305 vmax = ( stmp( i )-tol ) / ( sin( i )+tolin )
309 IF( vmax.GT.rmax( 2 ) )
THEN
311 IF( ninfo( 2 ).EQ.0 )
320 IF( v.GT.septmp( i )*stmp( i ) )
THEN
325 IF( v.GT.sepin( i )*sin( i ) )
THEN
330 tol = max( tol, smlnum / eps )
331 tolin = max( tolin, smlnum / eps )
332 IF( eps*( sepin( i )-tolin ).GT.septmp( i )+tol )
THEN
334 ELSE IF( sepin( i )-tolin.GT.septmp( i )+tol )
THEN
335 vmax = ( sepin( i )-tolin ) / ( septmp( i )+tol )
336 ELSE IF( sepin( i )+tolin.LT.eps*( septmp( i )-tol ) )
THEN
338 ELSE IF( sepin( i )+tolin.LT.septmp( i )-tol )
THEN
339 vmax = ( septmp( i )-tol ) / ( sepin( i )+tolin )
343 IF( vmax.GT.rmax( 2 ) )
THEN
345 IF( ninfo( 2 ).EQ.0 )
354 IF( sin( i ).LE.dble( 2*n )*eps .AND. stmp( i ).LE.
355 $ dble( 2*n )*eps )
THEN
357 ELSE IF( eps*sin( i ).GT.stmp( i ) )
THEN
359 ELSE IF( sin( i ).GT.stmp( i ) )
THEN
360 vmax = sin( i ) / stmp( i )
361 ELSE IF( sin( i ).LT.eps*stmp( i ) )
THEN
363 ELSE IF( sin( i ).LT.stmp( i ) )
THEN
364 vmax = stmp( i ) / sin( i )
368 IF( vmax.GT.rmax( 3 ) )
THEN
370 IF( ninfo( 3 ).EQ.0 )
379 IF( sepin( i ).LE.v .AND. septmp( i ).LE.v )
THEN
381 ELSE IF( eps*sepin( i ).GT.septmp( i ) )
THEN
383 ELSE IF( sepin( i ).GT.septmp( i ) )
THEN
384 vmax = sepin( i ) / septmp( i )
385 ELSE IF( sepin( i ).LT.eps*septmp( i ) )
THEN
387 ELSE IF( sepin( i ).LT.septmp( i ) )
THEN
388 vmax = septmp( i ) / sepin( i )
392 IF( vmax.GT.rmax( 3 ) )
THEN
394 IF( ninfo( 3 ).EQ.0 )
403 CALL dcopy( n, dum, 0, stmp, 1 )
404 CALL dcopy( n, dum, 0, septmp, 1 )
405 CALL ztrsna(
'E',
'A',
SELECT, n, t, ldt, le, ldt, re, ldt,
406 $ stmp, septmp, n, m, work, n, rwork, info )
409 ninfo( 3 ) = ninfo( 3 ) + 1
413 IF( stmp( i ).NE.s( i ) )
415 IF( septmp( i ).NE.dum( 1 ) )
421 CALL dcopy( n, dum, 0, stmp, 1 )
422 CALL dcopy( n, dum, 0, septmp, 1 )
423 CALL ztrsna(
'V',
'A',
SELECT, n, t, ldt, le, ldt, re, ldt,
424 $ stmp, septmp, n, m, work, n, rwork, info )
427 ninfo( 3 ) = ninfo( 3 ) + 1
431 IF( stmp( i ).NE.dum( 1 ) )
433 IF( septmp( i ).NE.sep( i ) )
442 CALL dcopy( n, dum, 0, stmp, 1 )
443 CALL dcopy( n, dum, 0, septmp, 1 )
444 CALL ztrsna(
'B',
'S',
SELECT, n, t, ldt, le, ldt, re, ldt,
445 $ stmp, septmp, n, m, work, n, rwork, info )
448 ninfo( 3 ) = ninfo( 3 ) + 1
452 IF( septmp( i ).NE.sep( i ) )
454 IF( stmp( i ).NE.s( i ) )
460 CALL dcopy( n, dum, 0, stmp, 1 )
461 CALL dcopy( n, dum, 0, septmp, 1 )
462 CALL ztrsna(
'E',
'S',
SELECT, n, t, ldt, le, ldt, re, ldt,
463 $ stmp, septmp, n, m, work, n, rwork, info )
466 ninfo( 3 ) = ninfo( 3 ) + 1
470 IF( stmp( i ).NE.s( i ) )
472 IF( septmp( i ).NE.dum( 1 ) )
478 CALL dcopy( n, dum, 0, stmp, 1 )
479 CALL dcopy( n, dum, 0, septmp, 1 )
480 CALL ztrsna(
'V',
'S',
SELECT, n, t, ldt, le, ldt, re, ldt,
481 $ stmp, septmp, n, m, work, n, rwork, info )
484 ninfo( 3 ) = ninfo( 3 ) + 1
488 IF( stmp( i ).NE.dum( 1 ) )
490 IF( septmp( i ).NE.sep( i ) )
493 IF( vmax.GT.rmax( 1 ) )
THEN
495 IF( ninfo( 1 ).EQ.0 )
502 SELECT( i ) = .false.
509 CALL zcopy( n, re( 1, 2 ), 1, re( 1, 1 ), 1 )
510 CALL zcopy( n, le( 1, 2 ), 1, le( 1, 1 ), 1 )
515 SELECT( n-1 ) = .true.
516 CALL zcopy( n, re( 1, n-1 ), 1, re( 1, 2 ), 1 )
517 CALL zcopy( n, le( 1, n-1 ), 1, le( 1, 2 ), 1 )
522 CALL dcopy( icmp, dum, 0, stmp, 1 )
523 CALL dcopy( icmp, dum, 0, septmp, 1 )
524 CALL ztrsna(
'B',
'S',
SELECT, n, t, ldt, le, ldt, re, ldt,
525 $ stmp, septmp, n, m, work, n, rwork, info )
528 ninfo( 3 ) = ninfo( 3 ) + 1
533 IF( septmp( i ).NE.sep( j ) )
535 IF( stmp( i ).NE.s( j ) )
541 CALL dcopy( icmp, dum, 0, stmp, 1 )
542 CALL dcopy( icmp, dum, 0, septmp, 1 )
543 CALL ztrsna(
'E',
'S',
SELECT, n, t, ldt, le, ldt, re, ldt,
544 $ stmp, septmp, n, m, work, n, rwork, info )
547 ninfo( 3 ) = ninfo( 3 ) + 1
552 IF( stmp( i ).NE.s( j ) )
554 IF( septmp( i ).NE.dum( 1 ) )
560 CALL dcopy( icmp, dum, 0, stmp, 1 )
561 CALL dcopy( icmp, dum, 0, septmp, 1 )
562 CALL ztrsna(
'V',
'S',
SELECT, n, t, ldt, le, ldt, re, ldt,
563 $ stmp, septmp, n, m, work, n, rwork, info )
566 ninfo( 3 ) = ninfo( 3 ) + 1
571 IF( stmp( i ).NE.dum( 1 ) )
573 IF( septmp( i ).NE.sep( j ) )
576 IF( vmax.GT.rmax( 1 ) )
THEN
578 IF( ninfo( 1 ).EQ.0 )
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zget37(RMAX, LMAX, NINFO, KNT, NIN)
ZGET37
subroutine zgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
ZGEHRD
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO)
ZHSEQR
subroutine ztrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO)
ZTREVC
subroutine ztrsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO)
ZTRSNA
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dscal(N, DA, DX, INCX)
DSCAL