89 SUBROUTINE sget37( RMAX, LMAX, NINFO, KNT, NIN )
99 INTEGER LMAX( 3 ), NINFO( 3 )
107 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0 )
109 parameter( epsin = 5.9605e-8 )
111 parameter( ldt = 20, lwork = 2*ldt*( 10+ldt ) )
114 INTEGER I, ICMP, IFND, INFO, ISCL, J, KMIN, M, N
115 REAL BIGNUM, EPS, SMLNUM, TNRM, TOL, TOLIN, V,
116 $ VIMIN, VMAX, VMUL, VRMIN
119 LOGICAL SELECT( LDT )
120 INTEGER IWORK( 2*LDT ), LCMP( 3 )
121 REAL 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 ),
131 EXTERNAL slamch, slange
138 INTRINSIC max, real, sqrt
143 smlnum = slamch(
'S' ) / eps
144 bignum = one / smlnum
145 CALL slabad( 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 = slange(
'M', n, n, tmp, ldt, work )
188 CALL slacpy(
'F', n, n, tmp, ldt, t, ldt )
191 CALL sscal( n, vmul, t( 1, i ), 1 )
198 CALL sgehrd( n, 1, n, t, ldt, work( 1 ), work( n+1 ), lwork-n,
202 ninfo( 1 ) = ninfo( 1 ) + 1
213 CALL shseqr(
'S',
'N', n, 1, n, t, ldt, wr, wi, dum, 1, work,
217 ninfo( 2 ) = ninfo( 2 ) + 1
223 CALL strevc(
'Both',
'All',
SELECT, n, t, ldt, le, ldt, re,
224 $ ldt, n, m, work, info )
228 CALL strsna(
'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 scopy( n, wr, 1, wrtmp, 1 )
240 CALL scopy( n, wi, 1, witmp, 1 )
241 CALL scopy( n, s, 1, stmp, 1 )
242 CALL scopy( n, sep, 1, septmp, 1 )
243 CALL sscal( 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*real( 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.real( 2*n )*eps .AND. stmp( i ).LE.
343 $ real( 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 scopy( n, dum, 0, stmp, 1 )
392 CALL scopy( n, dum, 0, septmp, 1 )
393 CALL strsna(
'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 scopy( n, dum, 0, stmp, 1 )
410 CALL scopy( n, dum, 0, septmp, 1 )
411 CALL strsna(
'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 scopy( n, dum, 0, stmp, 1 )
431 CALL scopy( n, dum, 0, septmp, 1 )
432 CALL strsna(
'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 scopy( n, dum, 0, stmp, 1 )
450 CALL scopy( n, dum, 0, septmp, 1 )
451 CALL strsna(
'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 scopy( n, dum, 0, stmp, 1 )
468 CALL scopy( n, dum, 0, septmp, 1 )
469 CALL strsna(
'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 scopy( n, re( 1, i ), 1, re( 1, 2 ), 1 )
501 CALL scopy( n, re( 1, i+1 ), 1, re( 1, 3 ), 1 )
502 CALL scopy( n, le( 1, i ), 1, le( 1, 2 ), 1 )
503 CALL scopy( 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 scopy( n, re( 1, i ), 1, re( 1, 3 ), 1 )
522 CALL scopy( n, le( 1, i ), 1, le( 1, 3 ), 1 )
534 CALL scopy( icmp, dum, 0, stmp, 1 )
535 CALL scopy( icmp, dum, 0, septmp, 1 )
536 CALL strsna(
'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 scopy( icmp, dum, 0, stmp, 1 )
555 CALL scopy( icmp, dum, 0, septmp, 1 )
556 CALL strsna(
'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 scopy( icmp, dum, 0, stmp, 1 )
574 CALL scopy( icmp, dum, 0, septmp, 1 )
575 CALL strsna(
'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 )
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine sgehrd(N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO)
SGEHRD
subroutine strevc(SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO)
STREVC
subroutine strsna(JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO)
STRSNA
subroutine shseqr(JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO)
SHSEQR
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine sget37(RMAX, LMAX, NINFO, KNT, NIN)
SGET37