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' )
414 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
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 )
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 xerbla(SRNAME, INFO)
XERBLA
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 ssbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
SSBTRD
subroutine ssbt21(UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, RESULT)
SSBT21
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
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