589 SUBROUTINE dchkst( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
590 $ nounit, a, lda, ap, sd, se, d1, d2, d3, d4, d5,
591 $ wa1, wa2, wa3, wr, u, ldu, v, vp, tau, z, work,
592 $ lwork, iwork, liwork, result, info )
600 INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
602 DOUBLE PRECISION THRESH
606 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
607 DOUBLE PRECISION A( lda, * ), AP( * ), D1( * ), D2( * ),
608 $ d3( * ), d4( * ), d5( * ), result( * ),
609 $ sd( * ), se( * ), tau( * ), u( ldu, * ),
610 $ v( ldu, * ), vp( * ), wa1( * ), wa2( * ),
611 $ wa3( * ), work( * ), wr( * ), z( ldu, * )
617 DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN
618 parameter ( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
619 $ eight = 8.0d0, ten = 10.0d0, hun = 100.0d0 )
620 DOUBLE PRECISION HALF
621 parameter ( half = one / two )
623 parameter ( maxtyp = 21 )
625 parameter ( srange = .false. )
627 parameter ( srel = .false. )
630 LOGICAL BADNN, TRYRAC
631 INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC,
632 $ jr, jsize, jtype, lgn, liwedc, log2ui, lwedc,
633 $ m, m2, m3, mtypes, n, nap, nblock, nerrs,
634 $ nmats, nmax, nsplit, ntest, ntestt
635 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
636 $ rtunfl, temp1, temp2, temp3, temp4, ulp,
637 $ ulpinv, unfl, vl, vu
640 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
641 $ kmagn( maxtyp ), kmode( maxtyp ),
643 DOUBLE PRECISION DUMMA( 1 )
647 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
648 EXTERNAL ilaenv, dlamch, dlarnd, dsxt1
657 INTRINSIC abs, dble, int, log, max, min, sqrt
660 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
661 $ 8, 8, 9, 9, 9, 9, 9, 10 /
662 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
663 $ 2, 3, 1, 1, 1, 2, 3, 1 /
664 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
665 $ 0, 0, 4, 3, 1, 4, 4, 3 /
683 nmax = max( nmax, nn( j ) )
688 nblock = ilaenv( 1,
'DSYTRD',
'L', nmax, -1, -1, -1 )
689 nblock = min( nmax, max( 1, nblock ) )
693 IF( nsizes.LT.0 )
THEN
695 ELSE IF( badnn )
THEN
697 ELSE IF( ntypes.LT.0 )
THEN
699 ELSE IF( lda.LT.nmax )
THEN
701 ELSE IF( ldu.LT.nmax )
THEN
703 ELSE IF( 2*max( 2, nmax )**2.GT.lwork )
THEN
708 CALL xerbla(
'DCHKST', -info )
714 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
719 unfl = dlamch(
'Safe minimum' )
722 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
724 log2ui = int( log( ulpinv ) / log( two ) )
725 rtunfl = sqrt( unfl )
726 rtovfl = sqrt( ovfl )
731 iseed2( i ) = iseed( i )
736 DO 310 jsize = 1, nsizes
739 lgn = int( log( dble( n ) ) / log( two ) )
744 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
745 liwedc = 6 + 6*n + 5*n*lgn
750 nap = ( n*( n+1 ) ) / 2
751 aninv = one / dble( max( 1, n ) )
753 IF( nsizes.NE.1 )
THEN
754 mtypes = min( maxtyp, ntypes )
756 mtypes = min( maxtyp+1, ntypes )
759 DO 300 jtype = 1, mtypes
760 IF( .NOT.dotype( jtype ) )
766 ioldsd( j ) = iseed( j )
785 IF( mtypes.GT.maxtyp )
788 itype = ktype( jtype )
789 imode = kmode( jtype )
793 GO TO ( 40, 50, 60 )kmagn( jtype )
800 anorm = ( rtovfl*ulp )*aninv
804 anorm = rtunfl*n*ulpinv
809 CALL dlaset(
'Full', lda, n, zero, zero, a, lda )
811 IF( jtype.LE.15 )
THEN
814 cond = ulpinv*aninv / ten
821 IF( itype.EQ.1 )
THEN
824 ELSE IF( itype.EQ.2 )
THEN
832 ELSE IF( itype.EQ.4 )
THEN
836 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
837 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
841 ELSE IF( itype.EQ.5 )
THEN
845 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
846 $ anorm, n, n,
'N', a, lda, work( n+1 ),
849 ELSE IF( itype.EQ.7 )
THEN
853 CALL dlatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
854 $
'T',
'N', work( n+1 ), 1, one,
855 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
856 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
858 ELSE IF( itype.EQ.8 )
THEN
862 CALL dlatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
863 $
'T',
'N', work( n+1 ), 1, one,
864 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
865 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
867 ELSE IF( itype.EQ.9 )
THEN
871 CALL dlatms( n, n,
'S', iseed,
'P', work, imode, cond,
872 $ anorm, n, n,
'N', a, lda, work( n+1 ),
875 ELSE IF( itype.EQ.10 )
THEN
879 CALL dlatms( n, n,
'S', iseed,
'P', work, imode, cond,
880 $ anorm, 1, 1,
'N', a, lda, work( n+1 ),
883 temp1 = abs( a( i-1, i ) ) /
884 $ sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
885 IF( temp1.GT.half )
THEN
886 a( i-1, i ) = half*sqrt( abs( a( i-1, i-1 )*a( i,
888 a( i, i-1 ) = a( i-1, i )
897 IF( iinfo.NE.0 )
THEN
898 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
909 CALL dlacpy(
'U', n, n, a, lda, v, ldu )
912 CALL dsytrd(
'U', n, v, ldu, sd, se, tau, work, lwork,
915 IF( iinfo.NE.0 )
THEN
916 WRITE( nounit, fmt = 9999 )
'DSYTRD(U)', iinfo, n, jtype,
919 IF( iinfo.LT.0 )
THEN
927 CALL dlacpy(
'U', n, n, v, ldu, u, ldu )
930 CALL dorgtr(
'U', n, u, ldu, tau, work, lwork, iinfo )
931 IF( iinfo.NE.0 )
THEN
932 WRITE( nounit, fmt = 9999 )
'DORGTR(U)', iinfo, n, jtype,
935 IF( iinfo.LT.0 )
THEN
945 CALL dsyt21( 2,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
946 $ ldu, tau, work, result( 1 ) )
947 CALL dsyt21( 3,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
948 $ ldu, tau, work, result( 2 ) )
953 CALL dlacpy(
'L', n, n, a, lda, v, ldu )
956 CALL dsytrd(
'L', n, v, ldu, sd, se, tau, work, lwork,
959 IF( iinfo.NE.0 )
THEN
960 WRITE( nounit, fmt = 9999 )
'DSYTRD(L)', iinfo, n, jtype,
963 IF( iinfo.LT.0 )
THEN
971 CALL dlacpy(
'L', n, n, v, ldu, u, ldu )
974 CALL dorgtr(
'L', n, u, ldu, tau, work, lwork, iinfo )
975 IF( iinfo.NE.0 )
THEN
976 WRITE( nounit, fmt = 9999 )
'DORGTR(L)', iinfo, n, jtype,
979 IF( iinfo.LT.0 )
THEN
987 CALL dsyt21( 2,
'Lower', n, 1, a, lda, sd, se, u, ldu, v,
988 $ ldu, tau, work, result( 3 ) )
989 CALL dsyt21( 3,
'Lower', n, 1, a, lda, sd, se, u, ldu, v,
990 $ ldu, tau, work, result( 4 ) )
998 ap( i ) = a( jr, jc )
1004 CALL dcopy( nap, ap, 1, vp, 1 )
1007 CALL dsptrd(
'U', n, vp, sd, se, tau, iinfo )
1009 IF( iinfo.NE.0 )
THEN
1010 WRITE( nounit, fmt = 9999 )
'DSPTRD(U)', iinfo, n, jtype,
1013 IF( iinfo.LT.0 )
THEN
1016 result( 5 ) = ulpinv
1022 CALL dopgtr(
'U', n, vp, tau, u, ldu, work, iinfo )
1023 IF( iinfo.NE.0 )
THEN
1024 WRITE( nounit, fmt = 9999 )
'DOPGTR(U)', iinfo, n, jtype,
1027 IF( iinfo.LT.0 )
THEN
1030 result( 6 ) = ulpinv
1037 CALL dspt21( 2,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1038 $ work, result( 5 ) )
1039 CALL dspt21( 3,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1040 $ work, result( 6 ) )
1048 ap( i ) = a( jr, jc )
1054 CALL dcopy( nap, ap, 1, vp, 1 )
1057 CALL dsptrd(
'L', n, vp, sd, se, tau, iinfo )
1059 IF( iinfo.NE.0 )
THEN
1060 WRITE( nounit, fmt = 9999 )
'DSPTRD(L)', iinfo, n, jtype,
1063 IF( iinfo.LT.0 )
THEN
1066 result( 7 ) = ulpinv
1072 CALL dopgtr(
'L', n, vp, tau, u, ldu, work, iinfo )
1073 IF( iinfo.NE.0 )
THEN
1074 WRITE( nounit, fmt = 9999 )
'DOPGTR(L)', iinfo, n, jtype,
1077 IF( iinfo.LT.0 )
THEN
1080 result( 8 ) = ulpinv
1085 CALL dspt21( 2,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1086 $ work, result( 7 ) )
1087 CALL dspt21( 3,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1088 $ work, result( 8 ) )
1094 CALL dcopy( n, sd, 1, d1, 1 )
1096 $
CALL dcopy( n-1, se, 1, work, 1 )
1097 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1100 CALL dsteqr(
'V', n, d1, work, z, ldu, work( n+1 ), iinfo )
1101 IF( iinfo.NE.0 )
THEN
1102 WRITE( nounit, fmt = 9999 )
'DSTEQR(V)', iinfo, n, jtype,
1105 IF( iinfo.LT.0 )
THEN
1108 result( 9 ) = ulpinv
1115 CALL dcopy( n, sd, 1, d2, 1 )
1117 $
CALL dcopy( n-1, se, 1, work, 1 )
1120 CALL dsteqr(
'N', n, d2, work, work( n+1 ), ldu,
1121 $ work( n+1 ), iinfo )
1122 IF( iinfo.NE.0 )
THEN
1123 WRITE( nounit, fmt = 9999 )
'DSTEQR(N)', iinfo, n, jtype,
1126 IF( iinfo.LT.0 )
THEN
1129 result( 11 ) = ulpinv
1136 CALL dcopy( n, sd, 1, d3, 1 )
1138 $
CALL dcopy( n-1, se, 1, work, 1 )
1141 CALL dsterf( n, d3, work, iinfo )
1142 IF( iinfo.NE.0 )
THEN
1143 WRITE( nounit, fmt = 9999 )
'DSTERF', iinfo, n, jtype,
1146 IF( iinfo.LT.0 )
THEN
1149 result( 12 ) = ulpinv
1156 CALL dstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1167 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1168 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1169 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1170 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1173 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1174 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1180 temp1 = thresh*( half-ulp )
1182 DO 160 j = 0, log2ui
1183 CALL dstech( n, sd, se, d1, temp1, work, iinfo )
1190 result( 13 ) = temp1
1195 IF( jtype.GT.15 )
THEN
1199 CALL dcopy( n, sd, 1, d4, 1 )
1201 $
CALL dcopy( n-1, se, 1, work, 1 )
1202 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1205 CALL dpteqr(
'V', n, d4, work, z, ldu, work( n+1 ),
1207 IF( iinfo.NE.0 )
THEN
1208 WRITE( nounit, fmt = 9999 )
'DPTEQR(V)', iinfo, n,
1211 IF( iinfo.LT.0 )
THEN
1214 result( 14 ) = ulpinv
1221 CALL dstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1226 CALL dcopy( n, sd, 1, d5, 1 )
1228 $
CALL dcopy( n-1, se, 1, work, 1 )
1231 CALL dpteqr(
'N', n, d5, work, z, ldu, work( n+1 ),
1233 IF( iinfo.NE.0 )
THEN
1234 WRITE( nounit, fmt = 9999 )
'DPTEQR(N)', iinfo, n,
1237 IF( iinfo.LT.0 )
THEN
1240 result( 16 ) = ulpinv
1250 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1251 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1254 result( 16 ) = temp2 / max( unfl,
1255 $ hun*ulp*max( temp1, temp2 ) )
1271 IF( jtype.EQ.21 )
THEN
1273 abstol = unfl + unfl
1274 CALL dstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se,
1275 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1276 $ work, iwork( 2*n+1 ), iinfo )
1277 IF( iinfo.NE.0 )
THEN
1278 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A,rel)', iinfo, n,
1281 IF( iinfo.LT.0 )
THEN
1284 result( 17 ) = ulpinv
1291 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1296 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1297 $ ( abstol+abs( d4( j ) ) ) )
1300 result( 17 ) = temp1 / temp2
1308 abstol = unfl + unfl
1309 CALL dstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se, m,
1310 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), work,
1311 $ iwork( 2*n+1 ), iinfo )
1312 IF( iinfo.NE.0 )
THEN
1313 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A)', iinfo, n, jtype,
1316 IF( iinfo.LT.0 )
THEN
1319 result( 18 ) = ulpinv
1329 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1330 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1333 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1343 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1344 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1352 CALL dstebz(
'I',
'E', n, vl, vu, il, iu, abstol, sd, se,
1353 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1354 $ work, iwork( 2*n+1 ), iinfo )
1355 IF( iinfo.NE.0 )
THEN
1356 WRITE( nounit, fmt = 9999 )
'DSTEBZ(I)', iinfo, n, jtype,
1359 IF( iinfo.LT.0 )
THEN
1362 result( 19 ) = ulpinv
1372 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1373 $ ulp*anorm, two*rtunfl )
1375 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1376 $ ulp*anorm, two*rtunfl )
1379 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1380 $ ulp*anorm, two*rtunfl )
1382 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1383 $ ulp*anorm, two*rtunfl )
1390 CALL dstebz(
'V',
'E', n, vl, vu, il, iu, abstol, sd, se,
1391 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1392 $ work, iwork( 2*n+1 ), iinfo )
1393 IF( iinfo.NE.0 )
THEN
1394 WRITE( nounit, fmt = 9999 )
'DSTEBZ(V)', iinfo, n, jtype,
1397 IF( iinfo.LT.0 )
THEN
1400 result( 19 ) = ulpinv
1405 IF( m3.EQ.0 .AND. n.NE.0 )
THEN
1406 result( 19 ) = ulpinv
1412 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1413 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1415 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1420 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1427 CALL dstebz(
'A',
'B', n, vl, vu, il, iu, abstol, sd, se, m,
1428 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), work,
1429 $ iwork( 2*n+1 ), iinfo )
1430 IF( iinfo.NE.0 )
THEN
1431 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A,B)', iinfo, n,
1434 IF( iinfo.LT.0 )
THEN
1437 result( 20 ) = ulpinv
1438 result( 21 ) = ulpinv
1443 CALL dstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1444 $ ldu, work, iwork( 2*n+1 ), iwork( 3*n+1 ),
1446 IF( iinfo.NE.0 )
THEN
1447 WRITE( nounit, fmt = 9999 )
'DSTEIN', iinfo, n, jtype,
1450 IF( iinfo.LT.0 )
THEN
1453 result( 20 ) = ulpinv
1454 result( 21 ) = ulpinv
1461 CALL dstt21( n, 0, sd, se, wa1, dumma, z, ldu, work,
1468 CALL dcopy( n, sd, 1, d1, 1 )
1470 $
CALL dcopy( n-1, se, 1, work, 1 )
1471 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1474 CALL dstedc(
'I', n, d1, work, z, ldu, work( n+1 ), lwedc-n,
1475 $ iwork, liwedc, iinfo )
1476 IF( iinfo.NE.0 )
THEN
1477 WRITE( nounit, fmt = 9999 )
'DSTEDC(I)', iinfo, n, jtype,
1480 IF( iinfo.LT.0 )
THEN
1483 result( 22 ) = ulpinv
1490 CALL dstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1497 CALL dcopy( n, sd, 1, d1, 1 )
1499 $
CALL dcopy( n-1, se, 1, work, 1 )
1500 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1503 CALL dstedc(
'V', n, d1, work, z, ldu, work( n+1 ), lwedc-n,
1504 $ iwork, liwedc, iinfo )
1505 IF( iinfo.NE.0 )
THEN
1506 WRITE( nounit, fmt = 9999 )
'DSTEDC(V)', iinfo, n, jtype,
1509 IF( iinfo.LT.0 )
THEN
1512 result( 24 ) = ulpinv
1519 CALL dstt21( n, 0, sd, se, d1, dumma, z, ldu, work,
1526 CALL dcopy( n, sd, 1, d2, 1 )
1528 $
CALL dcopy( n-1, se, 1, work, 1 )
1529 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1532 CALL dstedc(
'N', n, d2, work, z, ldu, work( n+1 ), lwedc-n,
1533 $ iwork, liwedc, iinfo )
1534 IF( iinfo.NE.0 )
THEN
1535 WRITE( nounit, fmt = 9999 )
'DSTEDC(N)', iinfo, n, jtype,
1538 IF( iinfo.LT.0 )
THEN
1541 result( 26 ) = ulpinv
1552 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1553 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1556 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1560 IF( ilaenv( 10,
'DSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1561 $ ilaenv( 11,
'DSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 )
THEN
1572 IF( jtype.EQ.21 .AND. srel )
THEN
1574 abstol = unfl + unfl
1575 CALL dstemr(
'V',
'A', n, sd, se, vl, vu, il, iu,
1576 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1577 $ work, lwork, iwork( 2*n+1 ), lwork-2*n,
1579 IF( iinfo.NE.0 )
THEN
1580 WRITE( nounit, fmt = 9999 )
'DSTEMR(V,A,rel)',
1581 $ iinfo, n, jtype, ioldsd
1583 IF( iinfo.LT.0 )
THEN
1586 result( 27 ) = ulpinv
1593 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1598 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1599 $ ( abstol+abs( d4( j ) ) ) )
1602 result( 27 ) = temp1 / temp2
1604 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1605 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1614 abstol = unfl + unfl
1615 CALL dstemr(
'V',
'I', n, sd, se, vl, vu, il, iu,
1616 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1617 $ work, lwork, iwork( 2*n+1 ),
1618 $ lwork-2*n, iinfo )
1620 IF( iinfo.NE.0 )
THEN
1621 WRITE( nounit, fmt = 9999 )
'DSTEMR(V,I,rel)',
1622 $ iinfo, n, jtype, ioldsd
1624 IF( iinfo.LT.0 )
THEN
1627 result( 28 ) = ulpinv
1635 temp2 = two*( two*n-one )*ulp*
1636 $ ( one+eight*half**2 ) / ( one-half )**4
1640 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1641 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1644 result( 28 ) = temp1 / temp2
1657 CALL dcopy( n, sd, 1, d5, 1 )
1659 $
CALL dcopy( n-1, se, 1, work, 1 )
1660 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1664 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1665 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1671 CALL dstemr(
'V',
'I', n, d5, work, vl, vu, il, iu,
1672 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1673 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1674 $ liwork-2*n, iinfo )
1675 IF( iinfo.NE.0 )
THEN
1676 WRITE( nounit, fmt = 9999 )
'DSTEMR(V,I)', iinfo,
1679 IF( iinfo.LT.0 )
THEN
1682 result( 29 ) = ulpinv
1689 CALL dstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1696 CALL dcopy( n, sd, 1, d5, 1 )
1698 $
CALL dcopy( n-1, se, 1, work, 1 )
1701 CALL dstemr(
'N',
'I', n, d5, work, vl, vu, il, iu,
1702 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1703 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1704 $ liwork-2*n, iinfo )
1705 IF( iinfo.NE.0 )
THEN
1706 WRITE( nounit, fmt = 9999 )
'DSTEMR(N,I)', iinfo,
1709 IF( iinfo.LT.0 )
THEN
1712 result( 31 ) = ulpinv
1722 DO 240 j = 1, iu - il + 1
1723 temp1 = max( temp1, abs( d1( j ) ),
1725 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1728 result( 31 ) = temp2 / max( unfl,
1729 $ ulp*max( temp1, temp2 ) )
1736 CALL dcopy( n, sd, 1, d5, 1 )
1738 $
CALL dcopy( n-1, se, 1, work, 1 )
1739 CALL dlaset(
'Full', n, n, zero, one, z, ldu )
1745 vl = d2( il ) - max( half*
1746 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1749 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1750 $ ulp*anorm, two*rtunfl )
1753 vu = d2( iu ) + max( half*
1754 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1757 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1758 $ ulp*anorm, two*rtunfl )
1765 CALL dstemr(
'V',
'V', n, d5, work, vl, vu, il, iu,
1766 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1767 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1768 $ liwork-2*n, iinfo )
1769 IF( iinfo.NE.0 )
THEN
1770 WRITE( nounit, fmt = 9999 )
'DSTEMR(V,V)', iinfo,
1773 IF( iinfo.LT.0 )
THEN
1776 result( 32 ) = ulpinv
1783 CALL dstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1790 CALL dcopy( n, sd, 1, d5, 1 )
1792 $
CALL dcopy( n-1, se, 1, work, 1 )
1795 CALL dstemr(
'N',
'V', n, d5, work, vl, vu, il, iu,
1796 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1797 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1798 $ liwork-2*n, iinfo )
1799 IF( iinfo.NE.0 )
THEN
1800 WRITE( nounit, fmt = 9999 )
'DSTEMR(N,V)', iinfo,
1803 IF( iinfo.LT.0 )
THEN
1806 result( 34 ) = ulpinv
1816 DO 250 j = 1, iu - il + 1
1817 temp1 = max( temp1, abs( d1( j ) ),
1819 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1822 result( 34 ) = temp2 / max( unfl,
1823 $ ulp*max( temp1, temp2 ) )
1838 CALL dcopy( n, sd, 1, d5, 1 )
1840 $
CALL dcopy( n-1, se, 1, work, 1 )
1844 CALL dstemr(
'V',
'A', n, d5, work, vl, vu, il, iu,
1845 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1846 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1847 $ liwork-2*n, iinfo )
1848 IF( iinfo.NE.0 )
THEN
1849 WRITE( nounit, fmt = 9999 )
'DSTEMR(V,A)', iinfo, n,
1852 IF( iinfo.LT.0 )
THEN
1855 result( 35 ) = ulpinv
1862 CALL dstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1869 CALL dcopy( n, sd, 1, d5, 1 )
1871 $
CALL dcopy( n-1, se, 1, work, 1 )
1874 CALL dstemr(
'N',
'A', n, d5, work, vl, vu, il, iu,
1875 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1876 $ work( n+1 ), lwork-n, iwork( 2*n+1 ),
1877 $ liwork-2*n, iinfo )
1878 IF( iinfo.NE.0 )
THEN
1879 WRITE( nounit, fmt = 9999 )
'DSTEMR(N,A)', iinfo, n,
1882 IF( iinfo.LT.0 )
THEN
1885 result( 37 ) = ulpinv
1896 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1897 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1900 result( 37 ) = temp2 / max( unfl,
1901 $ ulp*max( temp1, temp2 ) )
1905 ntestt = ntestt + ntest
1912 DO 290 jr = 1, ntest
1913 IF( result( jr ).GE.thresh )
THEN
1918 IF( nerrs.EQ.0 )
THEN
1919 WRITE( nounit, fmt = 9998 )
'DST'
1920 WRITE( nounit, fmt = 9997 )
1921 WRITE( nounit, fmt = 9996 )
1922 WRITE( nounit, fmt = 9995 )
'Symmetric'
1923 WRITE( nounit, fmt = 9994 )
1927 WRITE( nounit, fmt = 9988 )
1930 WRITE( nounit, fmt = 9990 )n, ioldsd, jtype, jr,
1939 CALL dlasum(
'DST', nounit, nerrs, ntestt )
1942 9999
FORMAT(
' DCHKST: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1943 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
1945 9998
FORMAT( / 1x, a3,
' -- Real Symmetric eigenvalue problem' )
1946 9997
FORMAT(
' Matrix types (see DCHKST for details): ' )
1948 9996
FORMAT( /
' Special Matrices:',
1949 $ /
' 1=Zero matrix. ',
1950 $
' 5=Diagonal: clustered entries.',
1951 $ /
' 2=Identity matrix. ',
1952 $
' 6=Diagonal: large, evenly spaced.',
1953 $ /
' 3=Diagonal: evenly spaced entries. ',
1954 $
' 7=Diagonal: small, evenly spaced.',
1955 $ /
' 4=Diagonal: geometr. spaced entries.' )
1956 9995
FORMAT(
' Dense ', a,
' Matrices:',
1957 $ /
' 8=Evenly spaced eigenvals. ',
1958 $
' 12=Small, evenly spaced eigenvals.',
1959 $ /
' 9=Geometrically spaced eigenvals. ',
1960 $
' 13=Matrix with random O(1) entries.',
1961 $ /
' 10=Clustered eigenvalues. ',
1962 $
' 14=Matrix with large random entries.',
1963 $ /
' 11=Large, evenly spaced eigenvals. ',
1964 $
' 15=Matrix with small random entries.' )
1965 9994
FORMAT(
' 16=Positive definite, evenly spaced eigenvalues',
1966 $ /
' 17=Positive definite, geometrically spaced eigenvlaues',
1967 $ /
' 18=Positive definite, clustered eigenvalues',
1968 $ /
' 19=Positive definite, small evenly spaced eigenvalues',
1969 $ /
' 20=Positive definite, large evenly spaced eigenvalues',
1970 $ /
' 21=Diagonally dominant tridiagonal, geometrically',
1971 $
' spaced eigenvalues' )
1973 9990
FORMAT(
' N=', i5,
', seed=', 4( i4,
',' ),
' type ', i2,
1974 $
', test(', i2,
')=', g10.3 )
1976 9988
FORMAT( /
'Test performed: see DCHKST 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 dchkst(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)
DCHKST
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 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