620 SUBROUTINE zchkst2stg( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
621 $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5,
622 $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK,
623 $ LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT,
631 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
633 DOUBLE PRECISION THRESH
637 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
638 DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
639 $ RESULT( * ), RWORK( * ), SD( * ), SE( * ),
640 $ wa1( * ), wa2( * ), wa3( * ), wr( * )
641 COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ),
642 $ v( ldu, * ), vp( * ), work( * ), z( ldu, * )
648 DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN
649 PARAMETER ( ZERO = 0.0d0, one = 1.0d0, two = 2.0d0,
650 $ eight = 8.0d0, ten = 10.0d0, hun = 100.0d0 )
651 COMPLEX*16 CZERO, CONE
652 parameter( czero = ( 0.0d+0, 0.0d+0 ),
653 $ cone = ( 1.0d+0, 0.0d+0 ) )
654 DOUBLE PRECISION HALF
655 parameter( half = one / two )
657 PARAMETER ( MAXTYP = 21 )
659 parameter( crange = .false. )
661 parameter( crel = .false. )
664 LOGICAL BADNN, TRYRAC
665 INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP,
666 $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN,
667 $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3,
668 $ mtypes, n, nap, nblock, nerrs, nmats, nmax,
669 $ nsplit, ntest, ntestt, lh, lw
670 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
671 $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP,
672 $ ULPINV, UNFL, VL, VU
675 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
676 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
678 DOUBLE PRECISION DUMMA( 1 )
682 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
683 EXTERNAL ILAENV, DLAMCH, DLARND, DSXT1
693 INTRINSIC abs, dble, dconjg, int, log, max, min, sqrt
696 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
697 $ 8, 8, 9, 9, 9, 9, 9, 10 /
698 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
699 $ 2, 3, 1, 1, 1, 2, 3, 1 /
700 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
701 $ 0, 0, 4, 3, 1, 4, 4, 3 /
719 nmax = max( nmax, nn( j ) )
724 nblock = ilaenv( 1,
'ZHETRD',
'L', nmax, -1, -1, -1 )
725 nblock = min( nmax, max( 1, nblock ) )
729 IF( nsizes.LT.0 )
THEN
731 ELSE IF( badnn )
THEN
733 ELSE IF( ntypes.LT.0 )
THEN
735 ELSE IF( lda.LT.nmax )
THEN
737 ELSE IF( ldu.LT.nmax )
THEN
739 ELSE IF( 2*max( 2, nmax )**2.GT.lwork )
THEN
744 CALL xerbla(
'ZCHKST2STG', -info )
750 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
755 unfl = dlamch(
'Safe minimum' )
757 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
759 log2ui = int( log( ulpinv ) / log( two ) )
760 rtunfl = sqrt( unfl )
761 rtovfl = sqrt( ovfl )
766 iseed2( i ) = iseed( i )
771 DO 310 jsize = 1, nsizes
774 lgn = int( log( dble( n ) ) / log( two ) )
779 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
780 lrwedc = 1 + 3*n + 2*n*lgn + 4*n**2
781 liwedc = 6 + 6*n + 5*n*lgn
787 nap = ( n*( n+1 ) ) / 2
788 aninv = one / dble( max( 1, n ) )
790 IF( nsizes.NE.1 )
THEN
791 mtypes = min( maxtyp, ntypes )
793 mtypes = min( maxtyp+1, ntypes )
796 DO 300 jtype = 1, mtypes
797 IF( .NOT.dotype( jtype ) )
803 ioldsd( j ) = iseed( j )
822 IF( mtypes.GT.maxtyp )
825 itype = ktype( jtype )
826 imode = kmode( jtype )
830 GO TO ( 40, 50, 60 )kmagn( jtype )
837 anorm = ( rtovfl*ulp )*aninv
841 anorm = rtunfl*n*ulpinv
846 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
848 IF( jtype.LE.15 )
THEN
851 cond = ulpinv*aninv / ten
858 IF( itype.EQ.1 )
THEN
861 ELSE IF( itype.EQ.2 )
THEN
869 ELSE IF( itype.EQ.4 )
THEN
873 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
874 $ anorm, 0, 0,
'N', a, lda, work, iinfo )
877 ELSE IF( itype.EQ.5 )
THEN
881 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
882 $ anorm, n, n,
'N', a, lda, work, iinfo )
884 ELSE IF( itype.EQ.7 )
THEN
888 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
889 $
'T',
'N', work( n+1 ), 1, one,
890 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
891 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
893 ELSE IF( itype.EQ.8 )
THEN
897 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
898 $
'T',
'N', work( n+1 ), 1, one,
899 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
900 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
902 ELSE IF( itype.EQ.9 )
THEN
906 CALL zlatms( n, n,
'S', iseed,
'P', rwork, imode, cond,
907 $ anorm, n, n,
'N', a, lda, work, iinfo )
909 ELSE IF( itype.EQ.10 )
THEN
913 CALL zlatms( n, n,
'S', iseed,
'P', rwork, imode, cond,
914 $ anorm, 1, 1,
'N', a, lda, work, iinfo )
916 temp1 = abs( a( i-1, i ) )
917 temp2 = sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
918 IF( temp1.GT.half*temp2 )
THEN
919 a( i-1, i ) = a( i-1, i )*
920 $ ( half*temp2 / ( unfl+temp1 ) )
921 a( i, i-1 ) = dconjg( a( i-1, i ) )
930 IF( iinfo.NE.0 )
THEN
931 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
942 CALL zlacpy(
'U', n, n, a, lda, v, ldu )
945 CALL zhetrd(
'U', n, v, ldu, sd, se, tau, work, lwork,
948 IF( iinfo.NE.0 )
THEN
949 WRITE( nounit, fmt = 9999 )
'ZHETRD(U)', iinfo, n, jtype,
952 IF( iinfo.LT.0 )
THEN
960 CALL zlacpy(
'U', n, n, v, ldu, u, ldu )
963 CALL zungtr(
'U', n, u, ldu, tau, work, lwork, iinfo )
964 IF( iinfo.NE.0 )
THEN
965 WRITE( nounit, fmt = 9999 )
'ZUNGTR(U)', iinfo, n, jtype,
968 IF( iinfo.LT.0 )
THEN
978 CALL zhet21( 2,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
979 $ ldu, tau, work, rwork, result( 1 ) )
980 CALL zhet21( 3,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
981 $ ldu, tau, work, rwork, result( 2 ) )
990 CALL dcopy( n, sd, 1, d1, 1 )
992 $
CALL dcopy( n-1, se, 1, rwork, 1 )
994 CALL zsteqr(
'N', n, d1, rwork, work, ldu, rwork( n+1 ),
996 IF( iinfo.NE.0 )
THEN
997 WRITE( nounit, fmt = 9999 )
'ZSTEQR(N)', iinfo, n, jtype,
1000 IF( iinfo.LT.0 )
THEN
1003 result( 3 ) = ulpinv
1013 CALL dlaset(
'Full', n, 1, zero, zero, sd, n )
1014 CALL dlaset(
'Full', n, 1, zero, zero, se, n )
1015 CALL zlacpy(
'U', n, n, a, lda, v, ldu )
1019 $ work, lh, work( lh+1 ), lw, iinfo )
1023 CALL dcopy( n, sd, 1, d2, 1 )
1025 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1028 CALL zsteqr(
'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1030 IF( iinfo.NE.0 )
THEN
1031 WRITE( nounit, fmt = 9999 )
'ZSTEQR(N)', iinfo, n, jtype,
1034 IF( iinfo.LT.0 )
THEN
1037 result( 3 ) = ulpinv
1047 CALL dlaset(
'Full', n, 1, zero, zero, sd, n )
1048 CALL dlaset(
'Full', n, 1, zero, zero, se, n )
1049 CALL zlacpy(
'L', n, n, a, lda, v, ldu )
1051 $ work, lh, work( lh+1 ), lw, iinfo )
1055 CALL dcopy( n, sd, 1, d3, 1 )
1057 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1060 CALL zsteqr(
'N', n, d3, rwork, work, ldu, rwork( n+1 ),
1062 IF( iinfo.NE.0 )
THEN
1063 WRITE( nounit, fmt = 9999 )
'ZSTEQR(N)', iinfo, n, jtype,
1066 IF( iinfo.LT.0 )
THEN
1069 result( 4 ) = ulpinv
1084 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1085 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1086 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1087 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1090 result( 3 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1091 result( 4 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1099 ap( i ) = a( jr, jc )
1105 CALL zcopy( nap, ap, 1, vp, 1 )
1108 CALL zhptrd(
'U', n, vp, sd, se, tau, iinfo )
1110 IF( iinfo.NE.0 )
THEN
1111 WRITE( nounit, fmt = 9999 )
'ZHPTRD(U)', iinfo, n, jtype,
1114 IF( iinfo.LT.0 )
THEN
1117 result( 5 ) = ulpinv
1123 CALL zupgtr(
'U', n, vp, tau, u, ldu, work, iinfo )
1124 IF( iinfo.NE.0 )
THEN
1125 WRITE( nounit, fmt = 9999 )
'ZUPGTR(U)', iinfo, n, jtype,
1128 IF( iinfo.LT.0 )
THEN
1131 result( 6 ) = ulpinv
1138 CALL zhpt21( 2,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1139 $ work, rwork, result( 5 ) )
1140 CALL zhpt21( 3,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1141 $ work, rwork, result( 6 ) )
1149 ap( i ) = a( jr, jc )
1155 CALL zcopy( nap, ap, 1, vp, 1 )
1158 CALL zhptrd(
'L', n, vp, sd, se, tau, iinfo )
1160 IF( iinfo.NE.0 )
THEN
1161 WRITE( nounit, fmt = 9999 )
'ZHPTRD(L)', iinfo, n, jtype,
1164 IF( iinfo.LT.0 )
THEN
1167 result( 7 ) = ulpinv
1173 CALL zupgtr(
'L', n, vp, tau, u, ldu, work, iinfo )
1174 IF( iinfo.NE.0 )
THEN
1175 WRITE( nounit, fmt = 9999 )
'ZUPGTR(L)', iinfo, n, jtype,
1178 IF( iinfo.LT.0 )
THEN
1181 result( 8 ) = ulpinv
1186 CALL zhpt21( 2,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1187 $ work, rwork, result( 7 ) )
1188 CALL zhpt21( 3,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1189 $ work, rwork, result( 8 ) )
1195 CALL dcopy( n, sd, 1, d1, 1 )
1197 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1198 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1201 CALL zsteqr(
'V', n, d1, rwork, z, ldu, rwork( n+1 ),
1203 IF( iinfo.NE.0 )
THEN
1204 WRITE( nounit, fmt = 9999 )
'ZSTEQR(V)', iinfo, n, jtype,
1207 IF( iinfo.LT.0 )
THEN
1210 result( 9 ) = ulpinv
1217 CALL dcopy( n, sd, 1, d2, 1 )
1219 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1222 CALL zsteqr(
'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1224 IF( iinfo.NE.0 )
THEN
1225 WRITE( nounit, fmt = 9999 )
'ZSTEQR(N)', iinfo, n, jtype,
1228 IF( iinfo.LT.0 )
THEN
1231 result( 11 ) = ulpinv
1238 CALL dcopy( n, sd, 1, d3, 1 )
1240 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1243 CALL dsterf( n, d3, rwork, iinfo )
1244 IF( iinfo.NE.0 )
THEN
1245 WRITE( nounit, fmt = 9999 )
'DSTERF', iinfo, n, jtype,
1248 IF( iinfo.LT.0 )
THEN
1251 result( 12 ) = ulpinv
1258 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1269 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1270 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1271 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1272 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1275 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1276 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1282 temp1 = thresh*( half-ulp )
1284 DO 160 j = 0, log2ui
1285 CALL dstech( n, sd, se, d1, temp1, rwork, iinfo )
1292 result( 13 ) = temp1
1297 IF( jtype.GT.15 )
THEN
1301 CALL dcopy( n, sd, 1, d4, 1 )
1303 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1304 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1307 CALL zpteqr(
'V', n, d4, rwork, z, ldu, rwork( n+1 ),
1309 IF( iinfo.NE.0 )
THEN
1310 WRITE( nounit, fmt = 9999 )
'ZPTEQR(V)', iinfo, n,
1313 IF( iinfo.LT.0 )
THEN
1316 result( 14 ) = ulpinv
1323 CALL zstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1324 $ rwork, result( 14 ) )
1328 CALL dcopy( n, sd, 1, d5, 1 )
1330 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1333 CALL zpteqr(
'N', n, d5, rwork, z, ldu, rwork( n+1 ),
1335 IF( iinfo.NE.0 )
THEN
1336 WRITE( nounit, fmt = 9999 )
'ZPTEQR(N)', iinfo, n,
1339 IF( iinfo.LT.0 )
THEN
1342 result( 16 ) = ulpinv
1352 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1353 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1356 result( 16 ) = temp2 / max( unfl,
1357 $ hun*ulp*max( temp1, temp2 ) )
1373 IF( jtype.EQ.21 )
THEN
1375 abstol = unfl + unfl
1376 CALL dstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se,
1377 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1378 $ rwork, iwork( 2*n+1 ), iinfo )
1379 IF( iinfo.NE.0 )
THEN
1380 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A,rel)', iinfo, n,
1383 IF( iinfo.LT.0 )
THEN
1386 result( 17 ) = ulpinv
1393 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1398 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1399 $ ( abstol+abs( d4( j ) ) ) )
1402 result( 17 ) = temp1 / temp2
1410 abstol = unfl + unfl
1411 CALL dstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se, m,
1412 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1413 $ iwork( 2*n+1 ), iinfo )
1414 IF( iinfo.NE.0 )
THEN
1415 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A)', iinfo, n, jtype,
1418 IF( iinfo.LT.0 )
THEN
1421 result( 18 ) = ulpinv
1431 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1432 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1435 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1445 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1446 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1454 CALL dstebz(
'I',
'E', n, vl, vu, il, iu, abstol, sd, se,
1455 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1456 $ rwork, iwork( 2*n+1 ), iinfo )
1457 IF( iinfo.NE.0 )
THEN
1458 WRITE( nounit, fmt = 9999 )
'DSTEBZ(I)', iinfo, n, jtype,
1461 IF( iinfo.LT.0 )
THEN
1464 result( 19 ) = ulpinv
1474 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1475 $ ulp*anorm, two*rtunfl )
1477 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1478 $ ulp*anorm, two*rtunfl )
1481 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1482 $ ulp*anorm, two*rtunfl )
1484 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1485 $ ulp*anorm, two*rtunfl )
1492 CALL dstebz(
'V',
'E', n, vl, vu, il, iu, abstol, sd, se,
1493 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1494 $ rwork, iwork( 2*n+1 ), iinfo )
1495 IF( iinfo.NE.0 )
THEN
1496 WRITE( nounit, fmt = 9999 )
'DSTEBZ(V)', iinfo, n, jtype,
1499 IF( iinfo.LT.0 )
THEN
1502 result( 19 ) = ulpinv
1507 IF( m3.EQ.0 .AND. n.NE.0 )
THEN
1508 result( 19 ) = ulpinv
1514 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1515 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1517 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1522 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1529 CALL dstebz(
'A',
'B', n, vl, vu, il, iu, abstol, sd, se, m,
1530 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1531 $ iwork( 2*n+1 ), iinfo )
1532 IF( iinfo.NE.0 )
THEN
1533 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A,B)', iinfo, n,
1536 IF( iinfo.LT.0 )
THEN
1539 result( 20 ) = ulpinv
1540 result( 21 ) = ulpinv
1545 CALL zstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1546 $ ldu, rwork, iwork( 2*n+1 ), iwork( 3*n+1 ),
1548 IF( iinfo.NE.0 )
THEN
1549 WRITE( nounit, fmt = 9999 )
'ZSTEIN', iinfo, n, jtype,
1552 IF( iinfo.LT.0 )
THEN
1555 result( 20 ) = ulpinv
1556 result( 21 ) = ulpinv
1563 CALL zstt21( n, 0, sd, se, wa1, dumma, z, ldu, work, rwork,
1572 CALL dcopy( n, sd, 1, d1, 1 )
1574 $
CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1575 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1578 CALL zstedc(
'I', n, d1, rwork( inde ), z, ldu, work, lwedc,
1579 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1580 IF( iinfo.NE.0 )
THEN
1581 WRITE( nounit, fmt = 9999 )
'ZSTEDC(I)', iinfo, n, jtype,
1584 IF( iinfo.LT.0 )
THEN
1587 result( 22 ) = ulpinv
1594 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1601 CALL dcopy( n, sd, 1, d1, 1 )
1603 $
CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1604 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1607 CALL zstedc(
'V', n, d1, rwork( inde ), z, ldu, work, lwedc,
1608 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1609 IF( iinfo.NE.0 )
THEN
1610 WRITE( nounit, fmt = 9999 )
'ZSTEDC(V)', iinfo, n, jtype,
1613 IF( iinfo.LT.0 )
THEN
1616 result( 24 ) = ulpinv
1623 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1630 CALL dcopy( n, sd, 1, d2, 1 )
1632 $
CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1633 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1636 CALL zstedc(
'N', n, d2, rwork( inde ), z, ldu, work, lwedc,
1637 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1638 IF( iinfo.NE.0 )
THEN
1639 WRITE( nounit, fmt = 9999 )
'ZSTEDC(N)', iinfo, n, jtype,
1642 IF( iinfo.LT.0 )
THEN
1645 result( 26 ) = ulpinv
1656 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1657 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1660 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1664 IF( ilaenv( 10,
'ZSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1665 $ ilaenv( 11,
'ZSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 )
THEN
1676 IF( jtype.EQ.21 .AND. crel )
THEN
1678 abstol = unfl + unfl
1679 CALL zstemr(
'V',
'A', n, sd, se, vl, vu, il, iu,
1680 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1681 $ rwork, lrwork, iwork( 2*n+1 ), lwork-2*n,
1683 IF( iinfo.NE.0 )
THEN
1684 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,A,rel)',
1685 $ iinfo, n, jtype, ioldsd
1687 IF( iinfo.LT.0 )
THEN
1690 result( 27 ) = ulpinv
1697 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1702 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1703 $ ( abstol+abs( d4( j ) ) ) )
1706 result( 27 ) = temp1 / temp2
1708 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1709 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1718 abstol = unfl + unfl
1719 CALL zstemr(
'V',
'I', n, sd, se, vl, vu, il, iu,
1720 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1721 $ rwork, lrwork, iwork( 2*n+1 ),
1722 $ lwork-2*n, iinfo )
1724 IF( iinfo.NE.0 )
THEN
1725 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,I,rel)',
1726 $ iinfo, n, jtype, ioldsd
1728 IF( iinfo.LT.0 )
THEN
1731 result( 28 ) = ulpinv
1738 temp2 = two*( two*n-one )*ulp*
1739 $ ( one+eight*half**2 ) / ( one-half )**4
1743 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1744 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1747 result( 28 ) = temp1 / temp2
1760 CALL dcopy( n, sd, 1, d5, 1 )
1762 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1763 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1767 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1768 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1774 CALL zstemr(
'V',
'I', n, d5, rwork, vl, vu, il, iu,
1775 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1776 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1777 $ liwork-2*n, iinfo )
1778 IF( iinfo.NE.0 )
THEN
1779 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,I)', iinfo,
1782 IF( iinfo.LT.0 )
THEN
1785 result( 29 ) = ulpinv
1796 CALL dcopy( n, sd, 1, d5, 1 )
1798 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1801 CALL zstemr(
'N',
'I', n, d5, rwork, vl, vu, il, iu,
1802 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1803 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1804 $ liwork-2*n, iinfo )
1805 IF( iinfo.NE.0 )
THEN
1806 WRITE( nounit, fmt = 9999 )
'ZSTEMR(N,I)', iinfo,
1809 IF( iinfo.LT.0 )
THEN
1812 result( 31 ) = ulpinv
1822 DO 240 j = 1, iu - il + 1
1823 temp1 = max( temp1, abs( d1( j ) ),
1825 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1828 result( 31 ) = temp2 / max( unfl,
1829 $ ulp*max( temp1, temp2 ) )
1835 CALL dcopy( n, sd, 1, d5, 1 )
1837 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1838 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1844 vl = d2( il ) - max( half*
1845 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1848 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1849 $ ulp*anorm, two*rtunfl )
1852 vu = d2( iu ) + max( half*
1853 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1856 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1857 $ ulp*anorm, two*rtunfl )
1864 CALL zstemr(
'V',
'V', n, d5, rwork, vl, vu, il, iu,
1865 $ m, d1, z, ldu, m, iwork( 1 ), tryrac,
1866 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1867 $ liwork-2*n, iinfo )
1868 IF( iinfo.NE.0 )
THEN
1869 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,V)', iinfo,
1872 IF( iinfo.LT.0 )
THEN
1875 result( 32 ) = ulpinv
1882 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1883 $ m, rwork, result( 32 ) )
1889 CALL dcopy( n, sd, 1, d5, 1 )
1891 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1894 CALL zstemr(
'N',
'V', n, d5, rwork, vl, vu, il, iu,
1895 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1896 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1897 $ liwork-2*n, iinfo )
1898 IF( iinfo.NE.0 )
THEN
1899 WRITE( nounit, fmt = 9999 )
'ZSTEMR(N,V)', iinfo,
1902 IF( iinfo.LT.0 )
THEN
1905 result( 34 ) = ulpinv
1915 DO 250 j = 1, iu - il + 1
1916 temp1 = max( temp1, abs( d1( j ) ),
1918 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1921 result( 34 ) = temp2 / max( unfl,
1922 $ ulp*max( temp1, temp2 ) )
1936 CALL dcopy( n, sd, 1, d5, 1 )
1938 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1942 CALL zstemr(
'V',
'A', n, d5, rwork, vl, vu, il, iu,
1943 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1944 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1945 $ liwork-2*n, iinfo )
1946 IF( iinfo.NE.0 )
THEN
1947 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,A)', iinfo, n,
1950 IF( iinfo.LT.0 )
THEN
1953 result( 35 ) = ulpinv
1960 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1961 $ rwork, result( 35 ) )
1967 CALL dcopy( n, sd, 1, d5, 1 )
1969 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1972 CALL zstemr(
'N',
'A', n, d5, rwork, vl, vu, il, iu,
1973 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1974 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1975 $ liwork-2*n, iinfo )
1976 IF( iinfo.NE.0 )
THEN
1977 WRITE( nounit, fmt = 9999 )
'ZSTEMR(N,A)', iinfo, n,
1980 IF( iinfo.LT.0 )
THEN
1983 result( 37 ) = ulpinv
1994 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1995 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1998 result( 37 ) = temp2 / max( unfl,
1999 $ ulp*max( temp1, temp2 ) )
2003 ntestt = ntestt + ntest
2009 DO 290 jr = 1, ntest
2010 IF( result( jr ).GE.thresh )
THEN
2015 IF( nerrs.EQ.0 )
THEN
2016 WRITE( nounit, fmt = 9998 )
'ZST'
2017 WRITE( nounit, fmt = 9997 )
2018 WRITE( nounit, fmt = 9996 )
2019 WRITE( nounit, fmt = 9995 )
'Hermitian'
2020 WRITE( nounit, fmt = 9994 )
2024 WRITE( nounit, fmt = 9987 )
2027 IF( result( jr ).LT.10000.0d0 )
THEN
2028 WRITE( nounit, fmt = 9989 )n, jtype, ioldsd, jr,
2031 WRITE( nounit, fmt = 9988 )n, jtype, ioldsd, jr,
2041 CALL dlasum(
'ZST', nounit, nerrs, ntestt )
2044 9999
FORMAT(
' ZCHKST2STG: ', a,
' returned INFO=', i6,
'.', / 9x,
2045 $
'N=', i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
2047 9998
FORMAT( / 1x, a3,
' -- Complex Hermitian eigenvalue problem' )
2048 9997
FORMAT(
' Matrix types (see ZCHKST2STG for details): ' )
2050 9996
FORMAT( /
' Special Matrices:',
2051 $ /
' 1=Zero matrix. ',
2052 $
' 5=Diagonal: clustered entries.',
2053 $ /
' 2=Identity matrix. ',
2054 $
' 6=Diagonal: large, evenly spaced.',
2055 $ /
' 3=Diagonal: evenly spaced entries. ',
2056 $
' 7=Diagonal: small, evenly spaced.',
2057 $ /
' 4=Diagonal: geometr. spaced entries.' )
2058 9995
FORMAT(
' Dense ', a,
' Matrices:',
2059 $ /
' 8=Evenly spaced eigenvals. ',
2060 $
' 12=Small, evenly spaced eigenvals.',
2061 $ /
' 9=Geometrically spaced eigenvals. ',
2062 $
' 13=Matrix with random O(1) entries.',
2063 $ /
' 10=Clustered eigenvalues. ',
2064 $
' 14=Matrix with large random entries.',
2065 $ /
' 11=Large, evenly spaced eigenvals. ',
2066 $
' 15=Matrix with small random entries.' )
2067 9994
FORMAT(
' 16=Positive definite, evenly spaced eigenvalues',
2068 $ /
' 17=Positive definite, geometrically spaced eigenvlaues',
2069 $ /
' 18=Positive definite, clustered eigenvalues',
2070 $ /
' 19=Positive definite, small evenly spaced eigenvalues',
2071 $ /
' 20=Positive definite, large evenly spaced eigenvalues',
2072 $ /
' 21=Diagonally dominant tridiagonal, geometrically',
2073 $
' spaced eigenvalues' )
2075 9989
FORMAT(
' Matrix order=', i5,
', type=', i2,
', seed=',
2076 $ 4( i4,
',' ),
' result ', i3,
' is', 0p, f8.2 )
2077 9988
FORMAT(
' Matrix order=', i5,
', type=', i2,
', seed=',
2078 $ 4( i4,
',' ),
' result ', i3,
' is', 1p, d10.3 )
2080 9987
FORMAT( /
'Test performed: see ZCHKST2STG for details.', / )
subroutine xerbla(srname, info)
subroutine dlasum(type, iounit, ie, nrun)
DLASUM
subroutine dstech(n, a, b, eig, tol, work, info)
DSTECH
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
subroutine zhetrd_2stage(vect, uplo, n, a, lda, d, e, tau, hous2, lhous2, work, lwork, info)
ZHETRD_2STAGE
subroutine zhetrd(uplo, n, a, lda, d, e, tau, work, lwork, info)
ZHETRD
subroutine zhptrd(uplo, n, ap, d, e, tau, info)
ZHPTRD
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
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 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 zpteqr(compz, n, d, e, z, ldz, work, info)
ZPTEQR
subroutine dstebz(range, order, n, vl, vu, il, iu, abstol, d, e, m, nsplit, w, iblock, isplit, work, iwork, info)
DSTEBZ
subroutine zstedc(compz, n, d, e, z, ldz, work, lwork, rwork, lrwork, iwork, liwork, info)
ZSTEDC
subroutine zstein(n, d, e, m, w, iblock, isplit, z, ldz, work, iwork, ifail, info)
ZSTEIN
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 dsterf(n, d, e, info)
DSTERF
subroutine zungtr(uplo, n, a, lda, tau, work, lwork, info)
ZUNGTR
subroutine zupgtr(uplo, n, ap, tau, q, ldq, work, info)
ZUPGTR
subroutine zchkst2stg(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)
ZCHKST2STG
subroutine zhet21(itype, uplo, n, kband, a, lda, d, e, u, ldu, v, ldv, tau, work, rwork, result)
ZHET21
subroutine zhpt21(itype, uplo, n, kband, ap, d, e, u, ldu, vp, tau, work, rwork, result)
ZHPT21
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 zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
subroutine zstt21(n, kband, ad, ae, sd, se, u, ldu, work, rwork, result)
ZSTT21
subroutine zstt22(n, m, kband, ad, ae, sd, se, u, ldu, work, ldwork, rwork, result)
ZSTT22