601 SUBROUTINE zchkst( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
602 $ nounit, a, lda, ap, sd, se, d1, d2, d3, d4, d5,
603 $ wa1, wa2, wa3, wr, u, ldu, v, vp, tau, z, work,
604 $ lwork, rwork, lrwork, iwork, liwork, result,
613 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
615 DOUBLE PRECISION THRESH
619 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
620 DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
621 $ result( * ), rwork( * ), sd( * ), se( * ),
622 $ wa1( * ), wa2( * ), wa3( * ), wr( * )
623 COMPLEX*16 A( lda, * ), AP( * ), TAU( * ), U( ldu, * ),
624 $ v( ldu, * ), vp( * ), work( * ), z( ldu, * )
630 DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN
631 parameter ( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
632 $ eight = 8.0d0, ten = 10.0d0, hun = 100.0d0 )
633 COMPLEX*16 CZERO, CONE
634 parameter ( czero = ( 0.0d+0, 0.0d+0 ),
635 $ cone = ( 1.0d+0, 0.0d+0 ) )
636 DOUBLE PRECISION HALF
637 parameter ( half = one / two )
639 parameter ( maxtyp = 21 )
641 parameter ( crange = .false. )
643 parameter ( crel = .false. )
646 LOGICAL BADNN, TRYRAC
647 INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP,
648 $ itype, iu, j, jc, jr, jsize, jtype, lgn,
649 $ liwedc, log2ui, lrwedc, lwedc, m, m2, m3,
650 $ mtypes, n, nap, nblock, nerrs, nmats, nmax,
651 $ nsplit, ntest, ntestt
652 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
653 $ rtunfl, temp1, temp2, temp3, temp4, ulp,
654 $ ulpinv, unfl, vl, vu
657 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
658 $ kmagn( maxtyp ), kmode( maxtyp ),
660 DOUBLE PRECISION DUMMA( 1 )
664 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
665 EXTERNAL ilaenv, dlamch, dlarnd, dsxt1
675 INTRINSIC abs, dble, dconjg, int, log, max, min, sqrt
678 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
679 $ 8, 8, 9, 9, 9, 9, 9, 10 /
680 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
681 $ 2, 3, 1, 1, 1, 2, 3, 1 /
682 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
683 $ 0, 0, 4, 3, 1, 4, 4, 3 /
701 nmax = max( nmax, nn( j ) )
706 nblock = ilaenv( 1,
'ZHETRD',
'L', nmax, -1, -1, -1 )
707 nblock = min( nmax, max( 1, nblock ) )
711 IF( nsizes.LT.0 )
THEN
713 ELSE IF( badnn )
THEN
715 ELSE IF( ntypes.LT.0 )
THEN
717 ELSE IF( lda.LT.nmax )
THEN
719 ELSE IF( ldu.LT.nmax )
THEN
721 ELSE IF( 2*max( 2, nmax )**2.GT.lwork )
THEN
726 CALL xerbla(
'ZCHKST', -info )
732 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
737 unfl = dlamch(
'Safe minimum' )
740 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
742 log2ui = int( log( ulpinv ) / log( two ) )
743 rtunfl = sqrt( unfl )
744 rtovfl = sqrt( ovfl )
749 iseed2( i ) = iseed( i )
754 DO 310 jsize = 1, nsizes
757 lgn = int( log( dble( n ) ) / log( two ) )
762 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
763 lrwedc = 1 + 3*n + 2*n*lgn + 4*n**2
764 liwedc = 6 + 6*n + 5*n*lgn
770 nap = ( n*( n+1 ) ) / 2
771 aninv = one / dble( max( 1, n ) )
773 IF( nsizes.NE.1 )
THEN
774 mtypes = min( maxtyp, ntypes )
776 mtypes = min( maxtyp+1, ntypes )
779 DO 300 jtype = 1, mtypes
780 IF( .NOT.dotype( jtype ) )
786 ioldsd( j ) = iseed( j )
805 IF( mtypes.GT.maxtyp )
808 itype = ktype( jtype )
809 imode = kmode( jtype )
813 GO TO ( 40, 50, 60 )kmagn( jtype )
820 anorm = ( rtovfl*ulp )*aninv
824 anorm = rtunfl*n*ulpinv
829 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
831 IF( jtype.LE.15 )
THEN
834 cond = ulpinv*aninv / ten
841 IF( itype.EQ.1 )
THEN
844 ELSE IF( itype.EQ.2 )
THEN
852 ELSE IF( itype.EQ.4 )
THEN
856 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
857 $ anorm, 0, 0,
'N', a, lda, work, iinfo )
860 ELSE IF( itype.EQ.5 )
THEN
864 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
865 $ anorm, n, n,
'N', a, lda, work, iinfo )
867 ELSE IF( itype.EQ.7 )
THEN
871 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
872 $
'T',
'N', work( n+1 ), 1, one,
873 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
874 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
876 ELSE IF( itype.EQ.8 )
THEN
880 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
881 $
'T',
'N', work( n+1 ), 1, one,
882 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
883 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
885 ELSE IF( itype.EQ.9 )
THEN
889 CALL zlatms( n, n,
'S', iseed,
'P', rwork, imode, cond,
890 $ anorm, n, n,
'N', a, lda, work, iinfo )
892 ELSE IF( itype.EQ.10 )
THEN
896 CALL zlatms( n, n,
'S', iseed,
'P', rwork, imode, cond,
897 $ anorm, 1, 1,
'N', a, lda, work, iinfo )
899 temp1 = abs( a( i-1, i ) )
900 temp2 = sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
901 IF( temp1.GT.half*temp2 )
THEN
902 a( i-1, i ) = a( i-1, i )*
903 $ ( half*temp2 / ( unfl+temp1 ) )
904 a( i, i-1 ) = dconjg( a( i-1, i ) )
913 IF( iinfo.NE.0 )
THEN
914 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
925 CALL zlacpy(
'U', n, n, a, lda, v, ldu )
928 CALL zhetrd(
'U', n, v, ldu, sd, se, tau, work, lwork,
931 IF( iinfo.NE.0 )
THEN
932 WRITE( nounit, fmt = 9999 )
'ZHETRD(U)', iinfo, n, jtype,
935 IF( iinfo.LT.0 )
THEN
943 CALL zlacpy(
'U', n, n, v, ldu, u, ldu )
946 CALL zungtr(
'U', n, u, ldu, tau, work, lwork, iinfo )
947 IF( iinfo.NE.0 )
THEN
948 WRITE( nounit, fmt = 9999 )
'ZUNGTR(U)', iinfo, n, jtype,
951 IF( iinfo.LT.0 )
THEN
961 CALL zhet21( 2,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
962 $ ldu, tau, work, rwork, result( 1 ) )
963 CALL zhet21( 3,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
964 $ ldu, tau, work, rwork, result( 2 ) )
969 CALL zlacpy(
'L', n, n, a, lda, v, ldu )
972 CALL zhetrd(
'L', n, v, ldu, sd, se, tau, work, lwork,
975 IF( iinfo.NE.0 )
THEN
976 WRITE( nounit, fmt = 9999 )
'ZHETRD(L)', iinfo, n, jtype,
979 IF( iinfo.LT.0 )
THEN
987 CALL zlacpy(
'L', n, n, v, ldu, u, ldu )
990 CALL zungtr(
'L', n, u, ldu, tau, work, lwork, iinfo )
991 IF( iinfo.NE.0 )
THEN
992 WRITE( nounit, fmt = 9999 )
'ZUNGTR(L)', iinfo, n, jtype,
995 IF( iinfo.LT.0 )
THEN
1003 CALL zhet21( 2,
'Lower', n, 1, a, lda, sd, se, u, ldu, v,
1004 $ ldu, tau, work, rwork, result( 3 ) )
1005 CALL zhet21( 3,
'Lower', n, 1, a, lda, sd, se, u, ldu, v,
1006 $ ldu, tau, work, rwork, result( 4 ) )
1014 ap( i ) = a( jr, jc )
1020 CALL zcopy( nap, ap, 1, vp, 1 )
1023 CALL zhptrd(
'U', n, vp, sd, se, tau, iinfo )
1025 IF( iinfo.NE.0 )
THEN
1026 WRITE( nounit, fmt = 9999 )
'ZHPTRD(U)', iinfo, n, jtype,
1029 IF( iinfo.LT.0 )
THEN
1032 result( 5 ) = ulpinv
1038 CALL zupgtr(
'U', n, vp, tau, u, ldu, work, iinfo )
1039 IF( iinfo.NE.0 )
THEN
1040 WRITE( nounit, fmt = 9999 )
'ZUPGTR(U)', iinfo, n, jtype,
1043 IF( iinfo.LT.0 )
THEN
1046 result( 6 ) = ulpinv
1053 CALL zhpt21( 2,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1054 $ work, rwork, result( 5 ) )
1055 CALL zhpt21( 3,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1056 $ work, rwork, result( 6 ) )
1064 ap( i ) = a( jr, jc )
1070 CALL zcopy( nap, ap, 1, vp, 1 )
1073 CALL zhptrd(
'L', n, vp, sd, se, tau, iinfo )
1075 IF( iinfo.NE.0 )
THEN
1076 WRITE( nounit, fmt = 9999 )
'ZHPTRD(L)', iinfo, n, jtype,
1079 IF( iinfo.LT.0 )
THEN
1082 result( 7 ) = ulpinv
1088 CALL zupgtr(
'L', n, vp, tau, u, ldu, work, iinfo )
1089 IF( iinfo.NE.0 )
THEN
1090 WRITE( nounit, fmt = 9999 )
'ZUPGTR(L)', iinfo, n, jtype,
1093 IF( iinfo.LT.0 )
THEN
1096 result( 8 ) = ulpinv
1101 CALL zhpt21( 2,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1102 $ work, rwork, result( 7 ) )
1103 CALL zhpt21( 3,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1104 $ work, rwork, result( 8 ) )
1110 CALL dcopy( n, sd, 1, d1, 1 )
1112 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1113 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1116 CALL zsteqr(
'V', n, d1, rwork, z, ldu, rwork( n+1 ),
1118 IF( iinfo.NE.0 )
THEN
1119 WRITE( nounit, fmt = 9999 )
'ZSTEQR(V)', iinfo, n, jtype,
1122 IF( iinfo.LT.0 )
THEN
1125 result( 9 ) = ulpinv
1132 CALL dcopy( n, sd, 1, d2, 1 )
1134 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1137 CALL zsteqr(
'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1139 IF( iinfo.NE.0 )
THEN
1140 WRITE( nounit, fmt = 9999 )
'ZSTEQR(N)', iinfo, n, jtype,
1143 IF( iinfo.LT.0 )
THEN
1146 result( 11 ) = ulpinv
1153 CALL dcopy( n, sd, 1, d3, 1 )
1155 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1158 CALL dsterf( n, d3, rwork, iinfo )
1159 IF( iinfo.NE.0 )
THEN
1160 WRITE( nounit, fmt = 9999 )
'DSTERF', iinfo, n, jtype,
1163 IF( iinfo.LT.0 )
THEN
1166 result( 12 ) = ulpinv
1173 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1184 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1185 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1186 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1187 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1190 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1191 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1197 temp1 = thresh*( half-ulp )
1199 DO 160 j = 0, log2ui
1200 CALL dstech( n, sd, se, d1, temp1, rwork, iinfo )
1207 result( 13 ) = temp1
1212 IF( jtype.GT.15 )
THEN
1216 CALL dcopy( n, sd, 1, d4, 1 )
1218 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1219 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1222 CALL zpteqr(
'V', n, d4, rwork, z, ldu, rwork( n+1 ),
1224 IF( iinfo.NE.0 )
THEN
1225 WRITE( nounit, fmt = 9999 )
'ZPTEQR(V)', iinfo, n,
1228 IF( iinfo.LT.0 )
THEN
1231 result( 14 ) = ulpinv
1238 CALL zstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1239 $ rwork, result( 14 ) )
1243 CALL dcopy( n, sd, 1, d5, 1 )
1245 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1248 CALL zpteqr(
'N', n, d5, rwork, z, ldu, rwork( n+1 ),
1250 IF( iinfo.NE.0 )
THEN
1251 WRITE( nounit, fmt = 9999 )
'ZPTEQR(N)', iinfo, n,
1254 IF( iinfo.LT.0 )
THEN
1257 result( 16 ) = ulpinv
1267 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1268 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1271 result( 16 ) = temp2 / max( unfl,
1272 $ hun*ulp*max( temp1, temp2 ) )
1288 IF( jtype.EQ.21 )
THEN
1290 abstol = unfl + unfl
1291 CALL dstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se,
1292 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1293 $ rwork, iwork( 2*n+1 ), iinfo )
1294 IF( iinfo.NE.0 )
THEN
1295 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A,rel)', iinfo, n,
1298 IF( iinfo.LT.0 )
THEN
1301 result( 17 ) = ulpinv
1308 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1313 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1314 $ ( abstol+abs( d4( j ) ) ) )
1317 result( 17 ) = temp1 / temp2
1325 abstol = unfl + unfl
1326 CALL dstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se, m,
1327 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1328 $ iwork( 2*n+1 ), iinfo )
1329 IF( iinfo.NE.0 )
THEN
1330 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A)', iinfo, n, jtype,
1333 IF( iinfo.LT.0 )
THEN
1336 result( 18 ) = ulpinv
1346 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1347 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1350 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1360 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1361 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1369 CALL dstebz(
'I',
'E', n, vl, vu, il, iu, abstol, sd, se,
1370 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1371 $ rwork, iwork( 2*n+1 ), iinfo )
1372 IF( iinfo.NE.0 )
THEN
1373 WRITE( nounit, fmt = 9999 )
'DSTEBZ(I)', iinfo, n, jtype,
1376 IF( iinfo.LT.0 )
THEN
1379 result( 19 ) = ulpinv
1389 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1390 $ ulp*anorm, two*rtunfl )
1392 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1393 $ ulp*anorm, two*rtunfl )
1396 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1397 $ ulp*anorm, two*rtunfl )
1399 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1400 $ ulp*anorm, two*rtunfl )
1407 CALL dstebz(
'V',
'E', n, vl, vu, il, iu, abstol, sd, se,
1408 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1409 $ rwork, iwork( 2*n+1 ), iinfo )
1410 IF( iinfo.NE.0 )
THEN
1411 WRITE( nounit, fmt = 9999 )
'DSTEBZ(V)', iinfo, n, jtype,
1414 IF( iinfo.LT.0 )
THEN
1417 result( 19 ) = ulpinv
1422 IF( m3.EQ.0 .AND. n.NE.0 )
THEN
1423 result( 19 ) = ulpinv
1429 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1430 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1432 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1437 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1444 CALL dstebz(
'A',
'B', n, vl, vu, il, iu, abstol, sd, se, m,
1445 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1446 $ iwork( 2*n+1 ), iinfo )
1447 IF( iinfo.NE.0 )
THEN
1448 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A,B)', iinfo, n,
1451 IF( iinfo.LT.0 )
THEN
1454 result( 20 ) = ulpinv
1455 result( 21 ) = ulpinv
1460 CALL zstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1461 $ ldu, rwork, iwork( 2*n+1 ), iwork( 3*n+1 ),
1463 IF( iinfo.NE.0 )
THEN
1464 WRITE( nounit, fmt = 9999 )
'ZSTEIN', iinfo, n, jtype,
1467 IF( iinfo.LT.0 )
THEN
1470 result( 20 ) = ulpinv
1471 result( 21 ) = ulpinv
1478 CALL zstt21( n, 0, sd, se, wa1, dumma, z, ldu, work, rwork,
1487 CALL dcopy( n, sd, 1, d1, 1 )
1489 $
CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1490 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1493 CALL zstedc(
'I', n, d1, rwork( inde ), z, ldu, work, lwedc,
1494 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1495 IF( iinfo.NE.0 )
THEN
1496 WRITE( nounit, fmt = 9999 )
'ZSTEDC(I)', iinfo, n, jtype,
1499 IF( iinfo.LT.0 )
THEN
1502 result( 22 ) = ulpinv
1509 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1516 CALL dcopy( n, sd, 1, d1, 1 )
1518 $
CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1519 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1522 CALL zstedc(
'V', n, d1, rwork( inde ), z, ldu, work, lwedc,
1523 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1524 IF( iinfo.NE.0 )
THEN
1525 WRITE( nounit, fmt = 9999 )
'ZSTEDC(V)', iinfo, n, jtype,
1528 IF( iinfo.LT.0 )
THEN
1531 result( 24 ) = ulpinv
1538 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1545 CALL dcopy( n, sd, 1, d2, 1 )
1547 $
CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1548 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1551 CALL zstedc(
'N', n, d2, rwork( inde ), z, ldu, work, lwedc,
1552 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1553 IF( iinfo.NE.0 )
THEN
1554 WRITE( nounit, fmt = 9999 )
'ZSTEDC(N)', iinfo, n, jtype,
1557 IF( iinfo.LT.0 )
THEN
1560 result( 26 ) = ulpinv
1571 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1572 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1575 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1579 IF( ilaenv( 10,
'ZSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1580 $ ilaenv( 11,
'ZSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 )
THEN
1591 IF( jtype.EQ.21 .AND. crel )
THEN
1593 abstol = unfl + unfl
1594 CALL zstemr(
'V',
'A', n, sd, se, vl, vu, il, iu,
1595 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1596 $ rwork, lrwork, iwork( 2*n+1 ), lwork-2*n,
1598 IF( iinfo.NE.0 )
THEN
1599 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,A,rel)',
1600 $ iinfo, n, jtype, ioldsd
1602 IF( iinfo.LT.0 )
THEN
1605 result( 27 ) = ulpinv
1612 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1617 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1618 $ ( abstol+abs( d4( j ) ) ) )
1621 result( 27 ) = temp1 / temp2
1623 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1624 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1633 abstol = unfl + unfl
1634 CALL zstemr(
'V',
'I', n, sd, se, vl, vu, il, iu,
1635 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1636 $ rwork, lrwork, iwork( 2*n+1 ),
1637 $ lwork-2*n, iinfo )
1639 IF( iinfo.NE.0 )
THEN
1640 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,I,rel)',
1641 $ iinfo, n, jtype, ioldsd
1643 IF( iinfo.LT.0 )
THEN
1646 result( 28 ) = ulpinv
1654 temp2 = two*( two*n-one )*ulp*
1655 $ ( one+eight*half**2 ) / ( one-half )**4
1659 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1660 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1663 result( 28 ) = temp1 / temp2
1676 CALL dcopy( n, sd, 1, d5, 1 )
1678 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1679 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1683 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1684 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1690 CALL zstemr(
'V',
'I', n, d5, rwork, vl, vu, il, iu,
1691 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1692 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1693 $ liwork-2*n, iinfo )
1694 IF( iinfo.NE.0 )
THEN
1695 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,I)', iinfo,
1698 IF( iinfo.LT.0 )
THEN
1701 result( 29 ) = ulpinv
1713 CALL dcopy( n, sd, 1, d5, 1 )
1715 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1718 CALL zstemr(
'N',
'I', n, d5, rwork, vl, vu, il, iu,
1719 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1720 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1721 $ liwork-2*n, iinfo )
1722 IF( iinfo.NE.0 )
THEN
1723 WRITE( nounit, fmt = 9999 )
'ZSTEMR(N,I)', iinfo,
1726 IF( iinfo.LT.0 )
THEN
1729 result( 31 ) = ulpinv
1739 DO 240 j = 1, iu - il + 1
1740 temp1 = max( temp1, abs( d1( j ) ),
1742 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1745 result( 31 ) = temp2 / max( unfl,
1746 $ ulp*max( temp1, temp2 ) )
1753 CALL dcopy( n, sd, 1, d5, 1 )
1755 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1756 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1762 vl = d2( il ) - max( half*
1763 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1766 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1767 $ ulp*anorm, two*rtunfl )
1770 vu = d2( iu ) + max( half*
1771 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1774 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1775 $ ulp*anorm, two*rtunfl )
1782 CALL zstemr(
'V',
'V', n, d5, rwork, vl, vu, il, iu,
1783 $ m, d1, z, ldu, m, iwork( 1 ), tryrac,
1784 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1785 $ liwork-2*n, iinfo )
1786 IF( iinfo.NE.0 )
THEN
1787 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,V)', iinfo,
1790 IF( iinfo.LT.0 )
THEN
1793 result( 32 ) = ulpinv
1800 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1801 $ m, rwork, result( 32 ) )
1807 CALL dcopy( n, sd, 1, d5, 1 )
1809 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1812 CALL zstemr(
'N',
'V', n, d5, rwork, vl, vu, il, iu,
1813 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1814 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1815 $ liwork-2*n, iinfo )
1816 IF( iinfo.NE.0 )
THEN
1817 WRITE( nounit, fmt = 9999 )
'ZSTEMR(N,V)', iinfo,
1820 IF( iinfo.LT.0 )
THEN
1823 result( 34 ) = ulpinv
1833 DO 250 j = 1, iu - il + 1
1834 temp1 = max( temp1, abs( d1( j ) ),
1836 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1839 result( 34 ) = temp2 / max( unfl,
1840 $ ulp*max( temp1, temp2 ) )
1855 CALL dcopy( n, sd, 1, d5, 1 )
1857 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1861 CALL zstemr(
'V',
'A', n, d5, rwork, vl, vu, il, iu,
1862 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1863 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1864 $ liwork-2*n, iinfo )
1865 IF( iinfo.NE.0 )
THEN
1866 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,A)', iinfo, n,
1869 IF( iinfo.LT.0 )
THEN
1872 result( 35 ) = ulpinv
1879 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1880 $ rwork, result( 35 ) )
1886 CALL dcopy( n, sd, 1, d5, 1 )
1888 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1891 CALL zstemr(
'N',
'A', n, d5, rwork, vl, vu, il, iu,
1892 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1893 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1894 $ liwork-2*n, iinfo )
1895 IF( iinfo.NE.0 )
THEN
1896 WRITE( nounit, fmt = 9999 )
'ZSTEMR(N,A)', iinfo, n,
1899 IF( iinfo.LT.0 )
THEN
1902 result( 37 ) = ulpinv
1913 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1914 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1917 result( 37 ) = temp2 / max( unfl,
1918 $ ulp*max( temp1, temp2 ) )
1922 ntestt = ntestt + ntest
1929 DO 290 jr = 1, ntest
1930 IF( result( jr ).GE.thresh )
THEN
1935 IF( nerrs.EQ.0 )
THEN
1936 WRITE( nounit, fmt = 9998 )
'ZST'
1937 WRITE( nounit, fmt = 9997 )
1938 WRITE( nounit, fmt = 9996 )
1939 WRITE( nounit, fmt = 9995 )
'Hermitian'
1940 WRITE( nounit, fmt = 9994 )
1944 WRITE( nounit, fmt = 9987 )
1947 IF( result( jr ).LT.10000.0d0 )
THEN
1948 WRITE( nounit, fmt = 9989 )n, jtype, ioldsd, jr,
1951 WRITE( nounit, fmt = 9988 )n, jtype, ioldsd, jr,
1961 CALL dlasum(
'ZST', nounit, nerrs, ntestt )
1964 9999
FORMAT(
' ZCHKST: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1965 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
1967 9998
FORMAT( / 1x, a3,
' -- Complex Hermitian eigenvalue problem' )
1968 9997
FORMAT(
' Matrix types (see ZCHKST for details): ' )
1970 9996
FORMAT( /
' Special Matrices:',
1971 $ /
' 1=Zero matrix. ',
1972 $
' 5=Diagonal: clustered entries.',
1973 $ /
' 2=Identity matrix. ',
1974 $
' 6=Diagonal: large, evenly spaced.',
1975 $ /
' 3=Diagonal: evenly spaced entries. ',
1976 $
' 7=Diagonal: small, evenly spaced.',
1977 $ /
' 4=Diagonal: geometr. spaced entries.' )
1978 9995
FORMAT(
' Dense ', a,
' Matrices:',
1979 $ /
' 8=Evenly spaced eigenvals. ',
1980 $
' 12=Small, evenly spaced eigenvals.',
1981 $ /
' 9=Geometrically spaced eigenvals. ',
1982 $
' 13=Matrix with random O(1) entries.',
1983 $ /
' 10=Clustered eigenvalues. ',
1984 $
' 14=Matrix with large random entries.',
1985 $ /
' 11=Large, evenly spaced eigenvals. ',
1986 $
' 15=Matrix with small random entries.' )
1987 9994
FORMAT(
' 16=Positive definite, evenly spaced eigenvalues',
1988 $ /
' 17=Positive definite, geometrically spaced eigenvlaues',
1989 $ /
' 18=Positive definite, clustered eigenvalues',
1990 $ /
' 19=Positive definite, small evenly spaced eigenvalues',
1991 $ /
' 20=Positive definite, large evenly spaced eigenvalues',
1992 $ /
' 21=Diagonally dominant tridiagonal, geometrically',
1993 $
' spaced eigenvalues' )
1995 9989
FORMAT(
' Matrix order=', i5,
', type=', i2,
', seed=',
1996 $ 4( i4,
',' ),
' result ', i3,
' is', 0p, f8.2 )
1997 9988
FORMAT(
' Matrix order=', i5,
', type=', i2,
', seed=',
1998 $ 4( i4,
',' ),
' result ', i3,
' is', 1p, d10.3 )
2000 9987
FORMAT( /
'Test performed: see ZCHKST for details.', / )
subroutine zpteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
ZPTEQR
subroutine zlatmr(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)
ZLATMR
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine zstt22(N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, LDWORK, RWORK, RESULT)
ZSTT22
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zungtr(UPLO, N, A, LDA, TAU, WORK, LWORK, INFO)
ZUNGTR
subroutine zstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZSTEDC
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine dsterf(N, D, E, INFO)
DSTERF
subroutine zstt21(N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RWORK, RESULT)
ZSTT21
subroutine zstemr(JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO)
ZSTEMR
subroutine zsteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
ZSTEQR
subroutine zhpt21(ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, TAU, WORK, RWORK, RESULT)
ZHPT21
subroutine zstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
ZSTEIN
subroutine dstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
DSTEBZ
subroutine zchkst(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, RWORK, LRWORK, IWORK, LIWORK, RESULT, INFO)
ZCHKST
subroutine zhptrd(UPLO, N, AP, D, E, TAU, INFO)
ZHPTRD
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dstech(N, A, B, EIG, TOL, WORK, INFO)
DSTECH
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine zupgtr(UPLO, N, AP, TAU, Q, LDQ, WORK, INFO)
ZUPGTR
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zhet21(ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, LDV, TAU, WORK, RWORK, RESULT)
ZHET21
subroutine zhetrd(UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO)
ZHETRD