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, IFND, INFO, ISCL, J, KMIN, M, N
115 DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TNRM, TOL, TOLIN, V,
116 $ VIMIN, VMAX, VMUL, VRMIN
119 LOGICAL SELECT( LDT )
120 INTEGER IWORK( 2*LDT ), LCMP( 3 )
121 DOUBLE PRECISION DUM( 1 ), LE( LDT, LDT ), RE( LDT, LDT ),
122 $ S( LDT ), SEP( LDT ), SEPIN( LDT ),
123 $ SEPTMP( LDT ), SIN( LDT ), STMP( LDT ),
124 $ T( LDT, LDT ), TMP( LDT, LDT ), VAL( 3 ),
125 $ WI( LDT ), WIIN( LDT ), WITMP( LDT ),
126 $ WORK( LWORK ), WR( LDT ), WRIN( LDT ),
130 DOUBLE PRECISION DLAMCH, DLANGE
138 INTRINSIC dble, max, sqrt
143 smlnum =
dlamch(
'S' ) / eps
144 bignum = one / smlnum
145 CALL dlabad( smlnum, bignum )
149 eps = max( eps, epsin )
161 val( 1 ) = sqrt( smlnum )
163 val( 3 ) = sqrt( bignum )
170 READ( nin, fmt = * )n
174 READ( nin, fmt = * )( tmp( i, j ), j = 1, n )
177 READ( nin, fmt = * )wrin( i ), wiin( i ), sin( i ), sepin( i )
179 tnrm =
dlange(
'M', n, n, tmp, ldt, work )
188 CALL dlacpy(
'F', n, n, tmp, ldt, t, ldt )
191 CALL dscal( n, vmul, t( 1, i ), 1 )
198 CALL dgehrd( n, 1, n, t, ldt, work( 1 ), work( n+1 ), lwork-n,
202 ninfo( 1 ) = ninfo( 1 ) + 1
213 CALL dhseqr(
'S',
'N', n, 1, n, t, ldt, wr, wi, dum, 1, work,
217 ninfo( 2 ) = ninfo( 2 ) + 1
223 CALL dtrevc(
'Both',
'All',
SELECT, n, t, ldt, le, ldt, re,
224 $ ldt, n, m, work, info )
228 CALL dtrsna(
'Both',
'All',
SELECT, n, t, ldt, le, ldt, re,
229 $ ldt, s, sep, n, m, work, n, iwork, info )
232 ninfo( 3 ) = ninfo( 3 ) + 1
239 CALL dcopy( n, wr, 1, wrtmp, 1 )
240 CALL dcopy( n, wi, 1, witmp, 1 )
241 CALL dcopy( n, s, 1, stmp, 1 )
242 CALL dcopy( n, sep, 1, septmp, 1 )
243 CALL dscal( n, one / vmul, septmp, 1 )
249 IF( wrtmp( j ).LT.vrmin )
THEN
255 wrtmp( kmin ) = wrtmp( i )
256 witmp( kmin ) = witmp( i )
260 stmp( kmin ) = stmp( i )
262 vrmin = septmp( kmin )
263 septmp( kmin ) = septmp( i )
270 v = max( two*dble( n )*eps*tnrm, smlnum )
274 IF( v.GT.septmp( i ) )
THEN
277 tol = v / septmp( i )
279 IF( v.GT.sepin( i ) )
THEN
282 tolin = v / sepin( i )
284 tol = max( tol, smlnum / eps )
285 tolin = max( tolin, smlnum / eps )
286 IF( eps*( sin( i )-tolin ).GT.stmp( i )+tol )
THEN
288 ELSE IF( sin( i )-tolin.GT.stmp( i )+tol )
THEN
289 vmax = ( sin( i )-tolin ) / ( stmp( i )+tol )
290 ELSE IF( sin( i )+tolin.LT.eps*( stmp( i )-tol ) )
THEN
292 ELSE IF( sin( i )+tolin.LT.stmp( i )-tol )
THEN
293 vmax = ( stmp( i )-tol ) / ( sin( i )+tolin )
297 IF( vmax.GT.rmax( 2 ) )
THEN
299 IF( ninfo( 2 ).EQ.0 )
308 IF( v.GT.septmp( i )*stmp( i ) )
THEN
313 IF( v.GT.sepin( i )*sin( i ) )
THEN
318 tol = max( tol, smlnum / eps )
319 tolin = max( tolin, smlnum / eps )
320 IF( eps*( sepin( i )-tolin ).GT.septmp( i )+tol )
THEN
322 ELSE IF( sepin( i )-tolin.GT.septmp( i )+tol )
THEN
323 vmax = ( sepin( i )-tolin ) / ( septmp( i )+tol )
324 ELSE IF( sepin( i )+tolin.LT.eps*( septmp( i )-tol ) )
THEN
326 ELSE IF( sepin( i )+tolin.LT.septmp( i )-tol )
THEN
327 vmax = ( septmp( i )-tol ) / ( sepin( i )+tolin )
331 IF( vmax.GT.rmax( 2 ) )
THEN
333 IF( ninfo( 2 ).EQ.0 )
342 IF( sin( i ).LE.dble( 2*n )*eps .AND. stmp( i ).LE.
343 $ dble( 2*n )*eps )
THEN
345 ELSE IF( eps*sin( i ).GT.stmp( i ) )
THEN
347 ELSE IF( sin( i ).GT.stmp( i ) )
THEN
348 vmax = sin( i ) / stmp( i )
349 ELSE IF( sin( i ).LT.eps*stmp( i ) )
THEN
351 ELSE IF( sin( i ).LT.stmp( i ) )
THEN
352 vmax = stmp( i ) / sin( i )
356 IF( vmax.GT.rmax( 3 ) )
THEN
358 IF( ninfo( 3 ).EQ.0 )
367 IF( sepin( i ).LE.v .AND. septmp( i ).LE.v )
THEN
369 ELSE IF( eps*sepin( i ).GT.septmp( i ) )
THEN
371 ELSE IF( sepin( i ).GT.septmp( i ) )
THEN
372 vmax = sepin( i ) / septmp( i )
373 ELSE IF( sepin( i ).LT.eps*septmp( i ) )
THEN
375 ELSE IF( sepin( i ).LT.septmp( i ) )
THEN
376 vmax = septmp( i ) / sepin( i )
380 IF( vmax.GT.rmax( 3 ) )
THEN
382 IF( ninfo( 3 ).EQ.0 )
391 CALL dcopy( n, dum, 0, stmp, 1 )
392 CALL dcopy( n, dum, 0, septmp, 1 )
393 CALL dtrsna(
'Eigcond',
'All',
SELECT, n, t, ldt, le, ldt, re,
394 $ ldt, stmp, septmp, n, m, work, n, iwork, info )
397 ninfo( 3 ) = ninfo( 3 ) + 1
401 IF( stmp( i ).NE.s( i ) )
403 IF( septmp( i ).NE.dum( 1 ) )
409 CALL dcopy( n, dum, 0, stmp, 1 )
410 CALL dcopy( n, dum, 0, septmp, 1 )
411 CALL dtrsna(
'Veccond',
'All',
SELECT, n, t, ldt, le, ldt, re,
412 $ ldt, stmp, septmp, n, m, work, n, iwork, info )
415 ninfo( 3 ) = ninfo( 3 ) + 1
419 IF( stmp( i ).NE.dum( 1 ) )
421 IF( septmp( i ).NE.sep( i ) )
430 CALL dcopy( n, dum, 0, stmp, 1 )
431 CALL dcopy( n, dum, 0, septmp, 1 )
432 CALL dtrsna(
'Bothcond',
'Some',
SELECT, n, t, ldt, le, ldt,
433 $ re, ldt, stmp, septmp, n, m, work, n, iwork,
437 ninfo( 3 ) = ninfo( 3 ) + 1
441 IF( septmp( i ).NE.sep( i ) )
443 IF( stmp( i ).NE.s( i ) )
449 CALL dcopy( n, dum, 0, stmp, 1 )
450 CALL dcopy( n, dum, 0, septmp, 1 )
451 CALL dtrsna(
'Eigcond',
'Some',
SELECT, n, t, ldt, le, ldt, re,
452 $ ldt, stmp, septmp, n, m, work, n, iwork, info )
455 ninfo( 3 ) = ninfo( 3 ) + 1
459 IF( stmp( i ).NE.s( i ) )
461 IF( septmp( i ).NE.dum( 1 ) )
467 CALL dcopy( n, dum, 0, stmp, 1 )
468 CALL dcopy( n, dum, 0, septmp, 1 )
469 CALL dtrsna(
'Veccond',
'Some',
SELECT, n, t, ldt, le, ldt, re,
470 $ ldt, stmp, septmp, n, m, work, n, iwork, info )
473 ninfo( 3 ) = ninfo( 3 ) + 1
477 IF( stmp( i ).NE.dum( 1 ) )
479 IF( septmp( i ).NE.sep( i ) )
482 IF( vmax.GT.rmax( 1 ) )
THEN
484 IF( ninfo( 1 ).EQ.0 )
490 IF( wi( 1 ).EQ.zero )
THEN
494 IF( ifnd.EQ.1 .OR. wi( i ).EQ.zero )
THEN
495 SELECT( i ) = .false.
500 CALL dcopy( n, re( 1, i ), 1, re( 1, 2 ), 1 )
501 CALL dcopy( n, re( 1, i+1 ), 1, re( 1, 3 ), 1 )
502 CALL dcopy( n, le( 1, i ), 1, le( 1, 2 ), 1 )
503 CALL dcopy( n, le( 1, i+1 ), 1, le( 1, 3 ), 1 )
516 IF( ifnd.EQ.1 .OR. wi( i ).NE.zero )
THEN
517 SELECT( i ) = .false.
521 CALL dcopy( n, re( 1, i ), 1, re( 1, 3 ), 1 )
522 CALL dcopy( n, le( 1, i ), 1, le( 1, 3 ), 1 )
534 CALL dcopy( icmp, dum, 0, stmp, 1 )
535 CALL dcopy( icmp, dum, 0, septmp, 1 )
536 CALL dtrsna(
'Bothcond',
'Some',
SELECT, n, t, ldt, le, ldt,
537 $ re, ldt, stmp, septmp, n, m, work, n, iwork,
541 ninfo( 3 ) = ninfo( 3 ) + 1
546 IF( septmp( i ).NE.sep( j ) )
548 IF( stmp( i ).NE.s( j ) )
554 CALL dcopy( icmp, dum, 0, stmp, 1 )
555 CALL dcopy( icmp, dum, 0, septmp, 1 )
556 CALL dtrsna(
'Eigcond',
'Some',
SELECT, n, t, ldt, le, ldt, re,
557 $ ldt, stmp, septmp, n, m, work, n, iwork, info )
560 ninfo( 3 ) = ninfo( 3 ) + 1
565 IF( stmp( i ).NE.s( j ) )
567 IF( septmp( i ).NE.dum( 1 ) )
573 CALL dcopy( icmp, dum, 0, stmp, 1 )
574 CALL dcopy( icmp, dum, 0, septmp, 1 )
575 CALL dtrsna(
'Veccond',
'Some',
SELECT, n, t, ldt, le, ldt, re,
576 $ ldt, stmp, septmp, n, m, work, n, iwork, info )
579 ninfo( 3 ) = ninfo( 3 ) + 1
584 IF( stmp( i ).NE.dum( 1 ) )
586 IF( septmp( i ).NE.sep( j ) )
589 IF( vmax.GT.rmax( 1 ) )
THEN
591 IF( ninfo( 1 ).EQ.0 )
double precision function dlamch(CMACH)
DLAMCH
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dscal(N, DA, DX, INCX)
DSCAL
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine dgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
DGEHRD
subroutine dtrevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
DTREVC
subroutine dtrsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO)
DTRSNA
subroutine dhseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
DHSEQR