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 )
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' )
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,
'.', / 9
x,
'N=',
1965 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
1967 9998
FORMAT( / 1
x, 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 zhptrd(UPLO, N, AP, D, E, TAU, INFO)
ZHPTRD
subroutine zstt22(N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, LDWORK, RWORK, RESULT)
ZSTT22
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zstein(N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO)
ZSTEIN
subroutine dsterf(N, D, E, INFO)
DSTERF
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine zpteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
ZPTEQR
subroutine zstedc(COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZSTEDC
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zstt21(N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RWORK, RESULT)
ZSTT21
subroutine zhetrd(UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO)
ZHETRD
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
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 dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
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 zupgtr(UPLO, N, AP, TAU, Q, LDQ, WORK, INFO)
ZUPGTR
INTEGER function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine dstech(N, A, B, EIG, TOL, WORK, INFO)
DSTECH
subroutine zsteqr(COMPZ, N, D, E, Z, LDZ, WORK, INFO)
ZSTEQR
DOUBLE PRECISION function dlarnd(IDIST, ISEED)
DLARND
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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
DOUBLE PRECISION function dsxt1(IJOB, D1, N1, D2, N2, ABSTOL, ULP, UNFL)
DSXT1
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 dstebz(RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO)
DSTEBZ
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zhpt21(ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP, TAU, WORK, RWORK, RESULT)
ZHPT21
subroutine zungtr(UPLO, N, A, LDA, TAU, WORK, LWORK, INFO)
ZUNGTR
subroutine zhet21(ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, LDV, TAU, WORK, RWORK, RESULT)
ZHET21