610 SUBROUTINE dchkst2stg( 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,
623 DOUBLE PRECISION THRESH
627 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
628 DOUBLE PRECISION 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 DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN
639 parameter ( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
640 $ eight = 8.0d0, ten = 10.0d0, hun = 100.0d0 )
641 DOUBLE PRECISION HALF
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 DOUBLE PRECISION 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 ),
664 DOUBLE PRECISION DUMMA( 1 )
668 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
669 EXTERNAL ilaenv, dlamch, dlarnd, dsxt1
679 INTRINSIC abs, dble, 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,
'DSYTRD',
'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(
'DCHKST2STG', -info )
736 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
741 unfl = dlamch(
'Safe minimum' )
744 ulp = dlamch(
'Epsilon' )*dlamch(
'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( dble( 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 / dble( 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 dlaset(
'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 dlatms( 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 dlatms( 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 dlatmr( 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 dlatmr( 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 dlatms( 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 dlatms( 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 dlacpy(
'U', n, n, a, lda, v, ldu )
934 CALL dsytrd(
'U', n, v, ldu, sd, se, tau, work, lwork,
937 IF( iinfo.NE.0 )
THEN
938 WRITE( nounit, fmt = 9999 )
'DSYTRD(U)', iinfo, n, jtype,
941 IF( iinfo.LT.0 )
THEN
949 CALL dlacpy(
'U', n, n, v, ldu, u, ldu )
952 CALL dorgtr(
'U', n, u, ldu, tau, work, lwork, iinfo )
953 IF( iinfo.NE.0 )
THEN
954 WRITE( nounit, fmt = 9999 )
'DORGTR(U)', iinfo, n, jtype,
957 IF( iinfo.LT.0 )
THEN
967 CALL dsyt21( 2,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
968 $ ldu, tau, work, result( 1 ) )
969 CALL dsyt21( 3,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
970 $ ldu, tau, work, result( 2 ) )
979 CALL dcopy( n, sd, 1, d1, 1 )
981 $
CALL dcopy( n-1, se, 1, work, 1 )
983 CALL dsteqr(
'N', n, d1, work, work( n+1 ), ldu,
984 $ work( n+1 ), iinfo )
985 IF( iinfo.NE.0 )
THEN
986 WRITE( nounit, fmt = 9999 )
'DSTEQR(N)', iinfo, n, jtype,
989 IF( iinfo.LT.0 )
THEN
1002 CALL dlaset(
'Full', n, 1, zero, zero, sd, 1 )
1003 CALL dlaset(
'Full', n, 1, zero, zero, se, 1 )
1004 CALL dlacpy(
"U", n, n, a, lda, v, ldu )
1008 $ work, lh, work( lh+1 ), lw, iinfo )
1012 CALL dcopy( n, sd, 1, d2, 1 )
1014 $
CALL dcopy( n-1, se, 1, work, 1 )
1016 CALL dsteqr(
'N', n, d2, work, work( n+1 ), ldu,
1017 $ work( n+1 ), iinfo )
1018 IF( iinfo.NE.0 )
THEN
1019 WRITE( nounit, fmt = 9999 )
'DSTEQR(N)', iinfo, n, jtype,
1022 IF( iinfo.LT.0 )
THEN
1025 result( 3 ) = ulpinv
1035 CALL dlaset(
'Full', n, 1, zero, zero, sd, 1 )
1036 CALL dlaset(
'Full', n, 1, zero, zero, se, 1 )
1037 CALL dlacpy(
"L", n, n, a, lda, v, ldu )
1039 $ work, lh, work( lh+1 ), lw, iinfo )
1043 CALL dcopy( n, sd, 1, d3, 1 )
1045 $
CALL dcopy( n-1, se, 1, work, 1 )
1047 CALL dsteqr(
'N', n, d3, work, work( n+1 ), ldu,
1048 $ work( n+1 ), iinfo )
1049 IF( iinfo.NE.0 )
THEN
1050 WRITE( nounit, fmt = 9999 )
'DSTEQR(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 dcopy( nap, ap, 1, vp, 1 )
1096 CALL dsptrd(
'U', n, vp, sd, se, tau, iinfo )
1098 IF( iinfo.NE.0 )
THEN
1099 WRITE( nounit, fmt = 9999 )
'DSPTRD(U)', iinfo, n, jtype,
1102 IF( iinfo.LT.0 )
THEN
1105 result( 5 ) = ulpinv
1111 CALL dopgtr(
'U', n, vp, tau, u, ldu, work, iinfo )
1112 IF( iinfo.NE.0 )
THEN
1113 WRITE( nounit, fmt = 9999 )
'DOPGTR(U)', iinfo, n, jtype,
1116 IF( iinfo.LT.0 )
THEN
1119 result( 6 ) = ulpinv
1126 CALL dspt21( 2,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1127 $ work, result( 5 ) )
1128 CALL dspt21( 3,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1129 $ work, result( 6 ) )
1137 ap( i ) = a( jr, jc )
1143 CALL dcopy( nap, ap, 1, vp, 1 )
1146 CALL dsptrd(
'L', n, vp, sd, se, tau, iinfo )
1148 IF( iinfo.NE.0 )
THEN
1149 WRITE( nounit, fmt = 9999 )
'DSPTRD(L)', iinfo, n, jtype,
1152 IF( iinfo.LT.0 )
THEN
1155 result( 7 ) = ulpinv
1161 CALL dopgtr(
'L', n, vp, tau, u, ldu, work, iinfo )
1162 IF( iinfo.NE.0 )
THEN
1163 WRITE( nounit, fmt = 9999 )
'DOPGTR(L)', iinfo, n, jtype,
1166 IF( iinfo.LT.0 )
THEN
1169 result( 8 ) = ulpinv
1174 CALL dspt21( 2,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1175 $ work, result( 7 ) )
1176 CALL dspt21( 3,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1177 $ work, result( 8 ) )
1183 CALL dcopy( n, sd, 1, d1, 1 )
1185 $
CALL dcopy( n-1, se, 1, work, 1 )
1186 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1189 CALL dsteqr(
'V', n, d1, work, z, ldu, work( n+1 ), iinfo )
1190 IF( iinfo.NE.0 )
THEN
1191 WRITE( nounit, fmt = 9999 )
'DSTEQR(V)', iinfo, n, jtype,
1194 IF( iinfo.LT.0 )
THEN
1197 result( 9 ) = ulpinv
1204 CALL dcopy( n, sd, 1, d2, 1 )
1206 $
CALL dcopy( n-1, se, 1, work, 1 )
1209 CALL dsteqr(
'N', n, d2, work, work( n+1 ), ldu,
1210 $ work( n+1 ), iinfo )
1211 IF( iinfo.NE.0 )
THEN
1212 WRITE( nounit, fmt = 9999 )
'DSTEQR(N)', iinfo, n, jtype,
1215 IF( iinfo.LT.0 )
THEN
1218 result( 11 ) = ulpinv
1225 CALL dcopy( n, sd, 1, d3, 1 )
1227 $
CALL dcopy( n-1, se, 1, work, 1 )
1230 CALL dsterf( n, d3, work, iinfo )
1231 IF( iinfo.NE.0 )
THEN
1232 WRITE( nounit, fmt = 9999 )
'DSTERF', iinfo, n, jtype,
1235 IF( iinfo.LT.0 )
THEN
1238 result( 12 ) = ulpinv
1245 CALL dstt21( 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 dstech( n, sd, se, d1, temp1, work, iinfo )
1279 result( 13 ) = temp1
1284 IF( jtype.GT.15 )
THEN
1288 CALL dcopy( n, sd, 1, d4, 1 )
1290 $
CALL dcopy( n-1, se, 1, work, 1 )
1291 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1294 CALL dpteqr(
'V', n, d4, work, z, ldu, work( n+1 ),
1296 IF( iinfo.NE.0 )
THEN
1297 WRITE( nounit, fmt = 9999 )
'DPTEQR(V)', iinfo, n,
1300 IF( iinfo.LT.0 )
THEN
1303 result( 14 ) = ulpinv
1310 CALL dstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1315 CALL dcopy( n, sd, 1, d5, 1 )
1317 $
CALL dcopy( n-1, se, 1, work, 1 )
1320 CALL dpteqr(
'N', n, d5, work, z, ldu, work( n+1 ),
1322 IF( iinfo.NE.0 )
THEN
1323 WRITE( nounit, fmt = 9999 )
'DPTEQR(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 dstebz(
'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 )
'DSTEBZ(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 dstebz(
'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 )
'DSTEBZ(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( dlarnd( 1, iseed2 ) )
1433 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1441 CALL dstebz(
'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 )
'DSTEBZ(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 dstebz(
'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 )
'DSTEBZ(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 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1502 temp2 = dsxt1( 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 dstebz(
'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 )
'DSTEBZ(A,B)', iinfo, n,
1523 IF( iinfo.LT.0 )
THEN
1526 result( 20 ) = ulpinv
1527 result( 21 ) = ulpinv
1532 CALL dstein( 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 )
'DSTEIN', iinfo, n, jtype,
1539 IF( iinfo.LT.0 )
THEN
1542 result( 20 ) = ulpinv
1543 result( 21 ) = ulpinv
1550 CALL dstt21( n, 0, sd, se, wa1, dumma, z, ldu, work,
1557 CALL dcopy( n, sd, 1, d1, 1 )
1559 $
CALL dcopy( n-1, se, 1, work, 1 )
1560 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1563 CALL dstedc(
'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 )
'DSTEDC(I)', iinfo, n, jtype,
1569 IF( iinfo.LT.0 )
THEN
1572 result( 22 ) = ulpinv
1579 CALL dstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1586 CALL dcopy( n, sd, 1, d1, 1 )
1588 $
CALL dcopy( n-1, se, 1, work, 1 )
1589 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1592 CALL dstedc(
'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 )
'DSTEDC(V)', iinfo, n, jtype,
1598 IF( iinfo.LT.0 )
THEN
1601 result( 24 ) = ulpinv
1608 CALL dstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1615 CALL dcopy( n, sd, 1, d2, 1 )
1617 $
CALL dcopy( n-1, se, 1, work, 1 )
1618 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1621 CALL dstedc(
'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 )
'DSTEDC(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,
'DSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1650 $ ilaenv( 11,
'DSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 )
THEN
1661 IF( jtype.EQ.21 .AND. srel )
THEN
1663 abstol = unfl + unfl
1664 CALL dstemr(
'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 )
'DSTEMR(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( dlarnd( 1, iseed2 ) )
1694 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1703 abstol = unfl + unfl
1704 CALL dstemr(
'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 )
'DSTEMR(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 dcopy( n, sd, 1, d5, 1 )
1748 $
CALL dcopy( n-1, se, 1, work, 1 )
1749 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1753 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1754 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1760 CALL dstemr(
'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 )
'DSTEMR(V,I)', iinfo,
1768 IF( iinfo.LT.0 )
THEN
1771 result( 29 ) = ulpinv
1778 CALL dstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1785 CALL dcopy( n, sd, 1, d5, 1 )
1787 $
CALL dcopy( n-1, se, 1, work, 1 )
1790 CALL dstemr(
'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 )
'DSTEMR(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 dcopy( n, sd, 1, d5, 1 )
1827 $
CALL dcopy( n-1, se, 1, work, 1 )
1828 CALL dlaset(
'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 dstemr(
'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 )
'DSTEMR(V,V)', iinfo,
1862 IF( iinfo.LT.0 )
THEN
1865 result( 32 ) = ulpinv
1872 CALL dstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1879 CALL dcopy( n, sd, 1, d5, 1 )
1881 $
CALL dcopy( n-1, se, 1, work, 1 )
1884 CALL dstemr(
'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 )
'DSTEMR(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 dcopy( n, sd, 1, d5, 1 )
1929 $
CALL dcopy( n-1, se, 1, work, 1 )
1933 CALL dstemr(
'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 )
'DSTEMR(V,A)', iinfo, n,
1941 IF( iinfo.LT.0 )
THEN
1944 result( 35 ) = ulpinv
1951 CALL dstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1958 CALL dcopy( n, sd, 1, d5, 1 )
1960 $
CALL dcopy( n-1, se, 1, work, 1 )
1963 CALL dstemr(
'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 )
'DSTEMR(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 )
'DST'
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 dlasum(
'DST', nounit, nerrs, ntestt )
2031 9999
FORMAT(
' DCHKST2STG: ', 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 DCHKST2STG 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 DCHKST2STG for details.', / )
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
subroutine dsteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
DSTEQR
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dsytrd(UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO)
DSYTRD
subroutine dlatmr(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)
DLATMR
subroutine dstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
DSTEIN
subroutine dsterf(N, D, E, INFO)
DSTERF
subroutine dpteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
DPTEQR
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
DSTEBZ
subroutine dstt22(N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, LDWORK, RESULT)
DSTT22
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dspt21(ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, TAU, WORK, RESULT)
DSPT21
subroutine dsptrd(UPLO, N, AP, D, E, TAU, INFO)
DSPTRD
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dstech(N, A, B, EIG, TOL, WORK, INFO)
DSTECH
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine dstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSTEDC
subroutine dchkst2stg(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)
DCHKST2STG
subroutine dsyt21(ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, LDV, TAU, WORK, RESULT)
DSYT21
subroutine dstt21(N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RESULT)
DSTT21
subroutine dorgtr(UPLO, N, A, LDA, TAU, WORK, LWORK, INFO)
DORGTR
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dstemr(JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO)
DSTEMR
subroutine dopgtr(UPLO, N, AP, TAU, Q, LDQ, WORK, INFO)
DOPGTR
subroutine dsytrd_2stage(VECT, UPLO, N, A, LDA, D, E, TAU, HOUS2, LHOUS2, WORK, LWORK, INFO)
DSYTRD_2STAGE