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 ssbt21(UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK, RESULT)
SSBT21
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine ssbtrd(VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO)
SSBTRD
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 schksb(NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK, LWORK, RESULT, INFO)
SCHKSB
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 slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM