610 SUBROUTINE schkst2stg( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
611 $ nounit, a, lda, ap, sd, se, d1, d2, d3, d4, d5,
612 $ wa1, wa2, wa3, wr, u, ldu, v, vp, tau, z, work,
613 $ lwork, iwork, liwork, result, info )
621 INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
627 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
628 REAL A( lda, * ), AP( * ), D1( * ), D2( * ),
629 $ d3( * ), d4( * ), d5( * ), result( * ),
630 $ sd( * ), se( * ), tau( * ), u( ldu, * ),
631 $ v( ldu, * ), vp( * ), wa1( * ), wa2( * ),
632 $ wa3( * ), work( * ), wr( * ), z( ldu, * )
638 REAL ZERO, ONE, TWO, EIGHT, TEN, HUN
639 parameter ( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
640 $ eight = 8.0e0, ten = 10.0e0, hun = 100.0e0 )
642 parameter ( half = one / two )
644 parameter ( maxtyp = 21 )
646 parameter ( srange = .false. )
648 parameter ( srel = .false. )
651 LOGICAL BADNN, TRYRAC
652 INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC,
653 $ jr, jsize, jtype, lgn, liwedc, log2ui, lwedc,
654 $ m, m2, m3, mtypes, n, nap, nblock, nerrs,
655 $ nmats, nmax, nsplit, ntest, ntestt, lh, lw
656 REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
657 $ rtunfl, temp1, temp2, temp3, temp4, ulp,
658 $ ulpinv, unfl, vl, vu
661 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
662 $ kmagn( maxtyp ), kmode( maxtyp ),
668 REAL SLAMCH, SLARND, SSXT1
669 EXTERNAL ilaenv, slamch, slarnd, ssxt1
679 INTRINSIC abs,
REAL, INT, LOG, MAX, MIN, SQRT
682 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
683 $ 8, 8, 9, 9, 9, 9, 9, 10 /
684 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
685 $ 2, 3, 1, 1, 1, 2, 3, 1 /
686 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
687 $ 0, 0, 4, 3, 1, 4, 4, 3 /
705 nmax = max( nmax, nn( j ) )
710 nblock = ilaenv( 1,
'SSYTRD',
'L', nmax, -1, -1, -1 )
711 nblock = min( nmax, max( 1, nblock ) )
715 IF( nsizes.LT.0 )
THEN
717 ELSE IF( badnn )
THEN
719 ELSE IF( ntypes.LT.0 )
THEN
721 ELSE IF( lda.LT.nmax )
THEN
723 ELSE IF( ldu.LT.nmax )
THEN
725 ELSE IF( 2*max( 2, nmax )**2.GT.lwork )
THEN
730 CALL xerbla(
'SCHKST2STG', -info )
736 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
741 unfl = slamch(
'Safe minimum' )
744 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
746 log2ui = int( log( ulpinv ) / log( two ) )
747 rtunfl = sqrt( unfl )
748 rtovfl = sqrt( ovfl )
753 iseed2( i ) = iseed( i )
758 DO 310 jsize = 1, nsizes
761 lgn = int( log(
REAL( N ) ) / log( TWO ) )
766 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
767 liwedc = 6 + 6*n + 5*n*lgn
772 nap = ( n*( n+1 ) ) / 2
773 aninv = one /
REAL( MAX( 1, N ) )
775 IF( nsizes.NE.1 )
THEN
776 mtypes = min( maxtyp, ntypes )
778 mtypes = min( maxtyp+1, ntypes )
781 DO 300 jtype = 1, mtypes
782 IF( .NOT.dotype( jtype ) )
788 ioldsd( j ) = iseed( j )
807 IF( mtypes.GT.maxtyp )
810 itype = ktype( jtype )
811 imode = kmode( jtype )
815 GO TO ( 40, 50, 60 )kmagn( jtype )
822 anorm = ( rtovfl*ulp )*aninv
826 anorm = rtunfl*n*ulpinv
831 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
833 IF( jtype.LE.15 )
THEN
836 cond = ulpinv*aninv / ten
843 IF( itype.EQ.1 )
THEN
846 ELSE IF( itype.EQ.2 )
THEN
854 ELSE IF( itype.EQ.4 )
THEN
858 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
859 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
863 ELSE IF( itype.EQ.5 )
THEN
867 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
868 $ anorm, n, n,
'N', a, lda, work( n+1 ),
871 ELSE IF( itype.EQ.7 )
THEN
875 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
876 $
'T',
'N', work( n+1 ), 1, one,
877 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
878 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
880 ELSE IF( itype.EQ.8 )
THEN
884 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
885 $
'T',
'N', work( n+1 ), 1, one,
886 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
887 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
889 ELSE IF( itype.EQ.9 )
THEN
893 CALL slatms( n, n,
'S', iseed,
'P', work, imode, cond,
894 $ anorm, n, n,
'N', a, lda, work( n+1 ),
897 ELSE IF( itype.EQ.10 )
THEN
901 CALL slatms( n, n,
'S', iseed,
'P', work, imode, cond,
902 $ anorm, 1, 1,
'N', a, lda, work( n+1 ),
905 temp1 = abs( a( i-1, i ) ) /
906 $ sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
907 IF( temp1.GT.half )
THEN
908 a( i-1, i ) = half*sqrt( abs( a( i-1, i-1 )*a( i,
910 a( i, i-1 ) = a( i-1, i )
919 IF( iinfo.NE.0 )
THEN
920 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
931 CALL slacpy(
'U', n, n, a, lda, v, ldu )
934 CALL ssytrd(
'U', n, v, ldu, sd, se, tau, work, lwork,
937 IF( iinfo.NE.0 )
THEN
938 WRITE( nounit, fmt = 9999 )
'SSYTRD(U)', iinfo, n, jtype,
941 IF( iinfo.LT.0 )
THEN
949 CALL slacpy(
'U', n, n, v, ldu, u, ldu )
952 CALL sorgtr(
'U', n, u, ldu, tau, work, lwork, iinfo )
953 IF( iinfo.NE.0 )
THEN
954 WRITE( nounit, fmt = 9999 )
'SORGTR(U)', iinfo, n, jtype,
957 IF( iinfo.LT.0 )
THEN
967 CALL ssyt21( 2,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
968 $ ldu, tau, work, result( 1 ) )
969 CALL ssyt21( 3,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
970 $ ldu, tau, work, result( 2 ) )
979 CALL scopy( n, sd, 1, d1, 1 )
981 $
CALL scopy( n-1, se, 1, work, 1 )
983 CALL ssteqr(
'N', n, d1, work, work( n+1 ), ldu,
984 $ work( n+1 ), iinfo )
985 IF( iinfo.NE.0 )
THEN
986 WRITE( nounit, fmt = 9999 )
'SSTEQR(N)', iinfo, n, jtype,
989 IF( iinfo.LT.0 )
THEN
1002 CALL slaset(
'Full', n, 1, zero, zero, sd, 1 )
1003 CALL slaset(
'Full', n, 1, zero, zero, se, 1 )
1004 CALL slacpy(
"U", n, n, a, lda, v, ldu )
1008 $ work, lh, work( lh+1 ), lw, iinfo )
1012 CALL scopy( n, sd, 1, d2, 1 )
1014 $
CALL scopy( n-1, se, 1, work, 1 )
1016 CALL ssteqr(
'N', n, d2, work, work( n+1 ), ldu,
1017 $ work( n+1 ), iinfo )
1018 IF( iinfo.NE.0 )
THEN
1019 WRITE( nounit, fmt = 9999 )
'SSTEQR(N)', iinfo, n, jtype,
1022 IF( iinfo.LT.0 )
THEN
1025 result( 3 ) = ulpinv
1035 CALL slaset(
'Full', n, 1, zero, zero, sd, 1 )
1036 CALL slaset(
'Full', n, 1, zero, zero, se, 1 )
1037 CALL slacpy(
"L", n, n, a, lda, v, ldu )
1039 $ work, lh, work( lh+1 ), lw, iinfo )
1043 CALL scopy( n, sd, 1, d3, 1 )
1045 $
CALL scopy( n-1, se, 1, work, 1 )
1047 CALL ssteqr(
'N', n, d3, work, work( n+1 ), ldu,
1048 $ work( n+1 ), iinfo )
1049 IF( iinfo.NE.0 )
THEN
1050 WRITE( nounit, fmt = 9999 )
'SSTEQR(N)', iinfo, n, jtype,
1053 IF( iinfo.LT.0 )
THEN
1056 result( 4 ) = ulpinv
1072 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1073 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1074 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1075 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1078 result( 3 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1079 result( 4 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1087 ap( i ) = a( jr, jc )
1093 CALL scopy( nap, ap, 1, vp, 1 )
1096 CALL ssptrd(
'U', n, vp, sd, se, tau, iinfo )
1098 IF( iinfo.NE.0 )
THEN
1099 WRITE( nounit, fmt = 9999 )
'SSPTRD(U)', iinfo, n, jtype,
1102 IF( iinfo.LT.0 )
THEN
1105 result( 5 ) = ulpinv
1111 CALL sopgtr(
'U', n, vp, tau, u, ldu, work, iinfo )
1112 IF( iinfo.NE.0 )
THEN
1113 WRITE( nounit, fmt = 9999 )
'SOPGTR(U)', iinfo, n, jtype,
1116 IF( iinfo.LT.0 )
THEN
1119 result( 6 ) = ulpinv
1126 CALL sspt21( 2,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1127 $ work, result( 5 ) )
1128 CALL sspt21( 3,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1129 $ work, result( 6 ) )
1137 ap( i ) = a( jr, jc )
1143 CALL scopy( nap, ap, 1, vp, 1 )
1146 CALL ssptrd(
'L', n, vp, sd, se, tau, iinfo )
1148 IF( iinfo.NE.0 )
THEN
1149 WRITE( nounit, fmt = 9999 )
'SSPTRD(L)', iinfo, n, jtype,
1152 IF( iinfo.LT.0 )
THEN
1155 result( 7 ) = ulpinv
1161 CALL sopgtr(
'L', n, vp, tau, u, ldu, work, iinfo )
1162 IF( iinfo.NE.0 )
THEN
1163 WRITE( nounit, fmt = 9999 )
'SOPGTR(L)', iinfo, n, jtype,
1166 IF( iinfo.LT.0 )
THEN
1169 result( 8 ) = ulpinv
1174 CALL sspt21( 2,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1175 $ work, result( 7 ) )
1176 CALL sspt21( 3,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1177 $ work, result( 8 ) )
1183 CALL scopy( n, sd, 1, d1, 1 )
1185 $
CALL scopy( n-1, se, 1, work, 1 )
1186 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1189 CALL ssteqr(
'V', n, d1, work, z, ldu, work( n+1 ), iinfo )
1190 IF( iinfo.NE.0 )
THEN
1191 WRITE( nounit, fmt = 9999 )
'SSTEQR(V)', iinfo, n, jtype,
1194 IF( iinfo.LT.0 )
THEN
1197 result( 9 ) = ulpinv
1204 CALL scopy( n, sd, 1, d2, 1 )
1206 $
CALL scopy( n-1, se, 1, work, 1 )
1209 CALL ssteqr(
'N', n, d2, work, work( n+1 ), ldu,
1210 $ work( n+1 ), iinfo )
1211 IF( iinfo.NE.0 )
THEN
1212 WRITE( nounit, fmt = 9999 )
'SSTEQR(N)', iinfo, n, jtype,
1215 IF( iinfo.LT.0 )
THEN
1218 result( 11 ) = ulpinv
1225 CALL scopy( n, sd, 1, d3, 1 )
1227 $
CALL scopy( n-1, se, 1, work, 1 )
1230 CALL ssterf( n, d3, work, iinfo )
1231 IF( iinfo.NE.0 )
THEN
1232 WRITE( nounit, fmt = 9999 )
'SSTERF', iinfo, n, jtype,
1235 IF( iinfo.LT.0 )
THEN
1238 result( 12 ) = ulpinv
1245 CALL sstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1256 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1257 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1258 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1259 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1262 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1263 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1269 temp1 = thresh*( half-ulp )
1271 DO 160 j = 0, log2ui
1272 CALL sstech( n, sd, se, d1, temp1, work, iinfo )
1279 result( 13 ) = temp1
1284 IF( jtype.GT.15 )
THEN
1288 CALL scopy( n, sd, 1, d4, 1 )
1290 $
CALL scopy( n-1, se, 1, work, 1 )
1291 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1294 CALL spteqr(
'V', n, d4, work, z, ldu, work( n+1 ),
1296 IF( iinfo.NE.0 )
THEN
1297 WRITE( nounit, fmt = 9999 )
'SPTEQR(V)', iinfo, n,
1300 IF( iinfo.LT.0 )
THEN
1303 result( 14 ) = ulpinv
1310 CALL sstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1315 CALL scopy( n, sd, 1, d5, 1 )
1317 $
CALL scopy( n-1, se, 1, work, 1 )
1320 CALL spteqr(
'N', n, d5, work, z, ldu, work( n+1 ),
1322 IF( iinfo.NE.0 )
THEN
1323 WRITE( nounit, fmt = 9999 )
'SPTEQR(N)', iinfo, n,
1326 IF( iinfo.LT.0 )
THEN
1329 result( 16 ) = ulpinv
1339 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1340 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1343 result( 16 ) = temp2 / max( unfl,
1344 $ hun*ulp*max( temp1, temp2 ) )
1360 IF( jtype.EQ.21 )
THEN
1362 abstol = unfl + unfl
1363 CALL sstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se,
1364 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1365 $ work, iwork( 2*n+1 ), iinfo )
1366 IF( iinfo.NE.0 )
THEN
1367 WRITE( nounit, fmt = 9999 )
'SSTEBZ(A,rel)', iinfo, n,
1370 IF( iinfo.LT.0 )
THEN
1373 result( 17 ) = ulpinv
1380 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1385 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1386 $ ( abstol+abs( d4( j ) ) ) )
1389 result( 17 ) = temp1 / temp2
1397 abstol = unfl + unfl
1398 CALL sstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se, m,
1399 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), work,
1400 $ iwork( 2*n+1 ), iinfo )
1401 IF( iinfo.NE.0 )
THEN
1402 WRITE( nounit, fmt = 9999 )
'SSTEBZ(A)', iinfo, n, jtype,
1405 IF( iinfo.LT.0 )
THEN
1408 result( 18 ) = ulpinv
1418 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1419 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1422 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1432 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1433 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1441 CALL sstebz(
'I',
'E', n, vl, vu, il, iu, abstol, sd, se,
1442 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1443 $ work, iwork( 2*n+1 ), iinfo )
1444 IF( iinfo.NE.0 )
THEN
1445 WRITE( nounit, fmt = 9999 )
'SSTEBZ(I)', iinfo, n, jtype,
1448 IF( iinfo.LT.0 )
THEN
1451 result( 19 ) = ulpinv
1461 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1462 $ ulp*anorm, two*rtunfl )
1464 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1465 $ ulp*anorm, two*rtunfl )
1468 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1469 $ ulp*anorm, two*rtunfl )
1471 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1472 $ ulp*anorm, two*rtunfl )
1479 CALL sstebz(
'V',
'E', n, vl, vu, il, iu, abstol, sd, se,
1480 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1481 $ work, iwork( 2*n+1 ), iinfo )
1482 IF( iinfo.NE.0 )
THEN
1483 WRITE( nounit, fmt = 9999 )
'SSTEBZ(V)', iinfo, n, jtype,
1486 IF( iinfo.LT.0 )
THEN
1489 result( 19 ) = ulpinv
1494 IF( m3.EQ.0 .AND. n.NE.0 )
THEN
1495 result( 19 ) = ulpinv
1501 temp1 = ssxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1502 temp2 = ssxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1504 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1509 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1516 CALL sstebz(
'A',
'B', n, vl, vu, il, iu, abstol, sd, se, m,
1517 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), work,
1518 $ iwork( 2*n+1 ), iinfo )
1519 IF( iinfo.NE.0 )
THEN
1520 WRITE( nounit, fmt = 9999 )
'SSTEBZ(A,B)', iinfo, n,
1523 IF( iinfo.LT.0 )
THEN
1526 result( 20 ) = ulpinv
1527 result( 21 ) = ulpinv
1532 CALL sstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1533 $ ldu, work, iwork( 2*n+1 ), iwork( 3*n+1 ),
1535 IF( iinfo.NE.0 )
THEN
1536 WRITE( nounit, fmt = 9999 )
'SSTEIN', iinfo, n, jtype,
1539 IF( iinfo.LT.0 )
THEN
1542 result( 20 ) = ulpinv
1543 result( 21 ) = ulpinv
1550 CALL sstt21( n, 0, sd, se, wa1, dumma, z, ldu, work,
1557 CALL scopy( n, sd, 1, d1, 1 )
1559 $
CALL scopy( n-1, se, 1, work, 1 )
1560 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1563 CALL sstedc(
'I', n, d1, work, z, ldu, work( n+1 ), lwedc-n,
1564 $ iwork, liwedc, iinfo )
1565 IF( iinfo.NE.0 )
THEN
1566 WRITE( nounit, fmt = 9999 )
'SSTEDC(I)', iinfo, n, jtype,
1569 IF( iinfo.LT.0 )
THEN
1572 result( 22 ) = ulpinv
1579 CALL sstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1586 CALL scopy( n, sd, 1, d1, 1 )
1588 $
CALL scopy( n-1, se, 1, work, 1 )
1589 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1592 CALL sstedc(
'V', n, d1, work, z, ldu, work( n+1 ), lwedc-n,
1593 $ iwork, liwedc, iinfo )
1594 IF( iinfo.NE.0 )
THEN
1595 WRITE( nounit, fmt = 9999 )
'SSTEDC(V)', iinfo, n, jtype,
1598 IF( iinfo.LT.0 )
THEN
1601 result( 24 ) = ulpinv
1608 CALL sstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1615 CALL scopy( n, sd, 1, d2, 1 )
1617 $
CALL scopy( n-1, se, 1, work, 1 )
1618 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1621 CALL sstedc(
'N', n, d2, work, z, ldu, work( n+1 ), lwedc-n,
1622 $ iwork, liwedc, iinfo )
1623 IF( iinfo.NE.0 )
THEN
1624 WRITE( nounit, fmt = 9999 )
'SSTEDC(N)', iinfo, n, jtype,
1627 IF( iinfo.LT.0 )
THEN
1630 result( 26 ) = ulpinv
1641 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1642 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1645 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1649 IF( ilaenv( 10,
'SSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1650 $ ilaenv( 11,
'SSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 )
THEN
1661 IF( jtype.EQ.21 .AND. srel )
THEN
1663 abstol = unfl + unfl
1664 CALL sstemr(
'V',
'A', n, sd, se, vl, vu, il, iu,
1665 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1666 $ work, lwork, iwork( 2*n+1 ), lwork-2*n,
1668 IF( iinfo.NE.0 )
THEN
1669 WRITE( nounit, fmt = 9999 )
'SSTEMR(V,A,rel)',
1670 $ iinfo, n, jtype, ioldsd
1672 IF( iinfo.LT.0 )
THEN
1675 result( 27 ) = ulpinv
1682 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1687 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1688 $ ( abstol+abs( d4( j ) ) ) )
1691 result( 27 ) = temp1 / temp2
1693 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1694 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1703 abstol = unfl + unfl
1704 CALL sstemr(
'V',
'I', n, sd, se, vl, vu, il, iu,
1705 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1706 $ work, lwork, iwork( 2*n+1 ),
1707 $ lwork-2*n, iinfo )
1709 IF( iinfo.NE.0 )
THEN
1710 WRITE( nounit, fmt = 9999 )
'SSTEMR(V,I,rel)',
1711 $ iinfo, n, jtype, ioldsd
1713 IF( iinfo.LT.0 )
THEN
1716 result( 28 ) = ulpinv
1724 temp2 = two*( two*n-one )*ulp*
1725 $ ( one+eight*half**2 ) / ( one-half )**4
1729 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1730 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1733 result( 28 ) = temp1 / temp2
1746 CALL scopy( n, sd, 1, d5, 1 )
1748 $
CALL scopy( n-1, se, 1, work, 1 )
1749 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1753 il = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1754 iu = 1 + ( n-1 )*int( slarnd( 1, iseed2 ) )
1760 CALL sstemr(
'V',
'I', n, d5, work, vl, vu, il, iu,
1761 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1762 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1763 $ liwork-2*n, iinfo )
1764 IF( iinfo.NE.0 )
THEN
1765 WRITE( nounit, fmt = 9999 )
'SSTEMR(V,I)', iinfo,
1768 IF( iinfo.LT.0 )
THEN
1771 result( 29 ) = ulpinv
1778 CALL sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1785 CALL scopy( n, sd, 1, d5, 1 )
1787 $
CALL scopy( n-1, se, 1, work, 1 )
1790 CALL sstemr(
'N',
'I', n, d5, work, vl, vu, il, iu,
1791 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1792 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1793 $ liwork-2*n, iinfo )
1794 IF( iinfo.NE.0 )
THEN
1795 WRITE( nounit, fmt = 9999 )
'SSTEMR(N,I)', iinfo,
1798 IF( iinfo.LT.0 )
THEN
1801 result( 31 ) = ulpinv
1811 DO 240 j = 1, iu - il + 1
1812 temp1 = max( temp1, abs( d1( j ) ),
1814 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1817 result( 31 ) = temp2 / max( unfl,
1818 $ ulp*max( temp1, temp2 ) )
1825 CALL scopy( n, sd, 1, d5, 1 )
1827 $
CALL scopy( n-1, se, 1, work, 1 )
1828 CALL slaset(
'Full', n, n, zero, one, z, ldu )
1834 vl = d2( il ) - max( half*
1835 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1838 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1839 $ ulp*anorm, two*rtunfl )
1842 vu = d2( iu ) + max( half*
1843 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1846 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1847 $ ulp*anorm, two*rtunfl )
1854 CALL sstemr(
'V',
'V', n, d5, work, vl, vu, il, iu,
1855 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1856 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1857 $ liwork-2*n, iinfo )
1858 IF( iinfo.NE.0 )
THEN
1859 WRITE( nounit, fmt = 9999 )
'SSTEMR(V,V)', iinfo,
1862 IF( iinfo.LT.0 )
THEN
1865 result( 32 ) = ulpinv
1872 CALL sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1879 CALL scopy( n, sd, 1, d5, 1 )
1881 $
CALL scopy( n-1, se, 1, work, 1 )
1884 CALL sstemr(
'N',
'V', n, d5, work, vl, vu, il, iu,
1885 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1886 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1887 $ liwork-2*n, iinfo )
1888 IF( iinfo.NE.0 )
THEN
1889 WRITE( nounit, fmt = 9999 )
'SSTEMR(N,V)', iinfo,
1892 IF( iinfo.LT.0 )
THEN
1895 result( 34 ) = ulpinv
1905 DO 250 j = 1, iu - il + 1
1906 temp1 = max( temp1, abs( d1( j ) ),
1908 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1911 result( 34 ) = temp2 / max( unfl,
1912 $ ulp*max( temp1, temp2 ) )
1927 CALL scopy( n, sd, 1, d5, 1 )
1929 $
CALL scopy( n-1, se, 1, work, 1 )
1933 CALL sstemr(
'V',
'A', n, d5, work, vl, vu, il, iu,
1934 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1935 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1936 $ liwork-2*n, iinfo )
1937 IF( iinfo.NE.0 )
THEN
1938 WRITE( nounit, fmt = 9999 )
'SSTEMR(V,A)', iinfo, n,
1941 IF( iinfo.LT.0 )
THEN
1944 result( 35 ) = ulpinv
1951 CALL sstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1958 CALL scopy( n, sd, 1, d5, 1 )
1960 $
CALL scopy( n-1, se, 1, work, 1 )
1963 CALL sstemr(
'N',
'A', n, d5, work, vl, vu, il, iu,
1964 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1965 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1966 $ liwork-2*n, iinfo )
1967 IF( iinfo.NE.0 )
THEN
1968 WRITE( nounit, fmt = 9999 )
'SSTEMR(N,A)', iinfo, n,
1971 IF( iinfo.LT.0 )
THEN
1974 result( 37 ) = ulpinv
1985 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1986 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1989 result( 37 ) = temp2 / max( unfl,
1990 $ ulp*max( temp1, temp2 ) )
1994 ntestt = ntestt + ntest
2001 DO 290 jr = 1, ntest
2002 IF( result( jr ).GE.thresh )
THEN
2007 IF( nerrs.EQ.0 )
THEN
2008 WRITE( nounit, fmt = 9998 )
'SST'
2009 WRITE( nounit, fmt = 9997 )
2010 WRITE( nounit, fmt = 9996 )
2011 WRITE( nounit, fmt = 9995 )
'Symmetric'
2012 WRITE( nounit, fmt = 9994 )
2016 WRITE( nounit, fmt = 9988 )
2019 WRITE( nounit, fmt = 9990 )n, ioldsd, jtype, jr,
2028 CALL slasum(
'SST', nounit, nerrs, ntestt )
2031 9999
FORMAT(
' SCHKST2STG: ', a,
' returned INFO=', i6,
'.', / 9x,
2032 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
2034 9998
FORMAT( / 1x, a3,
' -- Real Symmetric eigenvalue problem' )
2035 9997
FORMAT(
' Matrix types (see SCHKST2STG for details): ' )
2037 9996
FORMAT( /
' Special Matrices:',
2038 $ /
' 1=Zero matrix. ',
2039 $
' 5=Diagonal: clustered entries.',
2040 $ /
' 2=Identity matrix. ',
2041 $
' 6=Diagonal: large, evenly spaced.',
2042 $ /
' 3=Diagonal: evenly spaced entries. ',
2043 $
' 7=Diagonal: small, evenly spaced.',
2044 $ /
' 4=Diagonal: geometr. spaced entries.' )
2045 9995
FORMAT(
' Dense ', a,
' Matrices:',
2046 $ /
' 8=Evenly spaced eigenvals. ',
2047 $
' 12=Small, evenly spaced eigenvals.',
2048 $ /
' 9=Geometrically spaced eigenvals. ',
2049 $
' 13=Matrix with random O(1) entries.',
2050 $ /
' 10=Clustered eigenvalues. ',
2051 $
' 14=Matrix with large random entries.',
2052 $ /
' 11=Large, evenly spaced eigenvals. ',
2053 $
' 15=Matrix with small random entries.' )
2054 9994
FORMAT(
' 16=Positive definite, evenly spaced eigenvalues',
2055 $ /
' 17=Positive definite, geometrically spaced eigenvlaues',
2056 $ /
' 18=Positive definite, clustered eigenvalues',
2057 $ /
' 19=Positive definite, small evenly spaced eigenvalues',
2058 $ /
' 20=Positive definite, large evenly spaced eigenvalues',
2059 $ /
' 21=Diagonally dominant tridiagonal, geometrically',
2060 $
' spaced eigenvalues' )
2062 9990
FORMAT(
' N=', i5,
', seed=', 4( i4,
',' ),
' type ', i2,
2063 $
', test(', i2,
')=', g10.3 )
2065 9988
FORMAT( /
'Test performed: see SCHKST2STG for details.', / )
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 sstt22(N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, LDWORK, RESULT)
SSTT22
subroutine ssptrd(UPLO, N, AP, D, E, TAU, INFO)
SSPTRD
subroutine ssteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
SSTEQR
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 sopgtr(UPLO, N, AP, TAU, Q, LDQ, WORK, INFO)
SOPGTR
subroutine ssytrd(UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO)
SSYTRD
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine sstech(N, A, B, EIG, TOL, WORK, INFO)
SSTECH
subroutine sstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
SSTEIN
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine spteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
SPTEQR
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 sspt21(ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, TAU, WORK, RESULT)
SSPT21
subroutine ssyt21(ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, LDV, TAU, WORK, RESULT)
SSYT21
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine sstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
SSTEBZ
subroutine ssytrd_2stage(VECT, UPLO, N, A, LDA, D, E, TAU, HOUS2, LHOUS2, WORK, LWORK, INFO)
SSYTRD_2STAGE
subroutine schkst2stg(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)
SCHKST2STG
subroutine sstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
SSTEDC
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine ssterf(N, D, E, INFO)
SSTERF
subroutine sorgtr(UPLO, N, A, LDA, TAU, WORK, LWORK, INFO)
SORGTR
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine sstt21(N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RESULT)
SSTT21