599 SUBROUTINE zchkst( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
600 $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5,
601 $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK,
602 $ LWORK, RWORK, LRWORK, IWORK, LIWORK, RESULT,
610 INTEGER INFO, LDA, LDU, LIWORK, LRWORK, LWORK, NOUNIT,
612 DOUBLE PRECISION THRESH
616 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
617 DOUBLE PRECISION D1( * ), D2( * ), D3( * ), D4( * ), D5( * ),
618 $ RESULT( * ), RWORK( * ), SD( * ), SE( * ),
619 $ wa1( * ), wa2( * ), wa3( * ), wr( * )
620 COMPLEX*16 A( LDA, * ), AP( * ), TAU( * ), U( LDU, * ),
621 $ v( ldu, * ), vp( * ), work( * ), z( ldu, * )
627 DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN
628 PARAMETER ( ZERO = 0.0d0, one = 1.0d0, two = 2.0d0,
629 $ eight = 8.0d0, ten = 10.0d0, hun = 100.0d0 )
630 COMPLEX*16 CZERO, CONE
631 parameter( czero = ( 0.0d+0, 0.0d+0 ),
632 $ cone = ( 1.0d+0, 0.0d+0 ) )
633 DOUBLE PRECISION HALF
634 parameter( half = one / two )
636 PARAMETER ( MAXTYP = 21 )
638 parameter( crange = .false. )
640 parameter( crel = .false. )
643 LOGICAL BADNN, TRYRAC
644 INTEGER I, IINFO, IL, IMODE, INDE, INDRWK, ITEMP,
645 $ ITYPE, IU, J, JC, JR, JSIZE, JTYPE, LGN,
646 $ LIWEDC, LOG2UI, LRWEDC, LWEDC, M, M2, M3,
647 $ mtypes, n, nap, nblock, nerrs, nmats, nmax,
648 $ nsplit, ntest, ntestt
649 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
650 $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP,
651 $ ULPINV, UNFL, VL, VU
654 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
655 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
657 DOUBLE PRECISION DUMMA( 1 )
661 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
662 EXTERNAL ILAENV, DLAMCH, DLARND, DSXT1
671 INTRINSIC abs, dble, dconjg, int, log, max, min, sqrt
674 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
675 $ 8, 8, 9, 9, 9, 9, 9, 10 /
676 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
677 $ 2, 3, 1, 1, 1, 2, 3, 1 /
678 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
679 $ 0, 0, 4, 3, 1, 4, 4, 3 /
697 nmax = max( nmax, nn( j ) )
702 nblock = ilaenv( 1,
'ZHETRD',
'L', nmax, -1, -1, -1 )
703 nblock = min( nmax, max( 1, nblock ) )
707 IF( nsizes.LT.0 )
THEN
709 ELSE IF( badnn )
THEN
711 ELSE IF( ntypes.LT.0 )
THEN
713 ELSE IF( lda.LT.nmax )
THEN
715 ELSE IF( ldu.LT.nmax )
THEN
717 ELSE IF( 2*max( 2, nmax )**2.GT.lwork )
THEN
722 CALL xerbla(
'ZCHKST', -info )
728 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
733 unfl = dlamch(
'Safe minimum' )
735 ulp = dlamch(
'Epsilon' )*dlamch(
'Base' )
737 log2ui = int( log( ulpinv ) / log( two ) )
738 rtunfl = sqrt( unfl )
739 rtovfl = sqrt( ovfl )
744 iseed2( i ) = iseed( i )
749 DO 310 jsize = 1, nsizes
752 lgn = int( log( dble( n ) ) / log( two ) )
757 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
758 lrwedc = 1 + 3*n + 2*n*lgn + 4*n**2
759 liwedc = 6 + 6*n + 5*n*lgn
765 nap = ( n*( n+1 ) ) / 2
766 aninv = one / dble( max( 1, n ) )
768 IF( nsizes.NE.1 )
THEN
769 mtypes = min( maxtyp, ntypes )
771 mtypes = min( maxtyp+1, ntypes )
774 DO 300 jtype = 1, mtypes
775 IF( .NOT.dotype( jtype ) )
781 ioldsd( j ) = iseed( j )
800 IF( mtypes.GT.maxtyp )
803 itype = ktype( jtype )
804 imode = kmode( jtype )
808 GO TO ( 40, 50, 60 )kmagn( jtype )
815 anorm = ( rtovfl*ulp )*aninv
819 anorm = rtunfl*n*ulpinv
824 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
826 IF( jtype.LE.15 )
THEN
829 cond = ulpinv*aninv / ten
836 IF( itype.EQ.1 )
THEN
839 ELSE IF( itype.EQ.2 )
THEN
847 ELSE IF( itype.EQ.4 )
THEN
851 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
852 $ anorm, 0, 0,
'N', a, lda, work, iinfo )
855 ELSE IF( itype.EQ.5 )
THEN
859 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
860 $ anorm, n, n,
'N', a, lda, work, iinfo )
862 ELSE IF( itype.EQ.7 )
THEN
866 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
867 $
'T',
'N', work( n+1 ), 1, one,
868 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
869 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
871 ELSE IF( itype.EQ.8 )
THEN
875 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
876 $
'T',
'N', work( n+1 ), 1, one,
877 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
878 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
880 ELSE IF( itype.EQ.9 )
THEN
884 CALL zlatms( n, n,
'S', iseed,
'P', rwork, imode, cond,
885 $ anorm, n, n,
'N', a, lda, work, iinfo )
887 ELSE IF( itype.EQ.10 )
THEN
891 CALL zlatms( n, n,
'S', iseed,
'P', rwork, imode, cond,
892 $ anorm, 1, 1,
'N', a, lda, work, iinfo )
894 temp1 = abs( a( i-1, i ) )
895 temp2 = sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
896 IF( temp1.GT.half*temp2 )
THEN
897 a( i-1, i ) = a( i-1, i )*
898 $ ( half*temp2 / ( unfl+temp1 ) )
899 a( i, i-1 ) = dconjg( a( i-1, i ) )
908 IF( iinfo.NE.0 )
THEN
909 WRITE( nounit, fmt = 9999 )
'Generator', iinfo, n, jtype,
920 CALL zlacpy(
'U', n, n, a, lda, v, ldu )
923 CALL zhetrd(
'U', n, v, ldu, sd, se, tau, work, lwork,
926 IF( iinfo.NE.0 )
THEN
927 WRITE( nounit, fmt = 9999 )
'ZHETRD(U)', iinfo, n, jtype,
930 IF( iinfo.LT.0 )
THEN
938 CALL zlacpy(
'U', n, n, v, ldu, u, ldu )
941 CALL zungtr(
'U', n, u, ldu, tau, work, lwork, iinfo )
942 IF( iinfo.NE.0 )
THEN
943 WRITE( nounit, fmt = 9999 )
'ZUNGTR(U)', iinfo, n, jtype,
946 IF( iinfo.LT.0 )
THEN
956 CALL zhet21( 2,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
957 $ ldu, tau, work, rwork, result( 1 ) )
958 CALL zhet21( 3,
'Upper', n, 1, a, lda, sd, se, u, ldu, v,
959 $ ldu, tau, work, rwork, result( 2 ) )
964 CALL zlacpy(
'L', n, n, a, lda, v, ldu )
967 CALL zhetrd(
'L', n, v, ldu, sd, se, tau, work, lwork,
970 IF( iinfo.NE.0 )
THEN
971 WRITE( nounit, fmt = 9999 )
'ZHETRD(L)', iinfo, n, jtype,
974 IF( iinfo.LT.0 )
THEN
982 CALL zlacpy(
'L', n, n, v, ldu, u, ldu )
985 CALL zungtr(
'L', n, u, ldu, tau, work, lwork, iinfo )
986 IF( iinfo.NE.0 )
THEN
987 WRITE( nounit, fmt = 9999 )
'ZUNGTR(L)', iinfo, n, jtype,
990 IF( iinfo.LT.0 )
THEN
998 CALL zhet21( 2,
'Lower', n, 1, a, lda, sd, se, u, ldu, v,
999 $ ldu, tau, work, rwork, result( 3 ) )
1000 CALL zhet21( 3,
'Lower', n, 1, a, lda, sd, se, u, ldu, v,
1001 $ ldu, tau, work, rwork, result( 4 ) )
1009 ap( i ) = a( jr, jc )
1015 CALL zcopy( nap, ap, 1, vp, 1 )
1018 CALL zhptrd(
'U', n, vp, sd, se, tau, iinfo )
1020 IF( iinfo.NE.0 )
THEN
1021 WRITE( nounit, fmt = 9999 )
'ZHPTRD(U)', iinfo, n, jtype,
1024 IF( iinfo.LT.0 )
THEN
1027 result( 5 ) = ulpinv
1033 CALL zupgtr(
'U', n, vp, tau, u, ldu, work, iinfo )
1034 IF( iinfo.NE.0 )
THEN
1035 WRITE( nounit, fmt = 9999 )
'ZUPGTR(U)', iinfo, n, jtype,
1038 IF( iinfo.LT.0 )
THEN
1041 result( 6 ) = ulpinv
1048 CALL zhpt21( 2,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1049 $ work, rwork, result( 5 ) )
1050 CALL zhpt21( 3,
'Upper', n, 1, ap, sd, se, u, ldu, vp, tau,
1051 $ work, rwork, result( 6 ) )
1059 ap( i ) = a( jr, jc )
1065 CALL zcopy( nap, ap, 1, vp, 1 )
1068 CALL zhptrd(
'L', n, vp, sd, se, tau, iinfo )
1070 IF( iinfo.NE.0 )
THEN
1071 WRITE( nounit, fmt = 9999 )
'ZHPTRD(L)', iinfo, n, jtype,
1074 IF( iinfo.LT.0 )
THEN
1077 result( 7 ) = ulpinv
1083 CALL zupgtr(
'L', n, vp, tau, u, ldu, work, iinfo )
1084 IF( iinfo.NE.0 )
THEN
1085 WRITE( nounit, fmt = 9999 )
'ZUPGTR(L)', iinfo, n, jtype,
1088 IF( iinfo.LT.0 )
THEN
1091 result( 8 ) = ulpinv
1096 CALL zhpt21( 2,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1097 $ work, rwork, result( 7 ) )
1098 CALL zhpt21( 3,
'Lower', n, 1, ap, sd, se, u, ldu, vp, tau,
1099 $ work, rwork, result( 8 ) )
1105 CALL dcopy( n, sd, 1, d1, 1 )
1107 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1108 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1111 CALL zsteqr(
'V', n, d1, rwork, z, ldu, rwork( n+1 ),
1113 IF( iinfo.NE.0 )
THEN
1114 WRITE( nounit, fmt = 9999 )
'ZSTEQR(V)', iinfo, n, jtype,
1117 IF( iinfo.LT.0 )
THEN
1120 result( 9 ) = ulpinv
1127 CALL dcopy( n, sd, 1, d2, 1 )
1129 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1132 CALL zsteqr(
'N', n, d2, rwork, work, ldu, rwork( n+1 ),
1134 IF( iinfo.NE.0 )
THEN
1135 WRITE( nounit, fmt = 9999 )
'ZSTEQR(N)', iinfo, n, jtype,
1138 IF( iinfo.LT.0 )
THEN
1141 result( 11 ) = ulpinv
1148 CALL dcopy( n, sd, 1, d3, 1 )
1150 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1153 CALL dsterf( n, d3, rwork, iinfo )
1154 IF( iinfo.NE.0 )
THEN
1155 WRITE( nounit, fmt = 9999 )
'DSTERF', iinfo, n, jtype,
1158 IF( iinfo.LT.0 )
THEN
1161 result( 12 ) = ulpinv
1168 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1179 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1180 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1181 temp3 = max( temp3, abs( d1( j ) ), abs( d3( j ) ) )
1182 temp4 = max( temp4, abs( d1( j )-d3( j ) ) )
1185 result( 11 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1186 result( 12 ) = temp4 / max( unfl, ulp*max( temp3, temp4 ) )
1192 temp1 = thresh*( half-ulp )
1194 DO 160 j = 0, log2ui
1195 CALL dstech( n, sd, se, d1, temp1, rwork, iinfo )
1202 result( 13 ) = temp1
1207 IF( jtype.GT.15 )
THEN
1211 CALL dcopy( n, sd, 1, d4, 1 )
1213 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1214 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1217 CALL zpteqr(
'V', n, d4, rwork, z, ldu, rwork( n+1 ),
1219 IF( iinfo.NE.0 )
THEN
1220 WRITE( nounit, fmt = 9999 )
'ZPTEQR(V)', iinfo, n,
1223 IF( iinfo.LT.0 )
THEN
1226 result( 14 ) = ulpinv
1233 CALL zstt21( n, 0, sd, se, d4, dumma, z, ldu, work,
1234 $ rwork, result( 14 ) )
1238 CALL dcopy( n, sd, 1, d5, 1 )
1240 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1243 CALL zpteqr(
'N', n, d5, rwork, z, ldu, rwork( n+1 ),
1245 IF( iinfo.NE.0 )
THEN
1246 WRITE( nounit, fmt = 9999 )
'ZPTEQR(N)', iinfo, n,
1249 IF( iinfo.LT.0 )
THEN
1252 result( 16 ) = ulpinv
1262 temp1 = max( temp1, abs( d4( j ) ), abs( d5( j ) ) )
1263 temp2 = max( temp2, abs( d4( j )-d5( j ) ) )
1266 result( 16 ) = temp2 / max( unfl,
1267 $ hun*ulp*max( temp1, temp2 ) )
1283 IF( jtype.EQ.21 )
THEN
1285 abstol = unfl + unfl
1286 CALL dstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se,
1287 $ m, nsplit, wr, iwork( 1 ), iwork( n+1 ),
1288 $ rwork, iwork( 2*n+1 ), iinfo )
1289 IF( iinfo.NE.0 )
THEN
1290 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A,rel)', iinfo, n,
1293 IF( iinfo.LT.0 )
THEN
1296 result( 17 ) = ulpinv
1303 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1308 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1309 $ ( abstol+abs( d4( j ) ) ) )
1312 result( 17 ) = temp1 / temp2
1320 abstol = unfl + unfl
1321 CALL dstebz(
'A',
'E', n, vl, vu, il, iu, abstol, sd, se, m,
1322 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1323 $ iwork( 2*n+1 ), iinfo )
1324 IF( iinfo.NE.0 )
THEN
1325 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A)', iinfo, n, jtype,
1328 IF( iinfo.LT.0 )
THEN
1331 result( 18 ) = ulpinv
1341 temp1 = max( temp1, abs( d3( j ) ), abs( wa1( j ) ) )
1342 temp2 = max( temp2, abs( d3( j )-wa1( j ) ) )
1345 result( 18 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1355 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1356 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1364 CALL dstebz(
'I',
'E', n, vl, vu, il, iu, abstol, sd, se,
1365 $ m2, nsplit, wa2, iwork( 1 ), iwork( n+1 ),
1366 $ rwork, iwork( 2*n+1 ), iinfo )
1367 IF( iinfo.NE.0 )
THEN
1368 WRITE( nounit, fmt = 9999 )
'DSTEBZ(I)', iinfo, n, jtype,
1371 IF( iinfo.LT.0 )
THEN
1374 result( 19 ) = ulpinv
1384 vl = wa1( il ) - max( half*( wa1( il )-wa1( il-1 ) ),
1385 $ ulp*anorm, two*rtunfl )
1387 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1388 $ ulp*anorm, two*rtunfl )
1391 vu = wa1( iu ) + max( half*( wa1( iu+1 )-wa1( iu ) ),
1392 $ ulp*anorm, two*rtunfl )
1394 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1395 $ ulp*anorm, two*rtunfl )
1402 CALL dstebz(
'V',
'E', n, vl, vu, il, iu, abstol, sd, se,
1403 $ m3, nsplit, wa3, iwork( 1 ), iwork( n+1 ),
1404 $ rwork, iwork( 2*n+1 ), iinfo )
1405 IF( iinfo.NE.0 )
THEN
1406 WRITE( nounit, fmt = 9999 )
'DSTEBZ(V)', iinfo, n, jtype,
1409 IF( iinfo.LT.0 )
THEN
1412 result( 19 ) = ulpinv
1417 IF( m3.EQ.0 .AND. n.NE.0 )
THEN
1418 result( 19 ) = ulpinv
1424 temp1 = dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1425 temp2 = dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1427 temp3 = max( abs( wa1( n ) ), abs( wa1( 1 ) ) )
1432 result( 19 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1439 CALL dstebz(
'A',
'B', n, vl, vu, il, iu, abstol, sd, se, m,
1440 $ nsplit, wa1, iwork( 1 ), iwork( n+1 ), rwork,
1441 $ iwork( 2*n+1 ), iinfo )
1442 IF( iinfo.NE.0 )
THEN
1443 WRITE( nounit, fmt = 9999 )
'DSTEBZ(A,B)', iinfo, n,
1446 IF( iinfo.LT.0 )
THEN
1449 result( 20 ) = ulpinv
1450 result( 21 ) = ulpinv
1455 CALL zstein( n, sd, se, m, wa1, iwork( 1 ), iwork( n+1 ), z,
1456 $ ldu, rwork, iwork( 2*n+1 ), iwork( 3*n+1 ),
1458 IF( iinfo.NE.0 )
THEN
1459 WRITE( nounit, fmt = 9999 )
'ZSTEIN', iinfo, n, jtype,
1462 IF( iinfo.LT.0 )
THEN
1465 result( 20 ) = ulpinv
1466 result( 21 ) = ulpinv
1473 CALL zstt21( n, 0, sd, se, wa1, dumma, z, ldu, work, rwork,
1482 CALL dcopy( n, sd, 1, d1, 1 )
1484 $
CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1485 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1488 CALL zstedc(
'I', n, d1, rwork( inde ), z, ldu, work, lwedc,
1489 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1490 IF( iinfo.NE.0 )
THEN
1491 WRITE( nounit, fmt = 9999 )
'ZSTEDC(I)', iinfo, n, jtype,
1494 IF( iinfo.LT.0 )
THEN
1497 result( 22 ) = ulpinv
1504 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1511 CALL dcopy( n, sd, 1, d1, 1 )
1513 $
CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1514 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1517 CALL zstedc(
'V', n, d1, rwork( inde ), z, ldu, work, lwedc,
1518 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1519 IF( iinfo.NE.0 )
THEN
1520 WRITE( nounit, fmt = 9999 )
'ZSTEDC(V)', iinfo, n, jtype,
1523 IF( iinfo.LT.0 )
THEN
1526 result( 24 ) = ulpinv
1533 CALL zstt21( n, 0, sd, se, d1, dumma, z, ldu, work, rwork,
1540 CALL dcopy( n, sd, 1, d2, 1 )
1542 $
CALL dcopy( n-1, se, 1, rwork( inde ), 1 )
1543 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1546 CALL zstedc(
'N', n, d2, rwork( inde ), z, ldu, work, lwedc,
1547 $ rwork( indrwk ), lrwedc, iwork, liwedc, iinfo )
1548 IF( iinfo.NE.0 )
THEN
1549 WRITE( nounit, fmt = 9999 )
'ZSTEDC(N)', iinfo, n, jtype,
1552 IF( iinfo.LT.0 )
THEN
1555 result( 26 ) = ulpinv
1566 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1567 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1570 result( 26 ) = temp2 / max( unfl, ulp*max( temp1, temp2 ) )
1574 IF( ilaenv( 10,
'ZSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 .AND.
1575 $ ilaenv( 11,
'ZSTEMR',
'VA', 1, 0, 0, 0 ).EQ.1 )
THEN
1586 IF( jtype.EQ.21 .AND. crel )
THEN
1588 abstol = unfl + unfl
1589 CALL zstemr(
'V',
'A', n, sd, se, vl, vu, il, iu,
1590 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1591 $ rwork, lrwork, iwork( 2*n+1 ), lwork-2*n,
1593 IF( iinfo.NE.0 )
THEN
1594 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,A,rel)',
1595 $ iinfo, n, jtype, ioldsd
1597 IF( iinfo.LT.0 )
THEN
1600 result( 27 ) = ulpinv
1607 temp2 = two*( two*n-one )*ulp*( one+eight*half**2 ) /
1612 temp1 = max( temp1, abs( d4( j )-wr( n-j+1 ) ) /
1613 $ ( abstol+abs( d4( j ) ) ) )
1616 result( 27 ) = temp1 / temp2
1618 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1619 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1628 abstol = unfl + unfl
1629 CALL zstemr(
'V',
'I', n, sd, se, vl, vu, il, iu,
1630 $ m, wr, z, ldu, n, iwork( 1 ), tryrac,
1631 $ rwork, lrwork, iwork( 2*n+1 ),
1632 $ lwork-2*n, iinfo )
1634 IF( iinfo.NE.0 )
THEN
1635 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,I,rel)',
1636 $ iinfo, n, jtype, ioldsd
1638 IF( iinfo.LT.0 )
THEN
1641 result( 28 ) = ulpinv
1649 temp2 = two*( two*n-one )*ulp*
1650 $ ( one+eight*half**2 ) / ( one-half )**4
1654 temp1 = max( temp1, abs( wr( j-il+1 )-d4( n-j+
1655 $ 1 ) ) / ( abstol+abs( wr( j-il+1 ) ) ) )
1658 result( 28 ) = temp1 / temp2
1671 CALL dcopy( n, sd, 1, d5, 1 )
1673 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1674 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1678 il = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1679 iu = 1 + ( n-1 )*int( dlarnd( 1, iseed2 ) )
1685 CALL zstemr(
'V',
'I', n, d5, rwork, vl, vu, il, iu,
1686 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1687 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1688 $ liwork-2*n, iinfo )
1689 IF( iinfo.NE.0 )
THEN
1690 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,I)', iinfo,
1693 IF( iinfo.LT.0 )
THEN
1696 result( 29 ) = ulpinv
1708 CALL dcopy( n, sd, 1, d5, 1 )
1710 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1713 CALL zstemr(
'N',
'I', n, d5, rwork, vl, vu, il, iu,
1714 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1715 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1716 $ liwork-2*n, iinfo )
1717 IF( iinfo.NE.0 )
THEN
1718 WRITE( nounit, fmt = 9999 )
'ZSTEMR(N,I)', iinfo,
1721 IF( iinfo.LT.0 )
THEN
1724 result( 31 ) = ulpinv
1734 DO 240 j = 1, iu - il + 1
1735 temp1 = max( temp1, abs( d1( j ) ),
1737 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1740 result( 31 ) = temp2 / max( unfl,
1741 $ ulp*max( temp1, temp2 ) )
1748 CALL dcopy( n, sd, 1, d5, 1 )
1750 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1751 CALL zlaset(
'Full', n, n, czero, cone, z, ldu )
1757 vl = d2( il ) - max( half*
1758 $ ( d2( il )-d2( il-1 ) ), ulp*anorm,
1761 vl = d2( 1 ) - max( half*( d2( n )-d2( 1 ) ),
1762 $ ulp*anorm, two*rtunfl )
1765 vu = d2( iu ) + max( half*
1766 $ ( d2( iu+1 )-d2( iu ) ), ulp*anorm,
1769 vu = d2( n ) + max( half*( d2( n )-d2( 1 ) ),
1770 $ ulp*anorm, two*rtunfl )
1777 CALL zstemr(
'V',
'V', n, d5, rwork, vl, vu, il, iu,
1778 $ m, d1, z, ldu, m, iwork( 1 ), tryrac,
1779 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1780 $ liwork-2*n, iinfo )
1781 IF( iinfo.NE.0 )
THEN
1782 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,V)', iinfo,
1785 IF( iinfo.LT.0 )
THEN
1788 result( 32 ) = ulpinv
1795 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work,
1796 $ m, rwork, result( 32 ) )
1802 CALL dcopy( n, sd, 1, d5, 1 )
1804 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1807 CALL zstemr(
'N',
'V', n, d5, rwork, vl, vu, il, iu,
1808 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1809 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1810 $ liwork-2*n, iinfo )
1811 IF( iinfo.NE.0 )
THEN
1812 WRITE( nounit, fmt = 9999 )
'ZSTEMR(N,V)', iinfo,
1815 IF( iinfo.LT.0 )
THEN
1818 result( 34 ) = ulpinv
1828 DO 250 j = 1, iu - il + 1
1829 temp1 = max( temp1, abs( d1( j ) ),
1831 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1834 result( 34 ) = temp2 / max( unfl,
1835 $ ulp*max( temp1, temp2 ) )
1850 CALL dcopy( n, sd, 1, d5, 1 )
1852 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1856 CALL zstemr(
'V',
'A', n, d5, rwork, vl, vu, il, iu,
1857 $ m, d1, z, ldu, n, iwork( 1 ), tryrac,
1858 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1859 $ liwork-2*n, iinfo )
1860 IF( iinfo.NE.0 )
THEN
1861 WRITE( nounit, fmt = 9999 )
'ZSTEMR(V,A)', iinfo, n,
1864 IF( iinfo.LT.0 )
THEN
1867 result( 35 ) = ulpinv
1874 CALL zstt22( n, m, 0, sd, se, d1, dumma, z, ldu, work, m,
1875 $ rwork, result( 35 ) )
1881 CALL dcopy( n, sd, 1, d5, 1 )
1883 $
CALL dcopy( n-1, se, 1, rwork, 1 )
1886 CALL zstemr(
'N',
'A', n, d5, rwork, vl, vu, il, iu,
1887 $ m, d2, z, ldu, n, iwork( 1 ), tryrac,
1888 $ rwork( n+1 ), lrwork-n, iwork( 2*n+1 ),
1889 $ liwork-2*n, iinfo )
1890 IF( iinfo.NE.0 )
THEN
1891 WRITE( nounit, fmt = 9999 )
'ZSTEMR(N,A)', iinfo, n,
1894 IF( iinfo.LT.0 )
THEN
1897 result( 37 ) = ulpinv
1908 temp1 = max( temp1, abs( d1( j ) ), abs( d2( j ) ) )
1909 temp2 = max( temp2, abs( d1( j )-d2( j ) ) )
1912 result( 37 ) = temp2 / max( unfl,
1913 $ ulp*max( temp1, temp2 ) )
1917 ntestt = ntestt + ntest
1924 DO 290 jr = 1, ntest
1925 IF( result( jr ).GE.thresh )
THEN
1930 IF( nerrs.EQ.0 )
THEN
1931 WRITE( nounit, fmt = 9998 )
'ZST'
1932 WRITE( nounit, fmt = 9997 )
1933 WRITE( nounit, fmt = 9996 )
1934 WRITE( nounit, fmt = 9995 )
'Hermitian'
1935 WRITE( nounit, fmt = 9994 )
1939 WRITE( nounit, fmt = 9987 )
1942 IF( result( jr ).LT.10000.0d0 )
THEN
1943 WRITE( nounit, fmt = 9989 )n, jtype, ioldsd, jr,
1946 WRITE( nounit, fmt = 9988 )n, jtype, ioldsd, jr,
1956 CALL dlasum(
'ZST', nounit, nerrs, ntestt )
1959 9999
FORMAT(
' ZCHKST: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1960 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
1962 9998
FORMAT( / 1x, a3,
' -- Complex Hermitian eigenvalue problem' )
1963 9997
FORMAT(
' Matrix types (see ZCHKST for details): ' )
1965 9996
FORMAT( /
' Special Matrices:',
1966 $ /
' 1=Zero matrix. ',
1967 $
' 5=Diagonal: clustered entries.',
1968 $ /
' 2=Identity matrix. ',
1969 $
' 6=Diagonal: large, evenly spaced.',
1970 $ /
' 3=Diagonal: evenly spaced entries. ',
1971 $
' 7=Diagonal: small, evenly spaced.',
1972 $ /
' 4=Diagonal: geometr. spaced entries.' )
1973 9995
FORMAT(
' Dense ', a,
' Matrices:',
1974 $ /
' 8=Evenly spaced eigenvals. ',
1975 $
' 12=Small, evenly spaced eigenvals.',
1976 $ /
' 9=Geometrically spaced eigenvals. ',
1977 $
' 13=Matrix with random O(1) entries.',
1978 $ /
' 10=Clustered eigenvalues. ',
1979 $
' 14=Matrix with large random entries.',
1980 $ /
' 11=Large, evenly spaced eigenvals. ',
1981 $
' 15=Matrix with small random entries.' )
1982 9994
FORMAT(
' 16=Positive definite, evenly spaced eigenvalues',
1983 $ /
' 17=Positive definite, geometrically spaced eigenvlaues',
1984 $ /
' 18=Positive definite, clustered eigenvalues',
1985 $ /
' 19=Positive definite, small evenly spaced eigenvalues',
1986 $ /
' 20=Positive definite, large evenly spaced eigenvalues',
1987 $ /
' 21=Diagonally dominant tridiagonal, geometrically',
1988 $
' spaced eigenvalues' )
1990 9989
FORMAT(
' Matrix order=', i5,
', type=', i2,
', seed=',
1991 $ 4( i4,
',' ),
' result ', i3,
' is', 0p, f8.2 )
1992 9988
FORMAT(
' Matrix order=', i5,
', type=', i2,
', seed=',
1993 $ 4( i4,
',' ),
' result ', i3,
' is', 1p, d10.3 )
1995 9987
FORMAT( /
'Test performed: see ZCHKST for details.', / )