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( ), WITMP( LDT ),
126 $ WORK( LWORK ), WR( LDT ), WRIN( LDT ),
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 )