292 SUBROUTINE schksb( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED,
293 $ thresh, nounit, a, lda, sd, se, u, ldu, work,
294 $ lwork, result, info )
302 INTEGER info, lda, ldu, lwork, nounit, nsizes, ntypes,
308 INTEGER iseed( 4 ), kk( * ), nn( * )
309 REAL a( lda, * ), result( * ), sd( * ), se( * ),
310 $ u( ldu, * ), work( * )
316 REAL zero, one, two, ten
317 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
320 parameter( half = one / two )
322 parameter( maxtyp = 15 )
325 LOGICAL badnn, badnnb
326 INTEGER i, iinfo, imode, itype, j, jc, jcol, jr, jsize,
327 $ jtype, jwidth, k, kmax, mtypes, n, nerrs,
328 $ nmats, nmax, ntest, ntestt
329 REAL aninv, anorm, cond, ovfl, rtovfl, rtunfl,
330 $ temp1, ulp, ulpinv, unfl
333 INTEGER idumma( 1 ), ioldsd( 4 ), kmagn( maxtyp ),
334 $ kmode( maxtyp ), ktype( maxtyp )
345 INTRINSIC abs, max, min,
REAL, sqrt
348 DATA ktype / 1, 2, 5*4, 5*5, 3*8 /
349 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
351 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
366 nmax = max( nmax, nn( j ) )
374 kmax = max( kmax, kk( j ) )
378 kmax = min( nmax-1, kmax )
382 IF( nsizes.LT.0 )
THEN
384 ELSE IF( badnn )
THEN
386 ELSE IF( nwdths.LT.0 )
THEN
388 ELSE IF( badnnb )
THEN
390 ELSE IF( ntypes.LT.0 )
THEN
392 ELSE IF( lda.LT.kmax+1 )
THEN
394 ELSE IF( ldu.LT.nmax )
THEN
396 ELSE IF( ( max( lda, nmax )+1 )*nmax.GT.lwork )
THEN
401 CALL
xerbla(
'SCHKSB', -info )
407 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
412 unfl =
slamch(
'Safe minimum' )
416 rtunfl = sqrt( unfl )
417 rtovfl = sqrt( ovfl )
424 DO 190 jsize = 1, nsizes
426 aninv = one /
REAL( MAX( 1, N ) )
428 DO 180 jwidth = 1, nwdths
432 k = max( 0, min( n-1, k ) )
434 IF( nsizes.NE.1 )
THEN
435 mtypes = min( maxtyp, ntypes )
437 mtypes = min( maxtyp+1, ntypes )
440 DO 170 jtype = 1, mtypes
441 IF( .NOT.dotype( jtype ) )
447 ioldsd( j ) = iseed( j )
467 IF( mtypes.GT.maxtyp )
470 itype = ktype( jtype )
471 imode = kmode( jtype )
475 go to( 40, 50, 60 )kmagn( jtype )
482 anorm = ( rtovfl*ulp )*aninv
486 anorm = rtunfl*n*ulpinv
491 CALL
slaset(
'Full', lda, n, zero, zero, a, lda )
493 IF( jtype.LE.15 )
THEN
496 cond = ulpinv*aninv / ten
503 IF( itype.EQ.1 )
THEN
506 ELSE IF( itype.EQ.2 )
THEN
511 a( k+1, jcol ) = anorm
514 ELSE IF( itype.EQ.4 )
THEN
518 CALL
slatms( n, n,
'S', iseed,
'S', work, imode, cond,
519 $ anorm, 0, 0,
'Q', a( k+1, 1 ), lda,
520 $ work( n+1 ), iinfo )
522 ELSE IF( itype.EQ.5 )
THEN
526 CALL
slatms( n, n,
'S', iseed,
'S', work, imode, cond,
527 $ anorm, k, k,
'Q', a, lda, work( n+1 ),
530 ELSE IF( itype.EQ.7 )
THEN
534 CALL
slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
535 $
'T',
'N', work( n+1 ), 1, one,
536 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
537 $ zero, anorm,
'Q', a( k+1, 1 ), lda,
540 ELSE IF( itype.EQ.8 )
THEN
544 CALL
slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
545 $
'T',
'N', work( n+1 ), 1, one,
546 $ work( 2*n+1 ), 1, one,
'N', idumma, k, k,
547 $ zero, anorm,
'Q', a, lda, idumma, iinfo )
549 ELSE IF( itype.EQ.9 )
THEN
553 CALL
slatms( n, n,
'S', iseed,
'P', work, imode, cond,
554 $ anorm, k, k,
'Q', a, lda, work( n+1 ),
557 ELSE IF( itype.EQ.10 )
THEN
563 CALL
slatms( n, n,
'S', iseed,
'P', work, imode, cond,
564 $ anorm, 1, 1,
'Q', a( k, 1 ), lda,
565 $ work( n+1 ), iinfo )
567 temp1 = abs( a( k, i ) ) /
568 $ sqrt( abs( a( k+1, i-1 )*a( k+1, i ) ) )
569 IF( temp1.GT.half )
THEN
570 a( k, i ) = half*sqrt( abs( a( k+1,
571 $ i-1 )*a( k+1, i ) ) )
580 IF( iinfo.NE.0 )
THEN
581 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n,
591 CALL
slacpy(
' ', k+1, n, a, lda, work, lda )
594 CALL
ssbtrd(
'V',
'U', n, k, work, lda, sd, se, u, ldu,
595 $ work( lda*n+1 ), iinfo )
597 IF( iinfo.NE.0 )
THEN
598 WRITE( nounit, fmt = 9999 )
'SSBTRD(U)', iinfo, n,
601 IF( iinfo.LT.0 )
THEN
611 CALL
ssbt21(
'Upper', n, k, 1, a, lda, sd, se, u, ldu,
612 $ work, result( 1 ) )
618 DO 110 jr = 0, min( k, n-jc )
619 a( jr+1, jc ) = a( k+1-jr, jc+jr )
622 DO 140 jc = n + 1 - k, n
623 DO 130 jr = min( k, n-jc ) + 1, k
630 CALL
slacpy(
' ', k+1, n, a, lda, work, lda )
633 CALL
ssbtrd(
'V',
'L', n, k, work, lda, sd, se, u, ldu,
634 $ work( lda*n+1 ), iinfo )
636 IF( iinfo.NE.0 )
THEN
637 WRITE( nounit, fmt = 9999 )
'SSBTRD(L)', iinfo, n,
640 IF( iinfo.LT.0 )
THEN
651 CALL
ssbt21(
'Lower', n, k, 1, a, lda, sd, se, u, ldu,
652 $ work, result( 3 ) )
657 ntestt = ntestt + ntest
662 IF( result( jr ).GE.thresh )
THEN
667 IF( nerrs.EQ.0 )
THEN
668 WRITE( nounit, fmt = 9998 )
'SSB'
669 WRITE( nounit, fmt = 9997 )
670 WRITE( nounit, fmt = 9996 )
671 WRITE( nounit, fmt = 9995 )
'Symmetric'
672 WRITE( nounit, fmt = 9994 )
'orthogonal',
'''',
673 $
'transpose', (
'''', j = 1, 4 )
676 WRITE( nounit, fmt = 9993 )n, k, ioldsd, jtype,
687 CALL
slasum(
'SSB', nounit, nerrs, ntestt )
690 9999 format(
' SCHKSB: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
691 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
693 9998 format( / 1x, a3,
694 $
' -- Real Symmetric Banded Tridiagonal Reduction Routines' )
695 9997 format(
' Matrix types (see SCHKSB for details): ' )
697 9996 format( /
' Special Matrices:',
698 $ /
' 1=Zero matrix. ',
699 $
' 5=Diagonal: clustered entries.',
700 $ /
' 2=Identity matrix. ',
701 $
' 6=Diagonal: large, evenly spaced.',
702 $ /
' 3=Diagonal: evenly spaced entries. ',
703 $
' 7=Diagonal: small, evenly spaced.',
704 $ /
' 4=Diagonal: geometr. spaced entries.' )
705 9995 format(
' Dense ', a,
' Banded Matrices:',
706 $ /
' 8=Evenly spaced eigenvals. ',
707 $
' 12=Small, evenly spaced eigenvals.',
708 $ /
' 9=Geometrically spaced eigenvals. ',
709 $
' 13=Matrix with random O(1) entries.',
710 $ /
' 10=Clustered eigenvalues. ',
711 $
' 14=Matrix with large random entries.',
712 $ /
' 11=Large, evenly spaced eigenvals. ',
713 $
' 15=Matrix with small random entries.' )
715 9994 format( /
' Tests performed: (S is Tridiag, U is ', a,
',',
716 $ / 20x, a,
' means ', a,
'.', /
' UPLO=''U'':',
717 $ /
' 1= | A - U S U', a1,
' | / ( |A| n ulp ) ',
718 $
' 2= | I - U U', a1,
' | / ( n ulp )', /
' UPLO=''L'':',
719 $ /
' 3= | A - U S U', a1,
' | / ( |A| n ulp ) ',
720 $
' 4= | I - U U', a1,
' | / ( n ulp )' )
721 9993 format(
' N=', i5,
', K=', i4,
', seed=', 4( i4,
',' ),
' type ',
722 $ i2,
', test(', i2,
')=', g10.3 )