290 SUBROUTINE schksb( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED,
291 $ THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK,
292 $ LWORK, RESULT, INFO )
299 INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES,
305 INTEGER ISEED( 4 ), KK( * ), NN( * )
306 REAL A( LDA, * ), RESULT( * ), SD( * ), SE( * ),
307 $ u( ldu, * ), work( * )
313 REAL ZERO, ONE, TWO, TEN
314 PARAMETER ( ZERO = 0.0e0, one = 1.0e0, two = 2.0e0,
317 PARAMETER ( HALF = one / two )
319 parameter( maxtyp = 15 )
322 LOGICAL BADNN, BADNNB
323 INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE,
324 $ jtype, jwidth, k, kmax, mtypes, n, nerrs,
325 $ nmats, nmax, ntest, ntestt
326 REAL ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
327 $ TEMP1, ULP, ULPINV, UNFL
330 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
331 $ KMODE( MAXTYP ), KTYPE( MAXTYP )
342 INTRINSIC abs, max, min, real, sqrt
345 DATA ktype / 1, 2, 5*4, 5*5, 3*8 /
346 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
348 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
363 nmax = max( nmax, nn( j ) )
371 kmax = max( kmax, kk( j ) )
375 kmax = min( nmax-1, kmax )
379 IF( nsizes.LT.0 )
THEN
381 ELSE IF( badnn )
THEN
383 ELSE IF( nwdths.LT.0 )
THEN
385 ELSE IF( badnnb )
THEN
387 ELSE IF( ntypes.LT.0 )
THEN
389 ELSE IF( lda.LT.kmax+1 )
THEN
391 ELSE IF( ldu.LT.nmax )
THEN
393 ELSE IF( ( max( lda, nmax )+1 )*nmax.GT.lwork )
THEN
398 CALL xerbla(
'SCHKSB', -info )
404 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 .OR. nwdths.EQ.0 )
409 unfl = slamch(
'Safe minimum' )
411 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
413 rtunfl = sqrt( unfl )
414 rtovfl = sqrt( ovfl )
421 DO 190 jsize = 1, nsizes
423 aninv = one / real( max( 1, n ) )
425 DO 180 jwidth = 1, nwdths
429 k = max( 0, min( n-1, k ) )
431 IF( nsizes.NE.1 )
THEN
432 mtypes = min( maxtyp, ntypes )
434 mtypes = min( maxtyp+1, ntypes )
437 DO 170 jtype = 1, mtypes
438 IF( .NOT.dotype( jtype ) )
444 ioldsd( j ) = iseed( j )
464 IF( mtypes.GT.maxtyp )
467 itype = ktype( jtype )
468 imode = kmode( jtype )
472 GO TO ( 40, 50, 60 )kmagn( jtype )
479 anorm = ( rtovfl*ulp )*aninv
483 anorm = rtunfl*n*ulpinv
488 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
490 IF( jtype.LE.15 )
THEN
493 cond = ulpinv*aninv / ten
500 IF( itype.EQ.1 )
THEN
503 ELSE IF( itype.EQ.2 )
THEN
508 a( k+1, jcol ) = anorm
511 ELSE IF( itype.EQ.4 )
THEN
515 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
516 $ anorm, 0, 0,
'Q', a( k+1, 1 ), lda,
517 $ work( n+1 ), iinfo )
519 ELSE IF( itype.EQ.5 )
THEN
523 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
524 $ anorm, k, k,
'Q', a, lda, work( n+1 ),
527 ELSE IF( itype.EQ.7 )
THEN
531 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
532 $
'T',
'N', work( n+1 ), 1, one,
533 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
534 $ zero, anorm,
'Q', a( k+1, 1 ), lda,
537 ELSE IF( itype.EQ.8 )
THEN
541 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
542 $
'T',
'N', work( n+1 ), 1, one,
543 $ work( 2*n+1 ), 1, one,
'N', idumma, k, k,
544 $ zero, anorm,
'Q', a, lda, idumma, iinfo )
546 ELSE IF( itype.EQ.9 )
THEN
550 CALL slatms( n, n,
'S', iseed,
'P', work, imode, cond,
551 $ anorm, k, k,
'Q', a, lda, work( n+1 ),
554 ELSE IF( itype.EQ.10 )
THEN
560 CALL slatms( n, n,
'S', iseed,
'P', work, imode, cond,
561 $ anorm, 1, 1,
'Q', a( k, 1 ), lda,
562 $ work( n+1 ), iinfo )
564 temp1 = abs( a( k, i ) ) /
565 $ sqrt( abs( a( k+1, i-1 )*a( k+1, i ) ) )
566 IF( temp1.GT.half )
THEN
567 a( k, i ) = half*sqrt( abs( a( k+1,
568 $ i-1 )*a( k+1, i ) ) )
577 IF( iinfo.NE.0 )
THEN
578 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n,
588 CALL slacpy(
' ', k+1, n, a, lda, work, lda )
591 CALL ssbtrd(
'V',
'U', n, k, work, lda, sd, se, u, ldu,
592 $ work( lda*n+1 ), iinfo )
594 IF( iinfo.NE.0 )
THEN
595 WRITE( nounit, fmt = 9999 )
'SSBTRD(U)', iinfo, n,
598 IF( iinfo.LT.0 )
THEN
608 CALL ssbt21(
'Upper', n, k, 1, a, lda, sd, se, u, ldu,
609 $ work, result( 1 ) )
615 DO 110 jr = 0, min( k, n-jc )
616 a( jr+1, jc ) = a( k+1-jr, jc+jr )
619 DO 140 jc = n + 1 - k, n
620 DO 130 jr = min( k, n-jc ) + 1, k
627 CALL slacpy(
' ', k+1, n, a, lda, work, lda )
630 CALL ssbtrd(
'V',
'L', n, k, work, lda, sd, se, u, ldu,
631 $ work( lda*n+1 ), iinfo )
633 IF( iinfo.NE.0 )
THEN
634 WRITE( nounit, fmt = 9999 )
'SSBTRD(L)', iinfo, n,
637 IF( iinfo.LT.0 )
THEN
648 CALL ssbt21(
'Lower', n, k, 1, a, lda, sd, se, u, ldu,
649 $ work, result( 3 ) )
654 ntestt = ntestt + ntest
659 IF( result( jr ).GE.thresh )
THEN
664 IF( nerrs.EQ.0 )
THEN
665 WRITE( nounit, fmt = 9998 )
'SSB'
666 WRITE( nounit, fmt = 9997 )
667 WRITE( nounit, fmt = 9996 )
668 WRITE( nounit, fmt = 9995 )
'Symmetric'
669 WRITE( nounit, fmt = 9994 )
'orthogonal',
'''',
670 $
'transpose', (
'''', j = 1, 4 )
673 WRITE( nounit, fmt = 9993 )n, k, ioldsd, jtype,
684 CALL slasum(
'SSB', nounit, nerrs, ntestt )
687 9999
FORMAT(
' SCHKSB: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
688 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
690 9998
FORMAT( / 1x, a3,
691 $
' -- Real Symmetric Banded Tridiagonal Reduction Routines' )
692 9997
FORMAT(
' Matrix types (see SCHKSB for details): ' )
694 9996
FORMAT( /
' Special Matrices:',
695 $ /
' 1=Zero matrix. ',
696 $
' 5=Diagonal: clustered entries.',
697 $ /
' 2=Identity matrix. ',
698 $
' 6=Diagonal: large, evenly spaced.',
699 $ /
' 3=Diagonal: evenly spaced entries. ',
700 $
' 7=Diagonal: small, evenly spaced.',
701 $ /
' 4=Diagonal: geometr. spaced entries.' )
702 9995
FORMAT(
' Dense ', a,
' Banded Matrices:',
703 $ /
' 8=Evenly spaced eigenvals. ',
704 $
' 12=Small, evenly spaced eigenvals.',
705 $ /
' 9=Geometrically spaced eigenvals. ',
706 $
' 13=Matrix with random O(1) entries.',
707 $ /
' 10=Clustered eigenvalues. ',
708 $
' 14=Matrix with large random entries.',
709 $ /
' 11=Large, evenly spaced eigenvals. ',
710 $
' 15=Matrix with small random entries.' )
712 9994
FORMAT( /
' Tests performed: (S is Tridiag, U is ', a,
',',
713 $ / 20x, a,
' means ', a,
'.', /
' UPLO=''U'':',
714 $ /
' 1= | A - U S U', a1,
' | / ( |A| n ulp ) ',
715 $
' 2= | I - U U', a1,
' | / ( n ulp )', /
' UPLO=''L'':',
716 $ /
' 3= | A - U S U', a1,
' | / ( |A| n ulp ) ',
717 $
' 4= | I - U U', a1,
' | / ( n ulp )' )
718 9993
FORMAT(
' N=', i5,
', K=', i4,
', seed=', 4( i4,
',' ),
' type ',
719 $ i2,
', test(', i2,
')=', g10.3 )
subroutine xerbla(srname, info)
subroutine ssbtrd(vect, uplo, n, kd, ab, ldab, d, e, q, ldq, work, info)
SSBTRD
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
subroutine slaset(uplo, m, n, alpha, beta, a, lda)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine schksb(nsizes, nn, nwdths, kk, ntypes, dotype, iseed, thresh, nounit, a, lda, sd, se, u, ldu, work, lwork, result, info)
SCHKSB
subroutine slasum(type, iounit, ie, nrun)
SLASUM
subroutine slatmr(m, n, dist, iseed, sym, d, mode, cond, dmax, rsign, grade, dl, model, condl, dr, moder, condr, pivtng, ipivot, kl, ku, sparse, anorm, pack, a, lda, iwork, info)
SLATMR
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
subroutine ssbt21(uplo, n, ka, ks, a, lda, d, e, u, ldu, work, result)
SSBT21