587 SUBROUTINE schkst( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
588 $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5,
589 $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK,
590 $ LWORK, IWORK, LIWORK, RESULT, INFO )
597 INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
603 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
604 REAL A( LDA, * ), AP( * ), D1( * ), D2( * ),
605 $ d3( * ), d4( * ), d5( * ), result( * ),
606 $ sd( * ), se( * ), tau( * ), u( ldu, * ),
607 $ v( ldu, * ), vp( * ), wa1( * ), wa2( * ),
608 $ wa3( * ), work( * ), wr( * ), z( ldu, * )
614 REAL ZERO, ONE, TWO, EIGHT, TEN, HUN
615 PARAMETER ( ZERO = 0.0e0, one = 1.0e0, two = 2.0e0,
616 $ eight = 8.0e0, ten = 10.0e0, hun = 100.0e0 )
618 parameter( half = one / two )
620 parameter( maxtyp = 21 )
622 parameter( srange = .false. )
624 parameter( srel = .false. )
627 LOGICAL BADNN, TRYRAC
628 INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC,
629 $ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC,
630 $ m, m2, m3, mtypes, n, nap, nblock, nerrs,
631 $ nmats, nmax, nsplit, ntest, ntestt
632 REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
633 $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP,
634 $ ULPINV, UNFL, VL, VU
637 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
638 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
644 REAL SLAMCH, SLARND, SSXT1
645 EXTERNAL ILAENV, SLAMCH, SLARND, SSXT1
654 INTRINSIC abs, int, log, max, min, real, sqrt
657 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
658 $ 8, 8, 9, 9, 9, 9, 9, 10 /
659 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
660 $ 2, 3, 1, 1, 1, 2, 3, 1 /
661 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
662 $ 0, 0, 4, 3, 1, 4, 4, 3 /
680 nmax = max( nmax, nn( j ) )
685 nblock = ilaenv( 1,
'SSYTRD',
'L', nmax, -1, -1, -1 )
686 nblock = min( nmax, max( 1, nblock ) )
690 IF( nsizes.LT.0 )
THEN
692 ELSE IF( badnn )
THEN
694 ELSE IF( ntypes.LT.0 )
THEN
696 ELSE IF( lda.LT.nmax )
THEN
698 ELSE IF( ldu.LT.nmax )
THEN
700 ELSE IF( 2*max( 2, nmax )**2.GT.lwork )
THEN
705 CALL xerbla(
'SCHKST', -info )
711 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
716 unfl = slamch(
'Safe minimum' )
719 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
721 log2ui = int( log( ulpinv ) / log( two ) )
722 rtunfl = sqrt( unfl )
723 rtovfl = sqrt( ovfl )
728 iseed2( i ) = iseed( i )
733 DO 310 jsize = 1, nsizes
736 lgn = int( log( real( n ) ) / log( two ) )
741 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
742 liwedc = 6 + 6*n + 5*n*lgn
747 nap = ( n*( n+1 ) ) / 2
748 aninv = one / real( max( 1, n ) )
750 IF( nsizes.NE.1 )
THEN
751 mtypes = min( maxtyp, ntypes )
753 mtypes = min( maxtyp+1, ntypes )
756 DO 300 jtype = 1, mtypes
757 IF( .NOT.dotype( jtype ) )
763 ioldsd( j ) = iseed( j )
782 IF( mtypes.GT.maxtyp )
785 itype = ktype( jtype )
786 imode = kmode( jtype )
790 GO TO ( 40, 50, 60 )kmagn( jtype )
797 anorm = ( rtovfl*ulp )*aninv
801 anorm = rtunfl*n*ulpinv
806 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
808 IF( jtype.LE.15 )
THEN
811 cond = ulpinv*aninv / ten
818 IF( itype.EQ.1 )
THEN
821 ELSE IF( itype.EQ.2 )
THEN
829 ELSE IF( itype.EQ.4 )
THEN
833 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
834 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
838 ELSE IF( itype.EQ.5 )
THEN
842 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
843 $ anorm, n, n,
'N', a, lda, work( n+1 ),
846 ELSE IF( itype.EQ.7 )
THEN
850 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
851 $
'T',
'N', work( n+1 ), 1, one,
852 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
853 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
855 ELSE IF( itype.EQ.8 )
THEN
859 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
860 $
'T',
'N', work( n+1 ), 1, one,
861 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
862 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
864 ELSE IF( itype.EQ.9 )
THEN
868 CALL slatms( n, n,
'S', iseed,
'P', work, imode, cond,
869 $ anorm, n, n,
'N', a, lda, work( n+1 ),
872 ELSE IF( itype.EQ.10 )
THEN
876 CALL slatms( n, n,
'S', iseed,
'P', work, imode, cond,
877 $ anorm, 1, 1,
'N', a, lda, work( n+1 ),
880 temp1 = abs( a( i-1, i ) ) /
881 $ sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
882 IF( temp1.GT.half )
THEN
883 a( i-1, i ) = half*sqrt( abs( a( i-1, i-1 )*a( i,
885 a( i, i-1 ) = a( i-1, i )
894 IF( iinfo.NE.0 )
THEN
895 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
906 CALL slacpy(
'U', n, n, a, lda, v, ldu )
909 CALL ssytrd(
'U', n, v, ldu, sd, se, tau, work, lwork,
912 IF( iinfo.NE.0 )
THEN
913 WRITE( nounit, fmt = 9999 )
'SSYTRD(U)', iinfo, n, jtype,
916 IF( iinfo.LT.0 )
THEN
924 CALL slacpy(
'U', n, n, v, ldu, u, ldu )
927 CALL sorgtr(
'U', n, u, ldu, tau, work, lwork, iinfo )
928 IF( iinfo.NE.0 )
THEN
929 WRITE( nounit, fmt = 9999 )
'SORGTR(U)', iinfo, n, jtype,
932 IF( iinfo.LT.0 )
THEN
942 CALL ssyt21( 2,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
943 $ ldu, tau, work, result( 1 ) )
944 CALL ssyt21( 3,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
945 $ ldu, tau, work, result( 2 ) )
950 CALL slacpy(
'L', n, n, a, lda, v, ldu )
953 CALL ssytrd(
'L', n, v, ldu, sd, se, tau, work, lwork,
956 IF( iinfo.NE.0 )
THEN
957 WRITE( nounit, fmt = 9999 )
'SSYTRD(L)', iinfo, n, jtype,
960 IF( iinfo.LT.0 )
THEN
968 CALL slacpy(
'L', n, n, v, ldu, u, ldu )
971 CALL sorgtr(
'L', n, u, ldu, tau, work, lwork, iinfo )
972 IF( iinfo.NE.0 )
THEN
973 WRITE( nounit, fmt = 9999 )
'SORGTR(L)', iinfo, n, jtype,
976 IF( iinfo.LT.0 )
THEN
984 CALL ssyt21( 2,
'Lower', n, 1, a, lda, sd, se, u, ldu, v,
985 $ ldu, tau, work, result( 3 ) )
986 CALL ssyt21( 3,
'Lower', n, 1, a, lda, sd, se, u, ldu, v,
987 $ ldu, tau, work, result( 4 ) )
995 ap( i ) = a( jr, jc )
1001 CALL scopy( nap, ap, 1, vp, 1 )
1004 CALL ssptrd(
'U', n, vp, sd, se, tau, iinfo )
1006 IF( iinfo.NE.0 )
THEN
1007 WRITE( nounit, fmt = 9999 )
'SSPTRD(U)', iinfo, n, jtype,
1010 IF( iinfo.LT.0 )
THEN
1013 result( 5 ) = ulpinv
1019 CALL sopgtr(
'U', n, vp, tau, u, ldu, work, iinfo )
1020 IF( iinfo.NE.0 )
THEN
1021 WRITE( nounit, fmt = 9999 )
'SOPGTR(U)', iinfo, n, jtype,
1024 IF( iinfo.LT.0 )
THEN
1027 result( 6 ) = ulpinv
1034 CALL sspt21( 2,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1035 $ work, result( 5 ) )
1036 CALL sspt21( 3,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1037 $ work, result( 6 ) )
1045 ap( i ) = a( jr, jc )
1051 CALL scopy( nap, ap, 1, vp, 1 )
1054 CALL ssptrd(
'L', n, vp, sd, se, tau, iinfo )
1056 IF( iinfo.NE.0 )
THEN
1057 WRITE( nounit, fmt = 9999 )
'SSPTRD(L)', iinfo, n, jtype,
1060 IF( iinfo.LT.0 )
THEN
1063 result( 7 ) = ulpinv
1069 CALL sopgtr(
'L', n, vp, tau, u, ldu, work, iinfo )
1070 IF( iinfo.NE.0 )
THEN
1071 WRITE( nounit, fmt = 9999 )
'SOPGTR(L)', iinfo, n, jtype,
1074 IF( iinfo.LT.0 )
THEN
1077 result( 8 ) = ulpinv
1082 CALL sspt21( 2,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1083 $ work, result( 7 ) )
1084 CALL sspt21( 3,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1085 $ work, result( 8 ) )
1091 CALL scopy( n, sd, 1, d1, 1 )
1093 $
CALL scopy( n-1, se, 1, work, 1 )
1094 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1097 CALL ssteqr(
'V', n, d1, work, z, ldu, work( n+1 ), iinfo )
1098 IF( iinfo.NE.0 )
THEN
1099 WRITE( nounit, fmt = 9999 )
'SSTEQR(V)', iinfo, n, jtype,
1102 IF( iinfo.LT.0 )
THEN
1105 result( 9 ) = ulpinv
1112 CALL scopy( n, sd, 1, d2, 1 )
1114 $
CALL scopy( n-1, se, 1, work, 1 )
1117 CALL ssteqr(
'N', n, d2, work, work( n+1 ), ldu,
1118 $ work( n+1 ), iinfo )
1119 IF( iinfo.NE.0 )
THEN
1120 WRITE( nounit, fmt = 9999 )
'SSTEQR(N)', iinfo, n, jtype,
1123 IF( iinfo.LT.0 )
THEN
1126 result( 11 ) = ulpinv
1133 CALL scopy( n, sd, 1, d3, 1 )
1135 $
CALL scopy( n-1, se, 1, work, 1 )
1138 CALL ssterf( n, d3, work, iinfo )
1139 IF( iinfo.NE.0 )
THEN
1140 WRITE( nounit, fmt = 9999 )
'SSTERF', iinfo, n, jtype,
1143 IF( iinfo.LT.0 )
THEN
1146 result( 12 ) = ulpinv
1153 CALL sstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1164 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1165 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1166 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1167 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1170 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1171 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1177 temp1 = thresh*( half-ulp )
1179 DO 160 j = 0, log2ui
1180 CALL sstech( n, sd, se, d1, temp1, work, iinfo )
1187 result( 13 ) = temp1
1192 IF( jtype.GT.15 )
THEN
1196 CALL scopy( n, sd, 1, d4, 1 )
1198 $
CALL scopy( n-1, se, 1, work, 1 )
1199 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1202 CALL spteqr(
'V', n, d4, work, z, ldu, work( n+1 ),
1204 IF( iinfo.NE.0 )
THEN
1205 WRITE( nounit, fmt = 9999 )
'SPTEQR(V)', iinfo, n,
1208 IF( iinfo.LT.0 )
THEN
1211 result( 14 ) = ulpinv
1218 CALL sstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1223 CALL scopy( n, sd, 1, d5, 1 )
1225 $
CALL scopy( n-1, se, 1, work, 1 )
1228 CALL spteqr(
'N', n, d5, work, z, ldu, work( n+1 ),
1230 IF( iinfo.NE.0 )
THEN
1231 WRITE( nounit, fmt = 9999 )
'SPTEQR(N)', iinfo, n,
1234 IF( iinfo.LT.0 )
THEN
1237 result( 16 ) = ulpinv
1247 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1248 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1251 result( 16 ) = temp2 / max( unfl,
1252 $ hun*ulp*max( temp1, temp2 ) )
1268 IF( jtype.EQ.21 )
THEN
1270 abstol = unfl + unfl
1271 CALL sstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se,
1272 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1273 $ work, iwork( 2*n+1 ), iinfo )
1274 IF( iinfo.NE.0 )
THEN
1275 WRITE( nounit, fmt = 9999 )
'SSTEBZ(A,rel)', iinfo, n,
1278 IF( iinfo.LT.0 )
THEN
1281 result( 17 ) = ulpinv
1288 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1293 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1294 $ ( abstol+abs( d4( j ) ) ) )
1297 result( 17 ) = temp1 / temp2
1305 abstol = unfl + unfl
1306 CALL sstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se, m,
1307 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), work,
1308 $ iwork( 2*n+1 ), iinfo )
1309 IF( iinfo.NE.0 )
THEN
1310 WRITE( nounit, fmt = 9999 )
'SSTEBZ(A)', iinfo, n, jtype,
1313 IF( iinfo.LT.0 )
THEN
1316 result( 18 ) = ulpinv
1326 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1327 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1330 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1340 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1341 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1349 CALL sstebz(
'I',
'E', n, vl, vu, il, iu, abstol, sd, se,
1350 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1351 $ work, iwork( 2*n+1 ), iinfo )
1352 IF( iinfo.NE.0 )
THEN
1353 WRITE( nounit, fmt = 9999 )
'SSTEBZ(I)', iinfo, n, jtype,
1356 IF( iinfo.LT.0 )
THEN
1359 result( 19 ) = ulpinv
1369 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1370 $ ulp*anorm, two*rtunfl )
1372 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1373 $ ulp*anorm, two*rtunfl )
1376 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1377 $ ulp*anorm, two*rtunfl )
1379 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1380 $ ulp*anorm, two*rtunfl )
1387 CALL sstebz(
'V',
'E', n, vl, vu, il, iu, abstol, sd, se,
1388 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1389 $ work, iwork( 2*n+1 ), iinfo )
1390 IF( iinfo.NE.0 )
THEN
1391 WRITE( nounit, fmt = 9999 )
'SSTEBZ(V)', iinfo, n, jtype,
1394 IF( iinfo.LT.0 )
THEN
1397 result( 19 ) = ulpinv
1402 IF( m3.EQ.0 .AND. n.NE.0 )
THEN
1403 result( 19 ) = ulpinv
1409 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1410 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1412 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1417 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1424 CALL sstebz(
'A',
'B', n, vl, vu, il, iu, abstol, sd, se, m,
1425 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), work,
1426 $ iwork( 2*n+1 ), iinfo )
1427 IF( iinfo.NE.0 )
THEN
1428 WRITE( nounit, fmt = 9999 )
'SSTEBZ(A,B)', iinfo, n,
1431 IF( iinfo.LT.0 )
THEN
1434 result( 20 ) = ulpinv
1435 result( 21 ) = ulpinv
1440 CALL sstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1441 $ ldu, work, iwork( 2*n+1 ), iwork( 3*n+1 ),
1443 IF( iinfo.NE.0 )
THEN
1444 WRITE( nounit, fmt = 9999 )
'SSTEIN', iinfo, n, jtype,
1447 IF( iinfo.LT.0 )
THEN
1450 result( 20 ) = ulpinv
1451 result( 21 ) = ulpinv
1458 CALL sstt21( n, 0, sd, se, wa1, dumma, z, ldu, work,
1465 CALL scopy( n, sd, 1, d1, 1 )
1467 $
CALL scopy( n-1, se, 1, work, 1 )
1468 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1471 CALL sstedc(
'I', n, d1, work, z, ldu, work( n+1 ), lwedc-n,
1472 $ iwork, liwedc, iinfo )
1473 IF( iinfo.NE.0 )
THEN
1474 WRITE( nounit, fmt = 9999 )
'SSTEDC(I)', iinfo, n, jtype,
1477 IF( iinfo.LT.0 )
THEN
1480 result( 22 ) = ulpinv
1487 CALL sstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1494 CALL scopy( n, sd, 1, d1, 1 )
1496 $
CALL scopy( n-1, se, 1, work, 1 )
1497 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1500 CALL sstedc(
'V', n, d1, work, z, ldu, work( n+1 ), lwedc-n,
1501 $ iwork, liwedc, iinfo )
1502 IF( iinfo.NE.0 )
THEN
1503 WRITE( nounit, fmt = 9999 )
'SSTEDC(V)', iinfo, n, jtype,
1506 IF( iinfo.LT.0 )
THEN
1509 result( 24 ) = ulpinv
1516 CALL sstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1523 CALL scopy( n, sd, 1, d2, 1 )
1525 $
CALL scopy( n-1, se, 1, work, 1 )
1526 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1529 CALL sstedc(
'N', n, d2, work, z, ldu, work( n+1 ), lwedc-n,
1530 $ iwork, liwedc, iinfo )
1531 IF( iinfo.NE.0 )
THEN
1532 WRITE( nounit, fmt = 9999 )
'SSTEDC(N)', iinfo, n, jtype,
1535 IF( iinfo.LT.0 )
THEN
1538 result( 26 ) = ulpinv
1549 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1550 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1553 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1557 IF( ilaenv( 10,
'SSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1558 $ ilaenv( 11,
'SSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 )
THEN
1569 IF( jtype.EQ.21 .AND. srel )
THEN
1571 abstol = unfl + unfl
1572 CALL sstemr(
'V',
'A', n, sd, se, vl, vu, il, iu,
1573 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1574 $ work, lwork, iwork( 2*n+1 ), lwork-2*n,
1576 IF( iinfo.NE.0 )
THEN
1577 WRITE( nounit, fmt = 9999 )
'SSTEMR(V,A,rel)',
1578 $ iinfo, n, jtype, ioldsd
1580 IF( iinfo.LT.0 )
THEN
1583 result( 27 ) = ulpinv
1590 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1595 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1596 $ ( abstol+abs( d4( j ) ) ) )
1599 result( 27 ) = temp1 / temp2
1601 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1602 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1611 abstol = unfl + unfl
1612 CALL sstemr(
'V',
'I', n, sd, se, vl, vu, il, iu,
1613 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1614 $ work, lwork, iwork( 2*n+1 ),
1615 $ lwork-2*n, iinfo )
1617 IF( iinfo.NE.0 )
THEN
1618 WRITE( nounit, fmt = 9999 )
'SSTEMR(V,I,rel)',
1619 $ iinfo, n, jtype, ioldsd
1621 IF( iinfo.LT.0 )
THEN
1624 result( 28 ) = ulpinv
1632 temp2 = two*( two*n-one )*ulp*
1633 $ ( one+eight*half**2 ) / ( one-half )**4
1637 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1638 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1641 result( 28 ) = temp1 / temp2
1654 CALL scopy( n, sd, 1, d5, 1 )
1656 $
CALL scopy( n-1, se, 1, work, 1 )
1657 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1661 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1662 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1668 CALL sstemr(
'V',
'I', n, d5, work, vl, vu, il, iu,
1669 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1670 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1671 $ liwork-2*n, iinfo )
1672 IF( iinfo.NE.0 )
THEN
1673 WRITE( nounit, fmt = 9999 )
'SSTEMR(V,I)', iinfo,
1676 IF( iinfo.LT.0 )
THEN
1679 result( 29 ) = ulpinv
1686 CALL sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1693 CALL scopy( n, sd, 1, d5, 1 )
1695 $
CALL scopy( n-1, se, 1, work, 1 )
1698 CALL sstemr(
'N',
'I', n, d5, work, vl, vu, il, iu,
1699 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1700 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1701 $ liwork-2*n, iinfo )
1702 IF( iinfo.NE.0 )
THEN
1703 WRITE( nounit, fmt = 9999 )
'SSTEMR(N,I)', iinfo,
1706 IF( iinfo.LT.0 )
THEN
1709 result( 31 ) = ulpinv
1719 DO 240 j = 1, iu - il + 1
1720 temp1 = max( temp1, abs( d1( j ) ),
1722 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1725 result( 31 ) = temp2 / max( unfl,
1726 $ ulp*max( temp1, temp2 ) )
1733 CALL scopy( n, sd, 1, d5, 1 )
1735 $
CALL scopy( n-1, se, 1, work, 1 )
1736 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1742 vl = d2( il ) - max( half*
1743 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1746 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1747 $ ulp*anorm, two*rtunfl )
1750 vu = d2( iu ) + max( half*
1751 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1754 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1755 $ ulp*anorm, two*rtunfl )
1762 CALL sstemr(
'V',
'V', n, d5, work, vl, vu, il, iu,
1763 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1764 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1765 $ liwork-2*n, iinfo )
1766 IF( iinfo.NE.0 )
THEN
1767 WRITE( nounit, fmt = 9999 )
'SSTEMR(V,V)', iinfo,
1770 IF( iinfo.LT.0 )
THEN
1773 result( 32 ) = ulpinv
1780 CALL sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1787 CALL scopy( n, sd, 1, d5, 1 )
1789 $
CALL scopy( n-1, se, 1, work, 1 )
1792 CALL sstemr(
'N',
'V', n, d5, work, vl, vu, il, iu,
1793 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1794 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1795 $ liwork-2*n, iinfo )
1796 IF( iinfo.NE.0 )
THEN
1797 WRITE( nounit, fmt = 9999 )
'SSTEMR(N,V)', iinfo,
1800 IF( iinfo.LT.0 )
THEN
1803 result( 34 ) = ulpinv
1813 DO 250 j = 1, iu - il + 1
1814 temp1 = max( temp1, abs( d1( j ) ),
1816 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1819 result( 34 ) = temp2 / max( unfl,
1820 $ ulp*max( temp1, temp2 ) )
1835 CALL scopy( n, sd, 1, d5, 1 )
1837 $
CALL scopy( n-1, se, 1, work, 1 )
1841 CALL sstemr(
'V',
'A', n, d5, work, vl, vu, il, iu,
1842 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1843 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1844 $ liwork-2*n, iinfo )
1845 IF( iinfo.NE.0 )
THEN
1846 WRITE( nounit, fmt = 9999 )
'SSTEMR(V,A)', iinfo, n,
1849 IF( iinfo.LT.0 )
THEN
1852 result( 35 ) = ulpinv
1859 CALL sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1866 CALL scopy( n, sd, 1, d5, 1 )
1868 $
CALL scopy( n-1, se, 1, work, 1 )
1871 CALL sstemr(
'N',
'A', n, d5, work, vl, vu, il, iu,
1872 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1873 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1874 $ liwork-2*n, iinfo )
1875 IF( iinfo.NE.0 )
THEN
1876 WRITE( nounit, fmt = 9999 )
'SSTEMR(N,A)', iinfo, n,
1879 IF( iinfo.LT.0 )
THEN
1882 result( 37 ) = ulpinv
1893 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1894 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1897 result( 37 ) = temp2 / max( unfl,
1898 $ ulp*max( temp1, temp2 ) )
1902 ntestt = ntestt + ntest
1909 DO 290 jr = 1, ntest
1910 IF( result( jr ).GE.thresh )
THEN
1915 IF( nerrs.EQ.0 )
THEN
1916 WRITE( nounit, fmt = 9998 )
'SST'
1917 WRITE( nounit, fmt = 9997 )
1918 WRITE( nounit, fmt = 9996 )
1919 WRITE( nounit, fmt = 9995 )
'Symmetric'
1920 WRITE( nounit, fmt = 9994 )
1924 WRITE( nounit, fmt = 9988 )
1927 WRITE( nounit, fmt = 9990 )n, ioldsd, jtype, jr,
1936 CALL slasum(
'SST', nounit, nerrs, ntestt )
1939 9999
FORMAT(
' SCHKST: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1940 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
1942 9998
FORMAT( / 1x, a3,
' -- Real Symmetric eigenvalue problem' )
1943 9997
FORMAT(
' Matrix types (see SCHKST for details): ' )
1945 9996
FORMAT( /
' Special Matrices:',
1946 $ /
' 1=Zero matrix. ',
1947 $
' 5=Diagonal: clustered entries.',
1948 $ /
' 2=Identity matrix. ',
1949 $
' 6=Diagonal: large, evenly spaced.',
1950 $ /
' 3=Diagonal: evenly spaced entries. ',
1951 $
' 7=Diagonal: small, evenly spaced.',
1952 $ /
' 4=Diagonal: geometr. spaced entries.' )
1953 9995
FORMAT(
' Dense ', a,
' Matrices:',
1954 $ /
' 8=Evenly spaced eigenvals. ',
1955 $
' 12=Small, evenly spaced eigenvals.',
1956 $ /
' 9=Geometrically spaced eigenvals. ',
1957 $
' 13=Matrix with random O(1) entries.',
1958 $ /
' 10=Clustered eigenvalues. ',
1959 $
' 14=Matrix with large random entries.',
1960 $ /
' 11=Large, evenly spaced eigenvals. ',
1961 $
' 15=Matrix with small random entries.' )
1962 9994
FORMAT(
' 16=Positive definite, evenly spaced eigenvalues',
1963 $ /
' 17=Positive definite, geometrically spaced eigenvlaues',
1964 $ /
' 18=Positive definite, clustered eigenvalues',
1965 $ /
' 19=Positive definite, small evenly spaced eigenvalues',
1966 $ /
' 20=Positive definite, large evenly spaced eigenvalues',
1967 $ /
' 21=Diagonally dominant tridiagonal, geometrically',
1968 $
' spaced eigenvalues' )
1970 9990
FORMAT(
' N=', i5,
', seed=', 4( i4,
',' ),
' type ', i2,
1971 $
', test(', i2,
')=', g10.3 )
1973 9988
FORMAT( /
'Test performed: see SCHKST for details.', / )
subroutine slabad(SMALL, LARGE)
SLABAD
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 slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine ssteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
SSTEQR
subroutine sstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
SSTEDC
subroutine ssterf(N, D, E, INFO)
SSTERF
subroutine sstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
SSTEBZ
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
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 ssptrd(UPLO, N, AP, D, E, TAU, INFO)
SSPTRD
subroutine sopgtr(UPLO, N, AP, TAU, Q, LDQ, WORK, INFO)
SOPGTR
subroutine sstemr(JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO)
SSTEMR
subroutine sstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
SSTEIN
subroutine sorgtr(UPLO, N, A, LDA, TAU, WORK, LWORK, INFO)
SORGTR
subroutine spteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
SPTEQR
subroutine ssytrd(UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO)
SSYTRD
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine sstech(N, A, B, EIG, TOL, WORK, INFO)
SSTECH
subroutine schkst(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, LWORK, IWORK, LIWORK, RESULT, INFO)
SCHKST
subroutine sstt21(N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RESULT)
SSTT21
subroutine sstt22(N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, LDWORK, RESULT)
SSTT22
subroutine ssyt21(ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, LDV, TAU, WORK, RESULT)
SSYT21
subroutine sspt21(ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, TAU, WORK, RESULT)
SSPT21
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM