453
454
455
456
457
458
459 INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
460 $ NTYPES
461 DOUBLE PRECISION THRESH
462
463
464 LOGICAL DOTYPE( * )
465 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
466 DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ),
467 $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ),
468 $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ),
469 $ WA3( * ), WORK( * ), Z( LDU, * )
470
471
472
473
474
475 DOUBLE PRECISION ZERO, ONE, TWO, TEN
476 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
477 $ ten = 10.0d0 )
478 DOUBLE PRECISION HALF
479 parameter( half = 0.5d0 )
480 INTEGER MAXTYP
481 parameter( maxtyp = 18 )
482
483
484 LOGICAL BADNN
485 CHARACTER UPLO
486 INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW,
487 $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL,
488 $ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2,
489 $ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
490 $ NTESTT
491 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
492 $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL,
493 $ VL, VU
494
495
496 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
497 $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
498 $ KTYPE( MAXTYP )
499
500
501 DOUBLE PRECISION DLAMCH, DLARND, DSXT1
503
504
510
511
512 CHARACTER*32 SRNAMT
513
514
515 COMMON / srnamc / srnamt
516
517
518 INTRINSIC abs, dble, int, log, max, min, sqrt
519
520
521 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 3*9 /
522 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
523 $ 2, 3, 1, 2, 3 /
524 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
525 $ 0, 0, 4, 4, 4 /
526
527
528
529
530
531 vl = zero
532 vu = zero
533
534
535
536 ntestt = 0
537 info = 0
538
539 badnn = .false.
540 nmax = 1
541 DO 10 j = 1, nsizes
542 nmax = max( nmax, nn( j ) )
543 IF( nn( j ).LT.0 )
544 $ badnn = .true.
545 10 CONTINUE
546
547
548
549 IF( nsizes.LT.0 ) THEN
550 info = -1
551 ELSE IF( badnn ) THEN
552 info = -2
553 ELSE IF( ntypes.LT.0 ) THEN
554 info = -3
555 ELSE IF( lda.LT.nmax ) THEN
556 info = -9
557 ELSE IF( ldu.LT.nmax ) THEN
558 info = -16
559 ELSE IF( 2*max( 2, nmax )**2.GT.lwork ) THEN
560 info = -21
561 END IF
562
563 IF( info.NE.0 ) THEN
564 CALL xerbla(
'DDRVST', -info )
565 RETURN
566 END IF
567
568
569
570 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
571 $ RETURN
572
573
574
575 unfl =
dlamch(
'Safe minimum' )
576 ovfl =
dlamch(
'Overflow' )
579 ulpinv = one / ulp
580 rtunfl = sqrt( unfl )
581 rtovfl = sqrt( ovfl )
582
583
584
585 DO 20 i = 1, 4
586 iseed2( i ) = iseed( i )
587 iseed3( i ) = iseed( i )
588 20 CONTINUE
589
590 nerrs = 0
591 nmats = 0
592
593
594 DO 1740 jsize = 1, nsizes
595 n = nn( jsize )
596 IF( n.GT.0 ) THEN
597 lgn = int( log( dble( n ) ) / log( two ) )
598 IF( 2**lgn.LT.n )
599 $ lgn = lgn + 1
600 IF( 2**lgn.LT.n )
601 $ lgn = lgn + 1
602 lwedc = 1 + 4*n + 2*n*lgn + 4*n**2
603
604 liwedc = 3 + 5*n
605 ELSE
606 lwedc = 9
607
608 liwedc = 8
609 END IF
610 aninv = one / dble( max( 1, n ) )
611
612 IF( nsizes.NE.1 ) THEN
613 mtypes = min( maxtyp, ntypes )
614 ELSE
615 mtypes = min( maxtyp+1, ntypes )
616 END IF
617
618 DO 1730 jtype = 1, mtypes
619
620 IF( .NOT.dotype( jtype ) )
621 $ GO TO 1730
622 nmats = nmats + 1
623 ntest = 0
624
625 DO 30 j = 1, 4
626 ioldsd( j ) = iseed( j )
627 30 CONTINUE
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644 IF( mtypes.GT.maxtyp )
645 $ GO TO 110
646
647 itype = ktype( jtype )
648 imode = kmode( jtype )
649
650
651
652 GO TO ( 40, 50, 60 )kmagn( jtype )
653
654 40 CONTINUE
655 anorm = one
656 GO TO 70
657
658 50 CONTINUE
659 anorm = ( rtovfl*ulp )*aninv
660 GO TO 70
661
662 60 CONTINUE
663 anorm = rtunfl*n*ulpinv
664 GO TO 70
665
666 70 CONTINUE
667
668 CALL dlaset(
'Full', lda, n, zero, zero, a, lda )
669 iinfo = 0
670 cond = ulpinv
671
672
673
674
675
676 IF( itype.EQ.1 ) THEN
677 iinfo = 0
678
679 ELSE IF( itype.EQ.2 ) THEN
680
681
682
683 DO 80 jcol = 1, n
684 a( jcol, jcol ) = anorm
685 80 CONTINUE
686
687 ELSE IF( itype.EQ.4 ) THEN
688
689
690
691 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
692 $ anorm, 0, 0, 'N', a, lda, work( n+1 ),
693 $ iinfo )
694
695 ELSE IF( itype.EQ.5 ) THEN
696
697
698
699 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
700 $ anorm, n, n, 'N', a, lda, work( n+1 ),
701 $ iinfo )
702
703 ELSE IF( itype.EQ.7 ) THEN
704
705
706
707 idumma( 1 ) = 1
708 CALL dlatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
709 $ 'T', 'N', work( n+1 ), 1, one,
710 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
711 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
712
713 ELSE IF( itype.EQ.8 ) THEN
714
715
716
717 idumma( 1 ) = 1
718 CALL dlatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
719 $ 'T', 'N', work( n+1 ), 1, one,
720 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
721 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
722
723 ELSE IF( itype.EQ.9 ) THEN
724
725
726
727 ihbw = int( ( n-1 )*
dlarnd( 1, iseed3 ) )
728 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
729 $ anorm, ihbw, ihbw, 'Z', u, ldu, work( n+1 ),
730 $ iinfo )
731
732
733
734 CALL dlaset(
'Full', lda, n, zero, zero, a, lda )
735 DO 100 idiag = -ihbw, ihbw
736 irow = ihbw - idiag + 1
737 j1 = max( 1, idiag+1 )
738 j2 = min( n, n+idiag )
739 DO 90 j = j1, j2
740 i = j - idiag
741 a( i, j ) = u( irow, j )
742 90 CONTINUE
743 100 CONTINUE
744 ELSE
745 iinfo = 1
746 END IF
747
748 IF( iinfo.NE.0 ) THEN
749 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
750 $ ioldsd
751 info = abs( iinfo )
752 RETURN
753 END IF
754
755 110 CONTINUE
756
757 abstol = unfl + unfl
758 IF( n.LE.1 ) THEN
759 il = 1
760 iu = n
761 ELSE
762 il = 1 + ( n-1 )*int(
dlarnd( 1, iseed2 ) )
763 iu = 1 + ( n-1 )*int(
dlarnd( 1, iseed2 ) )
764 IF( il.GT.iu ) THEN
765 itemp = il
766 il = iu
767 iu = itemp
768 END IF
769 END IF
770
771
772
773 IF( jtype.LE.7 ) THEN
774 ntest = 1
775 DO 120 i = 1, n
776 d1( i ) = dble( a( i, i ) )
777 120 CONTINUE
778 DO 130 i = 1, n - 1
779 d2( i ) = dble( a( i+1, i ) )
780 130 CONTINUE
781 srnamt = 'DSTEV'
782 CALL dstev(
'V', n, d1, d2, z, ldu, work, iinfo )
783 IF( iinfo.NE.0 ) THEN
784 WRITE( nounit, fmt = 9999 )'DSTEV(V)', iinfo, n,
785 $ jtype, ioldsd
786 info = abs( iinfo )
787 IF( iinfo.LT.0 ) THEN
788 RETURN
789 ELSE
790 result( 1 ) = ulpinv
791 result( 2 ) = ulpinv
792 result( 3 ) = ulpinv
793 GO TO 180
794 END IF
795 END IF
796
797
798
799 DO 140 i = 1, n
800 d3( i ) = dble( a( i, i ) )
801 140 CONTINUE
802 DO 150 i = 1, n - 1
803 d4( i ) = dble( a( i+1, i ) )
804 150 CONTINUE
805 CALL dstt21( n, 0, d3, d4, d1, d2, z, ldu, work,
806 $ result( 1 ) )
807
808 ntest = 3
809 DO 160 i = 1, n - 1
810 d4( i ) = dble( a( i+1, i ) )
811 160 CONTINUE
812 srnamt = 'DSTEV'
813 CALL dstev(
'N', n, d3, d4, z, ldu, work, iinfo )
814 IF( iinfo.NE.0 ) THEN
815 WRITE( nounit, fmt = 9999 )'DSTEV(N)', iinfo, n,
816 $ jtype, ioldsd
817 info = abs( iinfo )
818 IF( iinfo.LT.0 ) THEN
819 RETURN
820 ELSE
821 result( 3 ) = ulpinv
822 GO TO 180
823 END IF
824 END IF
825
826
827
828 temp1 = zero
829 temp2 = zero
830 DO 170 j = 1, n
831 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
832 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
833 170 CONTINUE
834 result( 3 ) = temp2 / max( unfl,
835 $ ulp*max( temp1, temp2 ) )
836
837 180 CONTINUE
838
839 ntest = 4
840 DO 190 i = 1, n
841 eveigs( i ) = d3( i )
842 d1( i ) = dble( a( i, i ) )
843 190 CONTINUE
844 DO 200 i = 1, n - 1
845 d2( i ) = dble( a( i+1, i ) )
846 200 CONTINUE
847 srnamt = 'DSTEVX'
848 CALL dstevx(
'V',
'A', n, d1, d2, vl, vu, il, iu, abstol,
849 $ m, wa1, z, ldu, work, iwork, iwork( 5*n+1 ),
850 $ iinfo )
851 IF( iinfo.NE.0 ) THEN
852 WRITE( nounit, fmt = 9999 )'DSTEVX(V,A)', iinfo, n,
853 $ jtype, ioldsd
854 info = abs( iinfo )
855 IF( iinfo.LT.0 ) THEN
856 RETURN
857 ELSE
858 result( 4 ) = ulpinv
859 result( 5 ) = ulpinv
860 result( 6 ) = ulpinv
861 GO TO 250
862 END IF
863 END IF
864 IF( n.GT.0 ) THEN
865 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
866 ELSE
867 temp3 = zero
868 END IF
869
870
871
872 DO 210 i = 1, n
873 d3( i ) = dble( a( i, i ) )
874 210 CONTINUE
875 DO 220 i = 1, n - 1
876 d4( i ) = dble( a( i+1, i ) )
877 220 CONTINUE
878 CALL dstt21( n, 0, d3, d4, wa1, d2, z, ldu, work,
879 $ result( 4 ) )
880
881 ntest = 6
882 DO 230 i = 1, n - 1
883 d4( i ) = dble( a( i+1, i ) )
884 230 CONTINUE
885 srnamt = 'DSTEVX'
886 CALL dstevx(
'N',
'A', n, d3, d4, vl, vu, il, iu, abstol,
887 $ m2, wa2, z, ldu, work, iwork,
888 $ iwork( 5*n+1 ), iinfo )
889 IF( iinfo.NE.0 ) THEN
890 WRITE( nounit, fmt = 9999 )'DSTEVX(N,A)', iinfo, n,
891 $ jtype, ioldsd
892 info = abs( iinfo )
893 IF( iinfo.LT.0 ) THEN
894 RETURN
895 ELSE
896 result( 6 ) = ulpinv
897 GO TO 250
898 END IF
899 END IF
900
901
902
903 temp1 = zero
904 temp2 = zero
905 DO 240 j = 1, n
906 temp1 = max( temp1, abs( wa2( j ) ),
907 $ abs( eveigs( j ) ) )
908 temp2 = max( temp2, abs( wa2( j )-eveigs( j ) ) )
909 240 CONTINUE
910 result( 6 ) = temp2 / max( unfl,
911 $ ulp*max( temp1, temp2 ) )
912
913 250 CONTINUE
914
915 ntest = 7
916 DO 260 i = 1, n
917 d1( i ) = dble( a( i, i ) )
918 260 CONTINUE
919 DO 270 i = 1, n - 1
920 d2( i ) = dble( a( i+1, i ) )
921 270 CONTINUE
922 srnamt = 'DSTEVR'
923 CALL dstevr(
'V',
'A', n, d1, d2, vl, vu, il, iu, abstol,
924 $ m, wa1, z, ldu, iwork, work, lwork,
925 $ iwork(2*n+1), liwork-2*n, iinfo )
926 IF( iinfo.NE.0 ) THEN
927 WRITE( nounit, fmt = 9999 )'DSTEVR(V,A)', iinfo, n,
928 $ jtype, ioldsd
929 info = abs( iinfo )
930 IF( iinfo.LT.0 ) THEN
931 RETURN
932 ELSE
933 result( 7 ) = ulpinv
934 result( 8 ) = ulpinv
935 GO TO 320
936 END IF
937 END IF
938 IF( n.GT.0 ) THEN
939 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
940 ELSE
941 temp3 = zero
942 END IF
943
944
945
946 DO 280 i = 1, n
947 d3( i ) = dble( a( i, i ) )
948 280 CONTINUE
949 DO 290 i = 1, n - 1
950 d4( i ) = dble( a( i+1, i ) )
951 290 CONTINUE
952 CALL dstt21( n, 0, d3, d4, wa1, d2, z, ldu, work,
953 $ result( 7 ) )
954
955 ntest = 9
956 DO 300 i = 1, n - 1
957 d4( i ) = dble( a( i+1, i ) )
958 300 CONTINUE
959 srnamt = 'DSTEVR'
960 CALL dstevr(
'N',
'A', n, d3, d4, vl, vu, il, iu, abstol,
961 $ m2, wa2, z, ldu, iwork, work, lwork,
962 $ iwork(2*n+1), liwork-2*n, iinfo )
963 IF( iinfo.NE.0 ) THEN
964 WRITE( nounit, fmt = 9999 )'DSTEVR(N,A)', iinfo, n,
965 $ jtype, ioldsd
966 info = abs( iinfo )
967 IF( iinfo.LT.0 ) THEN
968 RETURN
969 ELSE
970 result( 9 ) = ulpinv
971 GO TO 320
972 END IF
973 END IF
974
975
976
977 temp1 = zero
978 temp2 = zero
979 DO 310 j = 1, n
980 temp1 = max( temp1, abs( wa2( j ) ),
981 $ abs( eveigs( j ) ) )
982 temp2 = max( temp2, abs( wa2( j )-eveigs( j ) ) )
983 310 CONTINUE
984 result( 9 ) = temp2 / max( unfl,
985 $ ulp*max( temp1, temp2 ) )
986
987 320 CONTINUE
988
989
990 ntest = 10
991 DO 330 i = 1, n
992 d1( i ) = dble( a( i, i ) )
993 330 CONTINUE
994 DO 340 i = 1, n - 1
995 d2( i ) = dble( a( i+1, i ) )
996 340 CONTINUE
997 srnamt = 'DSTEVX'
998 CALL dstevx(
'V',
'I', n, d1, d2, vl, vu, il, iu, abstol,
999 $ m2, wa2, z, ldu, work, iwork,
1000 $ iwork( 5*n+1 ), iinfo )
1001 IF( iinfo.NE.0 ) THEN
1002 WRITE( nounit, fmt = 9999 )'DSTEVX(V,I)', iinfo, n,
1003 $ jtype, ioldsd
1004 info = abs( iinfo )
1005 IF( iinfo.LT.0 ) THEN
1006 RETURN
1007 ELSE
1008 result( 10 ) = ulpinv
1009 result( 11 ) = ulpinv
1010 result( 12 ) = ulpinv
1011 GO TO 380
1012 END IF
1013 END IF
1014
1015
1016
1017 DO 350 i = 1, n
1018 d3( i ) = dble( a( i, i ) )
1019 350 CONTINUE
1020 DO 360 i = 1, n - 1
1021 d4( i ) = dble( a( i+1, i ) )
1022 360 CONTINUE
1023 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1024 $ max( 1, m2 ), result( 10 ) )
1025
1026
1027 ntest = 12
1028 DO 370 i = 1, n - 1
1029 d4( i ) = dble( a( i+1, i ) )
1030 370 CONTINUE
1031 srnamt = 'DSTEVX'
1032 CALL dstevx(
'N',
'I', n, d3, d4, vl, vu, il, iu, abstol,
1033 $ m3, wa3, z, ldu, work, iwork,
1034 $ iwork( 5*n+1 ), iinfo )
1035 IF( iinfo.NE.0 ) THEN
1036 WRITE( nounit, fmt = 9999 )'DSTEVX(N,I)', iinfo, n,
1037 $ jtype, ioldsd
1038 info = abs( iinfo )
1039 IF( iinfo.LT.0 ) THEN
1040 RETURN
1041 ELSE
1042 result( 12 ) = ulpinv
1043 GO TO 380
1044 END IF
1045 END IF
1046
1047
1048
1049 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1050 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1051 result( 12 ) = ( temp1+temp2 ) / max( unfl, ulp*temp3 )
1052
1053 380 CONTINUE
1054
1055 ntest = 12
1056 IF( n.GT.0 ) THEN
1057 IF( il.NE.1 ) THEN
1058 vl = wa1( il ) - max( half*
1059 $ ( wa1( il )-wa1( il-1 ) ), ten*ulp*temp3,
1060 $ ten*rtunfl )
1061 ELSE
1062 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1063 $ ten*ulp*temp3, ten*rtunfl )
1064 END IF
1065 IF( iu.NE.n ) THEN
1066 vu = wa1( iu ) + max( half*
1067 $ ( wa1( iu+1 )-wa1( iu ) ), ten*ulp*temp3,
1068 $ ten*rtunfl )
1069 ELSE
1070 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1071 $ ten*ulp*temp3, ten*rtunfl )
1072 END IF
1073 ELSE
1074 vl = zero
1075 vu = one
1076 END IF
1077
1078 DO 390 i = 1, n
1079 d1( i ) = dble( a( i, i ) )
1080 390 CONTINUE
1081 DO 400 i = 1, n - 1
1082 d2( i ) = dble( a( i+1, i ) )
1083 400 CONTINUE
1084 srnamt = 'DSTEVX'
1085 CALL dstevx(
'V',
'V', n, d1, d2, vl, vu, il, iu, abstol,
1086 $ m2, wa2, z, ldu, work, iwork,
1087 $ iwork( 5*n+1 ), iinfo )
1088 IF( iinfo.NE.0 ) THEN
1089 WRITE( nounit, fmt = 9999 )'DSTEVX(V,V)', iinfo, n,
1090 $ jtype, ioldsd
1091 info = abs( iinfo )
1092 IF( iinfo.LT.0 ) THEN
1093 RETURN
1094 ELSE
1095 result( 13 ) = ulpinv
1096 result( 14 ) = ulpinv
1097 result( 15 ) = ulpinv
1098 GO TO 440
1099 END IF
1100 END IF
1101
1102 IF( m2.EQ.0 .AND. n.GT.0 ) THEN
1103 result( 13 ) = ulpinv
1104 result( 14 ) = ulpinv
1105 result( 15 ) = ulpinv
1106 GO TO 440
1107 END IF
1108
1109
1110
1111 DO 410 i = 1, n
1112 d3( i ) = dble( a( i, i ) )
1113 410 CONTINUE
1114 DO 420 i = 1, n - 1
1115 d4( i ) = dble( a( i+1, i ) )
1116 420 CONTINUE
1117 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1118 $ max( 1, m2 ), result( 13 ) )
1119
1120 ntest = 15
1121 DO 430 i = 1, n - 1
1122 d4( i ) = dble( a( i+1, i ) )
1123 430 CONTINUE
1124 srnamt = 'DSTEVX'
1125 CALL dstevx(
'N',
'V', n, d3, d4, vl, vu, il, iu, abstol,
1126 $ m3, wa3, z, ldu, work, iwork,
1127 $ iwork( 5*n+1 ), iinfo )
1128 IF( iinfo.NE.0 ) THEN
1129 WRITE( nounit, fmt = 9999 )'DSTEVX(N,V)', iinfo, n,
1130 $ jtype, ioldsd
1131 info = abs( iinfo )
1132 IF( iinfo.LT.0 ) THEN
1133 RETURN
1134 ELSE
1135 result( 15 ) = ulpinv
1136 GO TO 440
1137 END IF
1138 END IF
1139
1140
1141
1142 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1143 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1144 result( 15 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1145
1146 440 CONTINUE
1147
1148 ntest = 16
1149 DO 450 i = 1, n
1150 d1( i ) = dble( a( i, i ) )
1151 450 CONTINUE
1152 DO 460 i = 1, n - 1
1153 d2( i ) = dble( a( i+1, i ) )
1154 460 CONTINUE
1155 srnamt = 'DSTEVD'
1156 CALL dstevd(
'V', n, d1, d2, z, ldu, work, lwedc, iwork,
1157 $ liwedc, iinfo )
1158 IF( iinfo.NE.0 ) THEN
1159 WRITE( nounit, fmt = 9999 )'DSTEVD(V)', iinfo, n,
1160 $ jtype, ioldsd
1161 info = abs( iinfo )
1162 IF( iinfo.LT.0 ) THEN
1163 RETURN
1164 ELSE
1165 result( 16 ) = ulpinv
1166 result( 17 ) = ulpinv
1167 result( 18 ) = ulpinv
1168 GO TO 510
1169 END IF
1170 END IF
1171
1172
1173
1174 DO 470 i = 1, n
1175 d3( i ) = dble( a( i, i ) )
1176 470 CONTINUE
1177 DO 480 i = 1, n - 1
1178 d4( i ) = dble( a( i+1, i ) )
1179 480 CONTINUE
1180 CALL dstt21( n, 0, d3, d4, d1, d2, z, ldu, work,
1181 $ result( 16 ) )
1182
1183 ntest = 18
1184 DO 490 i = 1, n - 1
1185 d4( i ) = dble( a( i+1, i ) )
1186 490 CONTINUE
1187 srnamt = 'DSTEVD'
1188 CALL dstevd(
'N', n, d3, d4, z, ldu, work, lwedc, iwork,
1189 $ liwedc, iinfo )
1190 IF( iinfo.NE.0 ) THEN
1191 WRITE( nounit, fmt = 9999 )'DSTEVD(N)', iinfo, n,
1192 $ jtype, ioldsd
1193 info = abs( iinfo )
1194 IF( iinfo.LT.0 ) THEN
1195 RETURN
1196 ELSE
1197 result( 18 ) = ulpinv
1198 GO TO 510
1199 END IF
1200 END IF
1201
1202
1203
1204 temp1 = zero
1205 temp2 = zero
1206 DO 500 j = 1, n
1207 temp1 = max( temp1, abs( eveigs( j ) ),
1208 $ abs( d3( j ) ) )
1209 temp2 = max( temp2, abs( eveigs( j )-d3( j ) ) )
1210 500 CONTINUE
1211 result( 18 ) = temp2 / max( unfl,
1212 $ ulp*max( temp1, temp2 ) )
1213
1214 510 CONTINUE
1215
1216 ntest = 19
1217 DO 520 i = 1, n
1218 d1( i ) = dble( a( i, i ) )
1219 520 CONTINUE
1220 DO 530 i = 1, n - 1
1221 d2( i ) = dble( a( i+1, i ) )
1222 530 CONTINUE
1223 srnamt = 'DSTEVR'
1224 CALL dstevr(
'V',
'I', n, d1, d2, vl, vu, il, iu, abstol,
1225 $ m2, wa2, z, ldu, iwork, work, lwork,
1226 $ iwork(2*n+1), liwork-2*n, iinfo )
1227 IF( iinfo.NE.0 ) THEN
1228 WRITE( nounit, fmt = 9999 )'DSTEVR(V,I)', iinfo, n,
1229 $ jtype, ioldsd
1230 info = abs( iinfo )
1231 IF( iinfo.LT.0 ) THEN
1232 RETURN
1233 ELSE
1234 result( 19 ) = ulpinv
1235 result( 20 ) = ulpinv
1236 result( 21 ) = ulpinv
1237 GO TO 570
1238 END IF
1239 END IF
1240
1241
1242
1243 DO 540 i = 1, n
1244 d3( i ) = dble( a( i, i ) )
1245 540 CONTINUE
1246 DO 550 i = 1, n - 1
1247 d4( i ) = dble( a( i+1, i ) )
1248 550 CONTINUE
1249 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1250 $ max( 1, m2 ), result( 19 ) )
1251
1252
1253 ntest = 21
1254 DO 560 i = 1, n - 1
1255 d4( i ) = dble( a( i+1, i ) )
1256 560 CONTINUE
1257 srnamt = 'DSTEVR'
1258 CALL dstevr(
'N',
'I', n, d3, d4, vl, vu, il, iu, abstol,
1259 $ m3, wa3, z, ldu, iwork, work, lwork,
1260 $ iwork(2*n+1), liwork-2*n, iinfo )
1261 IF( iinfo.NE.0 ) THEN
1262 WRITE( nounit, fmt = 9999 )'DSTEVR(N,I)', iinfo, n,
1263 $ jtype, ioldsd
1264 info = abs( iinfo )
1265 IF( iinfo.LT.0 ) THEN
1266 RETURN
1267 ELSE
1268 result( 21 ) = ulpinv
1269 GO TO 570
1270 END IF
1271 END IF
1272
1273
1274
1275 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1276 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1277 result( 21 ) = ( temp1+temp2 ) / max( unfl, ulp*temp3 )
1278
1279 570 CONTINUE
1280
1281 ntest = 21
1282 IF( n.GT.0 ) THEN
1283 IF( il.NE.1 ) THEN
1284 vl = wa1( il ) - max( half*
1285 $ ( wa1( il )-wa1( il-1 ) ), ten*ulp*temp3,
1286 $ ten*rtunfl )
1287 ELSE
1288 vl = wa1( 1 ) - max( half*( wa1( n )-wa1( 1 ) ),
1289 $ ten*ulp*temp3, ten*rtunfl )
1290 END IF
1291 IF( iu.NE.n ) THEN
1292 vu = wa1( iu ) + max( half*
1293 $ ( wa1( iu+1 )-wa1( iu ) ), ten*ulp*temp3,
1294 $ ten*rtunfl )
1295 ELSE
1296 vu = wa1( n ) + max( half*( wa1( n )-wa1( 1 ) ),
1297 $ ten*ulp*temp3, ten*rtunfl )
1298 END IF
1299 ELSE
1300 vl = zero
1301 vu = one
1302 END IF
1303
1304 DO 580 i = 1, n
1305 d1( i ) = dble( a( i, i ) )
1306 580 CONTINUE
1307 DO 590 i = 1, n - 1
1308 d2( i ) = dble( a( i+1, i ) )
1309 590 CONTINUE
1310 srnamt = 'DSTEVR'
1311 CALL dstevr(
'V',
'V', n, d1, d2, vl, vu, il, iu, abstol,
1312 $ m2, wa2, z, ldu, iwork, work, lwork,
1313 $ iwork(2*n+1), liwork-2*n, iinfo )
1314 IF( iinfo.NE.0 ) THEN
1315 WRITE( nounit, fmt = 9999 )'DSTEVR(V,V)', iinfo, n,
1316 $ jtype, ioldsd
1317 info = abs( iinfo )
1318 IF( iinfo.LT.0 ) THEN
1319 RETURN
1320 ELSE
1321 result( 22 ) = ulpinv
1322 result( 23 ) = ulpinv
1323 result( 24 ) = ulpinv
1324 GO TO 630
1325 END IF
1326 END IF
1327
1328 IF( m2.EQ.0 .AND. n.GT.0 ) THEN
1329 result( 22 ) = ulpinv
1330 result( 23 ) = ulpinv
1331 result( 24 ) = ulpinv
1332 GO TO 630
1333 END IF
1334
1335
1336
1337 DO 600 i = 1, n
1338 d3( i ) = dble( a( i, i ) )
1339 600 CONTINUE
1340 DO 610 i = 1, n - 1
1341 d4( i ) = dble( a( i+1, i ) )
1342 610 CONTINUE
1343 CALL dstt22( n, m2, 0, d3, d4, wa2, d2, z, ldu, work,
1344 $ max( 1, m2 ), result( 22 ) )
1345
1346 ntest = 24
1347 DO 620 i = 1, n - 1
1348 d4( i ) = dble( a( i+1, i ) )
1349 620 CONTINUE
1350 srnamt = 'DSTEVR'
1351 CALL dstevr(
'N',
'V', n, d3, d4, vl, vu, il, iu, abstol,
1352 $ m3, wa3, z, ldu, iwork, work, lwork,
1353 $ iwork(2*n+1), liwork-2*n, iinfo )
1354 IF( iinfo.NE.0 ) THEN
1355 WRITE( nounit, fmt = 9999 )'DSTEVR(N,V)', iinfo, n,
1356 $ jtype, ioldsd
1357 info = abs( iinfo )
1358 IF( iinfo.LT.0 ) THEN
1359 RETURN
1360 ELSE
1361 result( 24 ) = ulpinv
1362 GO TO 630
1363 END IF
1364 END IF
1365
1366
1367
1368 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1369 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1370 result( 24 ) = ( temp1+temp2 ) / max( unfl, temp3*ulp )
1371
1372 630 CONTINUE
1373
1374
1375
1376 ELSE
1377
1378 DO 640 i = 1, 24
1379 result( i ) = zero
1380 640 CONTINUE
1381 ntest = 24
1382 END IF
1383
1384
1385
1386
1387 DO 1720 iuplo = 0, 1
1388 IF( iuplo.EQ.0 ) THEN
1389 uplo = 'L'
1390 ELSE
1391 uplo = 'U'
1392 END IF
1393
1394
1395
1396 CALL dlacpy(
' ', n, n, a, lda, v, ldu )
1397
1398 ntest = ntest + 1
1399 srnamt = 'DSYEV'
1400 CALL dsyev(
'V', uplo, n, a, ldu, d1, work, lwork,
1401 $ iinfo )
1402 IF( iinfo.NE.0 ) THEN
1403 WRITE( nounit, fmt = 9999 )'DSYEV(V,' // uplo // ')',
1404 $ iinfo, n, jtype, ioldsd
1405 info = abs( iinfo )
1406 IF( iinfo.LT.0 ) THEN
1407 RETURN
1408 ELSE
1409 result( ntest ) = ulpinv
1410 result( ntest+1 ) = ulpinv
1411 result( ntest+2 ) = ulpinv
1412 GO TO 660
1413 END IF
1414 END IF
1415
1416
1417
1418 CALL dsyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
1419 $ ldu, tau, work, result( ntest ) )
1420
1421 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
1422
1423 ntest = ntest + 2
1424 srnamt = 'DSYEV'
1425 CALL dsyev(
'N', uplo, n, a, ldu, d3, work, lwork,
1426 $ iinfo )
1427 IF( iinfo.NE.0 ) THEN
1428 WRITE( nounit, fmt = 9999 )'DSYEV(N,' // uplo // ')',
1429 $ iinfo, n, jtype, ioldsd
1430 info = abs( iinfo )
1431 IF( iinfo.LT.0 ) THEN
1432 RETURN
1433 ELSE
1434 result( ntest ) = ulpinv
1435 GO TO 660
1436 END IF
1437 END IF
1438
1439
1440
1441 temp1 = zero
1442 temp2 = zero
1443 DO 650 j = 1, n
1444 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1445 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1446 650 CONTINUE
1447 result( ntest ) = temp2 / max( unfl,
1448 $ ulp*max( temp1, temp2 ) )
1449
1450 660 CONTINUE
1451 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
1452
1453 ntest = ntest + 1
1454
1455 IF( n.GT.0 ) THEN
1456 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
1457 IF( il.NE.1 ) THEN
1458 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
1459 $ ten*ulp*temp3, ten*rtunfl )
1460 ELSE IF( n.GT.0 ) THEN
1461 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
1462 $ ten*ulp*temp3, ten*rtunfl )
1463 END IF
1464 IF( iu.NE.n ) THEN
1465 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
1466 $ ten*ulp*temp3, ten*rtunfl )
1467 ELSE IF( n.GT.0 ) THEN
1468 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
1469 $ ten*ulp*temp3, ten*rtunfl )
1470 END IF
1471 ELSE
1472 temp3 = zero
1473 vl = zero
1474 vu = one
1475 END IF
1476
1477 srnamt = 'DSYEVX'
1478 CALL dsyevx(
'V',
'A', uplo, n, a, ldu, vl, vu, il, iu,
1479 $ abstol, m, wa1, z, ldu, work, lwork, iwork,
1480 $ iwork( 5*n+1 ), iinfo )
1481 IF( iinfo.NE.0 ) THEN
1482 WRITE( nounit, fmt = 9999 )'DSYEVX(V,A,' // uplo //
1483 $ ')', iinfo, n, jtype, ioldsd
1484 info = abs( iinfo )
1485 IF( iinfo.LT.0 ) THEN
1486 RETURN
1487 ELSE
1488 result( ntest ) = ulpinv
1489 result( ntest+1 ) = ulpinv
1490 result( ntest+2 ) = ulpinv
1491 GO TO 680
1492 END IF
1493 END IF
1494
1495
1496
1497 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
1498
1499 CALL dsyt21( 1, uplo, n, 0, a, ldu, d1, d2, z, ldu, v,
1500 $ ldu, tau, work, result( ntest ) )
1501
1502 ntest = ntest + 2
1503 srnamt = 'DSYEVX'
1504 CALL dsyevx(
'N',
'A', uplo, n, a, ldu, vl, vu, il, iu,
1505 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1506 $ iwork( 5*n+1 ), iinfo )
1507 IF( iinfo.NE.0 ) THEN
1508 WRITE( nounit, fmt = 9999 )'DSYEVX(N,A,' // uplo //
1509 $ ')', iinfo, n, jtype, ioldsd
1510 info = abs( iinfo )
1511 IF( iinfo.LT.0 ) THEN
1512 RETURN
1513 ELSE
1514 result( ntest ) = ulpinv
1515 GO TO 680
1516 END IF
1517 END IF
1518
1519
1520
1521 temp1 = zero
1522 temp2 = zero
1523 DO 670 j = 1, n
1524 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1525 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1526 670 CONTINUE
1527 result( ntest ) = temp2 / max( unfl,
1528 $ ulp*max( temp1, temp2 ) )
1529
1530 680 CONTINUE
1531
1532 ntest = ntest + 1
1533 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
1534 srnamt = 'DSYEVX'
1535 CALL dsyevx(
'V',
'I', uplo, n, a, ldu, vl, vu, il, iu,
1536 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1537 $ iwork( 5*n+1 ), iinfo )
1538 IF( iinfo.NE.0 ) THEN
1539 WRITE( nounit, fmt = 9999 )'DSYEVX(V,I,' // uplo //
1540 $ ')', iinfo, n, jtype, ioldsd
1541 info = abs( iinfo )
1542 IF( iinfo.LT.0 ) THEN
1543 RETURN
1544 ELSE
1545 result( ntest ) = ulpinv
1546 result( ntest+1 ) = ulpinv
1547 result( ntest+2 ) = ulpinv
1548 GO TO 690
1549 END IF
1550 END IF
1551
1552
1553
1554 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
1555
1556 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1557 $ v, ldu, tau, work, result( ntest ) )
1558
1559 ntest = ntest + 2
1560 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
1561 srnamt = 'DSYEVX'
1562 CALL dsyevx(
'N',
'I', uplo, n, a, ldu, vl, vu, il, iu,
1563 $ abstol, m3, wa3, z, ldu, work, lwork, iwork,
1564 $ iwork( 5*n+1 ), iinfo )
1565 IF( iinfo.NE.0 ) THEN
1566 WRITE( nounit, fmt = 9999 )'DSYEVX(N,I,' // uplo //
1567 $ ')', iinfo, n, jtype, ioldsd
1568 info = abs( iinfo )
1569 IF( iinfo.LT.0 ) THEN
1570 RETURN
1571 ELSE
1572 result( ntest ) = ulpinv
1573 GO TO 690
1574 END IF
1575 END IF
1576
1577
1578
1579 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1580 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1581 result( ntest ) = ( temp1+temp2 ) /
1582 $ max( unfl, ulp*temp3 )
1583 690 CONTINUE
1584
1585 ntest = ntest + 1
1586 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
1587 srnamt = 'DSYEVX'
1588 CALL dsyevx(
'V',
'V', uplo, n, a, ldu, vl, vu, il, iu,
1589 $ abstol, m2, wa2, z, ldu, work, lwork, iwork,
1590 $ iwork( 5*n+1 ), iinfo )
1591 IF( iinfo.NE.0 ) THEN
1592 WRITE( nounit, fmt = 9999 )'DSYEVX(V,V,' // uplo //
1593 $ ')', iinfo, n, jtype, ioldsd
1594 info = abs( iinfo )
1595 IF( iinfo.LT.0 ) THEN
1596 RETURN
1597 ELSE
1598 result( ntest ) = ulpinv
1599 result( ntest+1 ) = ulpinv
1600 result( ntest+2 ) = ulpinv
1601 GO TO 700
1602 END IF
1603 END IF
1604
1605
1606
1607 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
1608
1609 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1610 $ v, ldu, tau, work, result( ntest ) )
1611
1612 ntest = ntest + 2
1613 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
1614 srnamt = 'DSYEVX'
1615 CALL dsyevx(
'N',
'V', uplo, n, a, ldu, vl, vu, il, iu,
1616 $ abstol, m3, wa3, z, ldu, work, lwork, iwork,
1617 $ iwork( 5*n+1 ), iinfo )
1618 IF( iinfo.NE.0 ) THEN
1619 WRITE( nounit, fmt = 9999 )'DSYEVX(N,V,' // uplo //
1620 $ ')', iinfo, n, jtype, ioldsd
1621 info = abs( iinfo )
1622 IF( iinfo.LT.0 ) THEN
1623 RETURN
1624 ELSE
1625 result( ntest ) = ulpinv
1626 GO TO 700
1627 END IF
1628 END IF
1629
1630 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1631 result( ntest ) = ulpinv
1632 GO TO 700
1633 END IF
1634
1635
1636
1637 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1638 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1639 IF( n.GT.0 ) THEN
1640 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1641 ELSE
1642 temp3 = zero
1643 END IF
1644 result( ntest ) = ( temp1+temp2 ) /
1645 $ max( unfl, temp3*ulp )
1646
1647 700 CONTINUE
1648
1649
1650
1651 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
1652
1653
1654
1655
1656 IF( iuplo.EQ.1 ) THEN
1657 indx = 1
1658 DO 720 j = 1, n
1659 DO 710 i = 1, j
1660 work( indx ) = a( i, j )
1661 indx = indx + 1
1662 710 CONTINUE
1663 720 CONTINUE
1664 ELSE
1665 indx = 1
1666 DO 740 j = 1, n
1667 DO 730 i = j, n
1668 work( indx ) = a( i, j )
1669 indx = indx + 1
1670 730 CONTINUE
1671 740 CONTINUE
1672 END IF
1673
1674 ntest = ntest + 1
1675 srnamt = 'DSPEV'
1676 CALL dspev(
'V', uplo, n, work, d1, z, ldu, v, iinfo )
1677 IF( iinfo.NE.0 ) THEN
1678 WRITE( nounit, fmt = 9999 )'DSPEV(V,' // uplo // ')',
1679 $ iinfo, n, jtype, ioldsd
1680 info = abs( iinfo )
1681 IF( iinfo.LT.0 ) THEN
1682 RETURN
1683 ELSE
1684 result( ntest ) = ulpinv
1685 result( ntest+1 ) = ulpinv
1686 result( ntest+2 ) = ulpinv
1687 GO TO 800
1688 END IF
1689 END IF
1690
1691
1692
1693 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
1694 $ ldu, tau, work, result( ntest ) )
1695
1696 IF( iuplo.EQ.1 ) THEN
1697 indx = 1
1698 DO 760 j = 1, n
1699 DO 750 i = 1, j
1700 work( indx ) = a( i, j )
1701 indx = indx + 1
1702 750 CONTINUE
1703 760 CONTINUE
1704 ELSE
1705 indx = 1
1706 DO 780 j = 1, n
1707 DO 770 i = j, n
1708 work( indx ) = a( i, j )
1709 indx = indx + 1
1710 770 CONTINUE
1711 780 CONTINUE
1712 END IF
1713
1714 ntest = ntest + 2
1715 srnamt = 'DSPEV'
1716 CALL dspev(
'N', uplo, n, work, d3, z, ldu, v, iinfo )
1717 IF( iinfo.NE.0 ) THEN
1718 WRITE( nounit, fmt = 9999 )'DSPEV(N,' // uplo // ')',
1719 $ iinfo, n, jtype, ioldsd
1720 info = abs( iinfo )
1721 IF( iinfo.LT.0 ) THEN
1722 RETURN
1723 ELSE
1724 result( ntest ) = ulpinv
1725 GO TO 800
1726 END IF
1727 END IF
1728
1729
1730
1731 temp1 = zero
1732 temp2 = zero
1733 DO 790 j = 1, n
1734 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
1735 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
1736 790 CONTINUE
1737 result( ntest ) = temp2 / max( unfl,
1738 $ ulp*max( temp1, temp2 ) )
1739
1740
1741
1742
1743 800 CONTINUE
1744 IF( iuplo.EQ.1 ) THEN
1745 indx = 1
1746 DO 820 j = 1, n
1747 DO 810 i = 1, j
1748 work( indx ) = a( i, j )
1749 indx = indx + 1
1750 810 CONTINUE
1751 820 CONTINUE
1752 ELSE
1753 indx = 1
1754 DO 840 j = 1, n
1755 DO 830 i = j, n
1756 work( indx ) = a( i, j )
1757 indx = indx + 1
1758 830 CONTINUE
1759 840 CONTINUE
1760 END IF
1761
1762 ntest = ntest + 1
1763
1764 IF( n.GT.0 ) THEN
1765 temp3 = max( abs( d1( 1 ) ), abs( d1( n ) ) )
1766 IF( il.NE.1 ) THEN
1767 vl = d1( il ) - max( half*( d1( il )-d1( il-1 ) ),
1768 $ ten*ulp*temp3, ten*rtunfl )
1769 ELSE IF( n.GT.0 ) THEN
1770 vl = d1( 1 ) - max( half*( d1( n )-d1( 1 ) ),
1771 $ ten*ulp*temp3, ten*rtunfl )
1772 END IF
1773 IF( iu.NE.n ) THEN
1774 vu = d1( iu ) + max( half*( d1( iu+1 )-d1( iu ) ),
1775 $ ten*ulp*temp3, ten*rtunfl )
1776 ELSE IF( n.GT.0 ) THEN
1777 vu = d1( n ) + max( half*( d1( n )-d1( 1 ) ),
1778 $ ten*ulp*temp3, ten*rtunfl )
1779 END IF
1780 ELSE
1781 temp3 = zero
1782 vl = zero
1783 vu = one
1784 END IF
1785
1786 srnamt = 'DSPEVX'
1787 CALL dspevx(
'V',
'A', uplo, n, work, vl, vu, il, iu,
1788 $ abstol, m, wa1, z, ldu, v, iwork,
1789 $ iwork( 5*n+1 ), iinfo )
1790 IF( iinfo.NE.0 ) THEN
1791 WRITE( nounit, fmt = 9999 )'DSPEVX(V,A,' // uplo //
1792 $ ')', iinfo, n, jtype, ioldsd
1793 info = abs( iinfo )
1794 IF( iinfo.LT.0 ) THEN
1795 RETURN
1796 ELSE
1797 result( ntest ) = ulpinv
1798 result( ntest+1 ) = ulpinv
1799 result( ntest+2 ) = ulpinv
1800 GO TO 900
1801 END IF
1802 END IF
1803
1804
1805
1806 CALL dsyt21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
1807 $ ldu, tau, work, result( ntest ) )
1808
1809 ntest = ntest + 2
1810
1811 IF( iuplo.EQ.1 ) THEN
1812 indx = 1
1813 DO 860 j = 1, n
1814 DO 850 i = 1, j
1815 work( indx ) = a( i, j )
1816 indx = indx + 1
1817 850 CONTINUE
1818 860 CONTINUE
1819 ELSE
1820 indx = 1
1821 DO 880 j = 1, n
1822 DO 870 i = j, n
1823 work( indx ) = a( i, j )
1824 indx = indx + 1
1825 870 CONTINUE
1826 880 CONTINUE
1827 END IF
1828
1829 srnamt = 'DSPEVX'
1830 CALL dspevx(
'N',
'A', uplo, n, work, vl, vu, il, iu,
1831 $ abstol, m2, wa2, z, ldu, v, iwork,
1832 $ iwork( 5*n+1 ), iinfo )
1833 IF( iinfo.NE.0 ) THEN
1834 WRITE( nounit, fmt = 9999 )'DSPEVX(N,A,' // uplo //
1835 $ ')', iinfo, n, jtype, ioldsd
1836 info = abs( iinfo )
1837 IF( iinfo.LT.0 ) THEN
1838 RETURN
1839 ELSE
1840 result( ntest ) = ulpinv
1841 GO TO 900
1842 END IF
1843 END IF
1844
1845
1846
1847 temp1 = zero
1848 temp2 = zero
1849 DO 890 j = 1, n
1850 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
1851 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
1852 890 CONTINUE
1853 result( ntest ) = temp2 / max( unfl,
1854 $ ulp*max( temp1, temp2 ) )
1855
1856 900 CONTINUE
1857 IF( iuplo.EQ.1 ) THEN
1858 indx = 1
1859 DO 920 j = 1, n
1860 DO 910 i = 1, j
1861 work( indx ) = a( i, j )
1862 indx = indx + 1
1863 910 CONTINUE
1864 920 CONTINUE
1865 ELSE
1866 indx = 1
1867 DO 940 j = 1, n
1868 DO 930 i = j, n
1869 work( indx ) = a( i, j )
1870 indx = indx + 1
1871 930 CONTINUE
1872 940 CONTINUE
1873 END IF
1874
1875 ntest = ntest + 1
1876
1877 srnamt = 'DSPEVX'
1878 CALL dspevx(
'V',
'I', uplo, n, work, vl, vu, il, iu,
1879 $ abstol, m2, wa2, z, ldu, v, iwork,
1880 $ iwork( 5*n+1 ), iinfo )
1881 IF( iinfo.NE.0 ) THEN
1882 WRITE( nounit, fmt = 9999 )'DSPEVX(V,I,' // uplo //
1883 $ ')', iinfo, n, jtype, ioldsd
1884 info = abs( iinfo )
1885 IF( iinfo.LT.0 ) THEN
1886 RETURN
1887 ELSE
1888 result( ntest ) = ulpinv
1889 result( ntest+1 ) = ulpinv
1890 result( ntest+2 ) = ulpinv
1891 GO TO 990
1892 END IF
1893 END IF
1894
1895
1896
1897 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1898 $ v, ldu, tau, work, result( ntest ) )
1899
1900 ntest = ntest + 2
1901
1902 IF( iuplo.EQ.1 ) THEN
1903 indx = 1
1904 DO 960 j = 1, n
1905 DO 950 i = 1, j
1906 work( indx ) = a( i, j )
1907 indx = indx + 1
1908 950 CONTINUE
1909 960 CONTINUE
1910 ELSE
1911 indx = 1
1912 DO 980 j = 1, n
1913 DO 970 i = j, n
1914 work( indx ) = a( i, j )
1915 indx = indx + 1
1916 970 CONTINUE
1917 980 CONTINUE
1918 END IF
1919
1920 srnamt = 'DSPEVX'
1921 CALL dspevx(
'N',
'I', uplo, n, work, vl, vu, il, iu,
1922 $ abstol, m3, wa3, z, ldu, v, iwork,
1923 $ iwork( 5*n+1 ), iinfo )
1924 IF( iinfo.NE.0 ) THEN
1925 WRITE( nounit, fmt = 9999 )'DSPEVX(N,I,' // uplo //
1926 $ ')', iinfo, n, jtype, ioldsd
1927 info = abs( iinfo )
1928 IF( iinfo.LT.0 ) THEN
1929 RETURN
1930 ELSE
1931 result( ntest ) = ulpinv
1932 GO TO 990
1933 END IF
1934 END IF
1935
1936 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
1937 result( ntest ) = ulpinv
1938 GO TO 990
1939 END IF
1940
1941
1942
1943 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
1944 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
1945 IF( n.GT.0 ) THEN
1946 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
1947 ELSE
1948 temp3 = zero
1949 END IF
1950 result( ntest ) = ( temp1+temp2 ) /
1951 $ max( unfl, temp3*ulp )
1952
1953 990 CONTINUE
1954 IF( iuplo.EQ.1 ) THEN
1955 indx = 1
1956 DO 1010 j = 1, n
1957 DO 1000 i = 1, j
1958 work( indx ) = a( i, j )
1959 indx = indx + 1
1960 1000 CONTINUE
1961 1010 CONTINUE
1962 ELSE
1963 indx = 1
1964 DO 1030 j = 1, n
1965 DO 1020 i = j, n
1966 work( indx ) = a( i, j )
1967 indx = indx + 1
1968 1020 CONTINUE
1969 1030 CONTINUE
1970 END IF
1971
1972 ntest = ntest + 1
1973
1974 srnamt = 'DSPEVX'
1975 CALL dspevx(
'V',
'V', uplo, n, work, vl, vu, il, iu,
1976 $ abstol, m2, wa2, z, ldu, v, iwork,
1977 $ iwork( 5*n+1 ), iinfo )
1978 IF( iinfo.NE.0 ) THEN
1979 WRITE( nounit, fmt = 9999 )'DSPEVX(V,V,' // uplo //
1980 $ ')', iinfo, n, jtype, ioldsd
1981 info = abs( iinfo )
1982 IF( iinfo.LT.0 ) THEN
1983 RETURN
1984 ELSE
1985 result( ntest ) = ulpinv
1986 result( ntest+1 ) = ulpinv
1987 result( ntest+2 ) = ulpinv
1988 GO TO 1080
1989 END IF
1990 END IF
1991
1992
1993
1994 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
1995 $ v, ldu, tau, work, result( ntest ) )
1996
1997 ntest = ntest + 2
1998
1999 IF( iuplo.EQ.1 ) THEN
2000 indx = 1
2001 DO 1050 j = 1, n
2002 DO 1040 i = 1, j
2003 work( indx ) = a( i, j )
2004 indx = indx + 1
2005 1040 CONTINUE
2006 1050 CONTINUE
2007 ELSE
2008 indx = 1
2009 DO 1070 j = 1, n
2010 DO 1060 i = j, n
2011 work( indx ) = a( i, j )
2012 indx = indx + 1
2013 1060 CONTINUE
2014 1070 CONTINUE
2015 END IF
2016
2017 srnamt = 'DSPEVX'
2018 CALL dspevx(
'N',
'V', uplo, n, work, vl, vu, il, iu,
2019 $ abstol, m3, wa3, z, ldu, v, iwork,
2020 $ iwork( 5*n+1 ), iinfo )
2021 IF( iinfo.NE.0 ) THEN
2022 WRITE( nounit, fmt = 9999 )'DSPEVX(N,V,' // uplo //
2023 $ ')', iinfo, n, jtype, ioldsd
2024 info = abs( iinfo )
2025 IF( iinfo.LT.0 ) THEN
2026 RETURN
2027 ELSE
2028 result( ntest ) = ulpinv
2029 GO TO 1080
2030 END IF
2031 END IF
2032
2033 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2034 result( ntest ) = ulpinv
2035 GO TO 1080
2036 END IF
2037
2038
2039
2040 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2041 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2042 IF( n.GT.0 ) THEN
2043 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2044 ELSE
2045 temp3 = zero
2046 END IF
2047 result( ntest ) = ( temp1+temp2 ) /
2048 $ max( unfl, temp3*ulp )
2049
2050 1080 CONTINUE
2051
2052
2053
2054 IF( jtype.LE.7 ) THEN
2055 kd = 1
2056 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
2057 kd = max( n-1, 0 )
2058 ELSE
2059 kd = ihbw
2060 END IF
2061
2062
2063
2064
2065 IF( iuplo.EQ.1 ) THEN
2066 DO 1100 j = 1, n
2067 DO 1090 i = max( 1, j-kd ), j
2068 v( kd+1+i-j, j ) = a( i, j )
2069 1090 CONTINUE
2070 1100 CONTINUE
2071 ELSE
2072 DO 1120 j = 1, n
2073 DO 1110 i = j, min( n, j+kd )
2074 v( 1+i-j, j ) = a( i, j )
2075 1110 CONTINUE
2076 1120 CONTINUE
2077 END IF
2078
2079 ntest = ntest + 1
2080 srnamt = 'DSBEV'
2081 CALL dsbev(
'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
2082 $ iinfo )
2083 IF( iinfo.NE.0 ) THEN
2084 WRITE( nounit, fmt = 9999 )'DSBEV(V,' // uplo // ')',
2085 $ iinfo, n, jtype, ioldsd
2086 info = abs( iinfo )
2087 IF( iinfo.LT.0 ) THEN
2088 RETURN
2089 ELSE
2090 result( ntest ) = ulpinv
2091 result( ntest+1 ) = ulpinv
2092 result( ntest+2 ) = ulpinv
2093 GO TO 1180
2094 END IF
2095 END IF
2096
2097
2098
2099 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2100 $ ldu, tau, work, result( ntest ) )
2101
2102 IF( iuplo.EQ.1 ) THEN
2103 DO 1140 j = 1, n
2104 DO 1130 i = max( 1, j-kd ), j
2105 v( kd+1+i-j, j ) = a( i, j )
2106 1130 CONTINUE
2107 1140 CONTINUE
2108 ELSE
2109 DO 1160 j = 1, n
2110 DO 1150 i = j, min( n, j+kd )
2111 v( 1+i-j, j ) = a( i, j )
2112 1150 CONTINUE
2113 1160 CONTINUE
2114 END IF
2115
2116 ntest = ntest + 2
2117 srnamt = 'DSBEV'
2118 CALL dsbev(
'N', uplo, n, kd, v, ldu, d3, z, ldu, work,
2119 $ iinfo )
2120 IF( iinfo.NE.0 ) THEN
2121 WRITE( nounit, fmt = 9999 )'DSBEV(N,' // uplo // ')',
2122 $ iinfo, n, jtype, ioldsd
2123 info = abs( iinfo )
2124 IF( iinfo.LT.0 ) THEN
2125 RETURN
2126 ELSE
2127 result( ntest ) = ulpinv
2128 GO TO 1180
2129 END IF
2130 END IF
2131
2132
2133
2134 temp1 = zero
2135 temp2 = zero
2136 DO 1170 j = 1, n
2137 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2138 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2139 1170 CONTINUE
2140 result( ntest ) = temp2 / max( unfl,
2141 $ ulp*max( temp1, temp2 ) )
2142
2143
2144
2145
2146 1180 CONTINUE
2147 IF( iuplo.EQ.1 ) THEN
2148 DO 1200 j = 1, n
2149 DO 1190 i = max( 1, j-kd ), j
2150 v( kd+1+i-j, j ) = a( i, j )
2151 1190 CONTINUE
2152 1200 CONTINUE
2153 ELSE
2154 DO 1220 j = 1, n
2155 DO 1210 i = j, min( n, j+kd )
2156 v( 1+i-j, j ) = a( i, j )
2157 1210 CONTINUE
2158 1220 CONTINUE
2159 END IF
2160
2161 ntest = ntest + 1
2162 srnamt = 'DSBEVX'
2163 CALL dsbevx(
'V',
'A', uplo, n, kd, v, ldu, u, ldu, vl,
2164 $ vu, il, iu, abstol, m, wa2, z, ldu, work,
2165 $ iwork, iwork( 5*n+1 ), iinfo )
2166 IF( iinfo.NE.0 ) THEN
2167 WRITE( nounit, fmt = 9999 )'DSBEVX(V,A,' // uplo //
2168 $ ')', iinfo, n, jtype, ioldsd
2169 info = abs( iinfo )
2170 IF( iinfo.LT.0 ) THEN
2171 RETURN
2172 ELSE
2173 result( ntest ) = ulpinv
2174 result( ntest+1 ) = ulpinv
2175 result( ntest+2 ) = ulpinv
2176 GO TO 1280
2177 END IF
2178 END IF
2179
2180
2181
2182 CALL dsyt21( 1, uplo, n, 0, a, ldu, wa2, d2, z, ldu, v,
2183 $ ldu, tau, work, result( ntest ) )
2184
2185 ntest = ntest + 2
2186
2187 IF( iuplo.EQ.1 ) THEN
2188 DO 1240 j = 1, n
2189 DO 1230 i = max( 1, j-kd ), j
2190 v( kd+1+i-j, j ) = a( i, j )
2191 1230 CONTINUE
2192 1240 CONTINUE
2193 ELSE
2194 DO 1260 j = 1, n
2195 DO 1250 i = j, min( n, j+kd )
2196 v( 1+i-j, j ) = a( i, j )
2197 1250 CONTINUE
2198 1260 CONTINUE
2199 END IF
2200
2201 srnamt = 'DSBEVX'
2202 CALL dsbevx(
'N',
'A', uplo, n, kd, v, ldu, u, ldu, vl,
2203 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
2204 $ iwork, iwork( 5*n+1 ), iinfo )
2205 IF( iinfo.NE.0 ) THEN
2206 WRITE( nounit, fmt = 9999 )'DSBEVX(N,A,' // uplo //
2207 $ ')', iinfo, n, jtype, ioldsd
2208 info = abs( iinfo )
2209 IF( iinfo.LT.0 ) THEN
2210 RETURN
2211 ELSE
2212 result( ntest ) = ulpinv
2213 GO TO 1280
2214 END IF
2215 END IF
2216
2217
2218
2219 temp1 = zero
2220 temp2 = zero
2221 DO 1270 j = 1, n
2222 temp1 = max( temp1, abs( wa2( j ) ), abs( wa3( j ) ) )
2223 temp2 = max( temp2, abs( wa2( j )-wa3( j ) ) )
2224 1270 CONTINUE
2225 result( ntest ) = temp2 / max( unfl,
2226 $ ulp*max( temp1, temp2 ) )
2227
2228 1280 CONTINUE
2229 ntest = ntest + 1
2230 IF( iuplo.EQ.1 ) THEN
2231 DO 1300 j = 1, n
2232 DO 1290 i = max( 1, j-kd ), j
2233 v( kd+1+i-j, j ) = a( i, j )
2234 1290 CONTINUE
2235 1300 CONTINUE
2236 ELSE
2237 DO 1320 j = 1, n
2238 DO 1310 i = j, min( n, j+kd )
2239 v( 1+i-j, j ) = a( i, j )
2240 1310 CONTINUE
2241 1320 CONTINUE
2242 END IF
2243
2244 srnamt = 'DSBEVX'
2245 CALL dsbevx(
'V',
'I', uplo, n, kd, v, ldu, u, ldu, vl,
2246 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
2247 $ iwork, iwork( 5*n+1 ), iinfo )
2248 IF( iinfo.NE.0 ) THEN
2249 WRITE( nounit, fmt = 9999 )'DSBEVX(V,I,' // uplo //
2250 $ ')', iinfo, n, jtype, ioldsd
2251 info = abs( iinfo )
2252 IF( iinfo.LT.0 ) THEN
2253 RETURN
2254 ELSE
2255 result( ntest ) = ulpinv
2256 result( ntest+1 ) = ulpinv
2257 result( ntest+2 ) = ulpinv
2258 GO TO 1370
2259 END IF
2260 END IF
2261
2262
2263
2264 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2265 $ v, ldu, tau, work, result( ntest ) )
2266
2267 ntest = ntest + 2
2268
2269 IF( iuplo.EQ.1 ) THEN
2270 DO 1340 j = 1, n
2271 DO 1330 i = max( 1, j-kd ), j
2272 v( kd+1+i-j, j ) = a( i, j )
2273 1330 CONTINUE
2274 1340 CONTINUE
2275 ELSE
2276 DO 1360 j = 1, n
2277 DO 1350 i = j, min( n, j+kd )
2278 v( 1+i-j, j ) = a( i, j )
2279 1350 CONTINUE
2280 1360 CONTINUE
2281 END IF
2282
2283 srnamt = 'DSBEVX'
2284 CALL dsbevx(
'N',
'I', uplo, n, kd, v, ldu, u, ldu, vl,
2285 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
2286 $ iwork, iwork( 5*n+1 ), iinfo )
2287 IF( iinfo.NE.0 ) THEN
2288 WRITE( nounit, fmt = 9999 )'DSBEVX(N,I,' // uplo //
2289 $ ')', iinfo, n, jtype, ioldsd
2290 info = abs( iinfo )
2291 IF( iinfo.LT.0 ) THEN
2292 RETURN
2293 ELSE
2294 result( ntest ) = ulpinv
2295 GO TO 1370
2296 END IF
2297 END IF
2298
2299
2300
2301 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2302 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2303 IF( n.GT.0 ) THEN
2304 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2305 ELSE
2306 temp3 = zero
2307 END IF
2308 result( ntest ) = ( temp1+temp2 ) /
2309 $ max( unfl, temp3*ulp )
2310
2311 1370 CONTINUE
2312 ntest = ntest + 1
2313 IF( iuplo.EQ.1 ) THEN
2314 DO 1390 j = 1, n
2315 DO 1380 i = max( 1, j-kd ), j
2316 v( kd+1+i-j, j ) = a( i, j )
2317 1380 CONTINUE
2318 1390 CONTINUE
2319 ELSE
2320 DO 1410 j = 1, n
2321 DO 1400 i = j, min( n, j+kd )
2322 v( 1+i-j, j ) = a( i, j )
2323 1400 CONTINUE
2324 1410 CONTINUE
2325 END IF
2326
2327 srnamt = 'DSBEVX'
2328 CALL dsbevx(
'V',
'V', uplo, n, kd, v, ldu, u, ldu, vl,
2329 $ vu, il, iu, abstol, m2, wa2, z, ldu, work,
2330 $ iwork, iwork( 5*n+1 ), iinfo )
2331 IF( iinfo.NE.0 ) THEN
2332 WRITE( nounit, fmt = 9999 )'DSBEVX(V,V,' // uplo //
2333 $ ')', iinfo, n, jtype, ioldsd
2334 info = abs( iinfo )
2335 IF( iinfo.LT.0 ) THEN
2336 RETURN
2337 ELSE
2338 result( ntest ) = ulpinv
2339 result( ntest+1 ) = ulpinv
2340 result( ntest+2 ) = ulpinv
2341 GO TO 1460
2342 END IF
2343 END IF
2344
2345
2346
2347 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2348 $ v, ldu, tau, work, result( ntest ) )
2349
2350 ntest = ntest + 2
2351
2352 IF( iuplo.EQ.1 ) THEN
2353 DO 1430 j = 1, n
2354 DO 1420 i = max( 1, j-kd ), j
2355 v( kd+1+i-j, j ) = a( i, j )
2356 1420 CONTINUE
2357 1430 CONTINUE
2358 ELSE
2359 DO 1450 j = 1, n
2360 DO 1440 i = j, min( n, j+kd )
2361 v( 1+i-j, j ) = a( i, j )
2362 1440 CONTINUE
2363 1450 CONTINUE
2364 END IF
2365
2366 srnamt = 'DSBEVX'
2367 CALL dsbevx(
'N',
'V', uplo, n, kd, v, ldu, u, ldu, vl,
2368 $ vu, il, iu, abstol, m3, wa3, z, ldu, work,
2369 $ iwork, iwork( 5*n+1 ), iinfo )
2370 IF( iinfo.NE.0 ) THEN
2371 WRITE( nounit, fmt = 9999 )'DSBEVX(N,V,' // uplo //
2372 $ ')', iinfo, n, jtype, ioldsd
2373 info = abs( iinfo )
2374 IF( iinfo.LT.0 ) THEN
2375 RETURN
2376 ELSE
2377 result( ntest ) = ulpinv
2378 GO TO 1460
2379 END IF
2380 END IF
2381
2382 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2383 result( ntest ) = ulpinv
2384 GO TO 1460
2385 END IF
2386
2387
2388
2389 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2390 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2391 IF( n.GT.0 ) THEN
2392 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2393 ELSE
2394 temp3 = zero
2395 END IF
2396 result( ntest ) = ( temp1+temp2 ) /
2397 $ max( unfl, temp3*ulp )
2398
2399 1460 CONTINUE
2400
2401
2402
2403 CALL dlacpy(
' ', n, n, a, lda, v, ldu )
2404
2405 ntest = ntest + 1
2406 srnamt = 'DSYEVD'
2407 CALL dsyevd(
'V', uplo, n, a, ldu, d1, work, lwedc,
2408 $ iwork, liwedc, iinfo )
2409 IF( iinfo.NE.0 ) THEN
2410 WRITE( nounit, fmt = 9999 )'DSYEVD(V,' // uplo //
2411 $ ')', iinfo, n, jtype, ioldsd
2412 info = abs( iinfo )
2413 IF( iinfo.LT.0 ) THEN
2414 RETURN
2415 ELSE
2416 result( ntest ) = ulpinv
2417 result( ntest+1 ) = ulpinv
2418 result( ntest+2 ) = ulpinv
2419 GO TO 1480
2420 END IF
2421 END IF
2422
2423
2424
2425 CALL dsyt21( 1, uplo, n, 0, v, ldu, d1, d2, a, ldu, z,
2426 $ ldu, tau, work, result( ntest ) )
2427
2428 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
2429
2430 ntest = ntest + 2
2431 srnamt = 'DSYEVD'
2432 CALL dsyevd(
'N', uplo, n, a, ldu, d3, work, lwedc,
2433 $ iwork, liwedc, iinfo )
2434 IF( iinfo.NE.0 ) THEN
2435 WRITE( nounit, fmt = 9999 )'DSYEVD(N,' // uplo //
2436 $ ')', iinfo, n, jtype, ioldsd
2437 info = abs( iinfo )
2438 IF( iinfo.LT.0 ) THEN
2439 RETURN
2440 ELSE
2441 result( ntest ) = ulpinv
2442 GO TO 1480
2443 END IF
2444 END IF
2445
2446
2447
2448 temp1 = zero
2449 temp2 = zero
2450 DO 1470 j = 1, n
2451 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2452 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2453 1470 CONTINUE
2454 result( ntest ) = temp2 / max( unfl,
2455 $ ulp*max( temp1, temp2 ) )
2456
2457 1480 CONTINUE
2458
2459
2460
2461 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
2462
2463
2464
2465
2466 IF( iuplo.EQ.1 ) THEN
2467 indx = 1
2468 DO 1500 j = 1, n
2469 DO 1490 i = 1, j
2470 work( indx ) = a( i, j )
2471 indx = indx + 1
2472 1490 CONTINUE
2473 1500 CONTINUE
2474 ELSE
2475 indx = 1
2476 DO 1520 j = 1, n
2477 DO 1510 i = j, n
2478 work( indx ) = a( i, j )
2479 indx = indx + 1
2480 1510 CONTINUE
2481 1520 CONTINUE
2482 END IF
2483
2484 ntest = ntest + 1
2485 srnamt = 'DSPEVD'
2486 CALL dspevd(
'V', uplo, n, work, d1, z, ldu,
2487 $ work( indx ), lwedc-indx+1, iwork, liwedc,
2488 $ iinfo )
2489 IF( iinfo.NE.0 ) THEN
2490 WRITE( nounit, fmt = 9999 )'DSPEVD(V,' // uplo //
2491 $ ')', iinfo, n, jtype, ioldsd
2492 info = abs( iinfo )
2493 IF( iinfo.LT.0 ) THEN
2494 RETURN
2495 ELSE
2496 result( ntest ) = ulpinv
2497 result( ntest+1 ) = ulpinv
2498 result( ntest+2 ) = ulpinv
2499 GO TO 1580
2500 END IF
2501 END IF
2502
2503
2504
2505 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2506 $ ldu, tau, work, result( ntest ) )
2507
2508 IF( iuplo.EQ.1 ) THEN
2509 indx = 1
2510 DO 1540 j = 1, n
2511 DO 1530 i = 1, j
2512
2513 work( indx ) = a( i, j )
2514 indx = indx + 1
2515 1530 CONTINUE
2516 1540 CONTINUE
2517 ELSE
2518 indx = 1
2519 DO 1560 j = 1, n
2520 DO 1550 i = j, n
2521 work( indx ) = a( i, j )
2522 indx = indx + 1
2523 1550 CONTINUE
2524 1560 CONTINUE
2525 END IF
2526
2527 ntest = ntest + 2
2528 srnamt = 'DSPEVD'
2529 CALL dspevd(
'N', uplo, n, work, d3, z, ldu,
2530 $ work( indx ), lwedc-indx+1, iwork, liwedc,
2531 $ iinfo )
2532 IF( iinfo.NE.0 ) THEN
2533 WRITE( nounit, fmt = 9999 )'DSPEVD(N,' // uplo //
2534 $ ')', iinfo, n, jtype, ioldsd
2535 info = abs( iinfo )
2536 IF( iinfo.LT.0 ) THEN
2537 RETURN
2538 ELSE
2539 result( ntest ) = ulpinv
2540 GO TO 1580
2541 END IF
2542 END IF
2543
2544
2545
2546 temp1 = zero
2547 temp2 = zero
2548 DO 1570 j = 1, n
2549 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2550 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2551 1570 CONTINUE
2552 result( ntest ) = temp2 / max( unfl,
2553 $ ulp*max( temp1, temp2 ) )
2554 1580 CONTINUE
2555
2556
2557
2558 IF( jtype.LE.7 ) THEN
2559 kd = 1
2560 ELSE IF( jtype.GE.8 .AND. jtype.LE.15 ) THEN
2561 kd = max( n-1, 0 )
2562 ELSE
2563 kd = ihbw
2564 END IF
2565
2566
2567
2568
2569 IF( iuplo.EQ.1 ) THEN
2570 DO 1600 j = 1, n
2571 DO 1590 i = max( 1, j-kd ), j
2572 v( kd+1+i-j, j ) = a( i, j )
2573 1590 CONTINUE
2574 1600 CONTINUE
2575 ELSE
2576 DO 1620 j = 1, n
2577 DO 1610 i = j, min( n, j+kd )
2578 v( 1+i-j, j ) = a( i, j )
2579 1610 CONTINUE
2580 1620 CONTINUE
2581 END IF
2582
2583 ntest = ntest + 1
2584 srnamt = 'DSBEVD'
2585 CALL dsbevd(
'V', uplo, n, kd, v, ldu, d1, z, ldu, work,
2586 $ lwedc, iwork, liwedc, iinfo )
2587 IF( iinfo.NE.0 ) THEN
2588 WRITE( nounit, fmt = 9999 )'DSBEVD(V,' // uplo //
2589 $ ')', iinfo, n, jtype, ioldsd
2590 info = abs( iinfo )
2591 IF( iinfo.LT.0 ) THEN
2592 RETURN
2593 ELSE
2594 result( ntest ) = ulpinv
2595 result( ntest+1 ) = ulpinv
2596 result( ntest+2 ) = ulpinv
2597 GO TO 1680
2598 END IF
2599 END IF
2600
2601
2602
2603 CALL dsyt21( 1, uplo, n, 0, a, lda, d1, d2, z, ldu, v,
2604 $ ldu, tau, work, result( ntest ) )
2605
2606 IF( iuplo.EQ.1 ) THEN
2607 DO 1640 j = 1, n
2608 DO 1630 i = max( 1, j-kd ), j
2609 v( kd+1+i-j, j ) = a( i, j )
2610 1630 CONTINUE
2611 1640 CONTINUE
2612 ELSE
2613 DO 1660 j = 1, n
2614 DO 1650 i = j, min( n, j+kd )
2615 v( 1+i-j, j ) = a( i, j )
2616 1650 CONTINUE
2617 1660 CONTINUE
2618 END IF
2619
2620 ntest = ntest + 2
2621 srnamt = 'DSBEVD'
2622 CALL dsbevd(
'N', uplo, n, kd, v, ldu, d3, z, ldu, work,
2623 $ lwedc, iwork, liwedc, iinfo )
2624 IF( iinfo.NE.0 ) THEN
2625 WRITE( nounit, fmt = 9999 )'DSBEVD(N,' // uplo //
2626 $ ')', iinfo, n, jtype, ioldsd
2627 info = abs( iinfo )
2628 IF( iinfo.LT.0 ) THEN
2629 RETURN
2630 ELSE
2631 result( ntest ) = ulpinv
2632 GO TO 1680
2633 END IF
2634 END IF
2635
2636
2637
2638 temp1 = zero
2639 temp2 = zero
2640 DO 1670 j = 1, n
2641 temp1 = max( temp1, abs( d1( j ) ), abs( d3( j ) ) )
2642 temp2 = max( temp2, abs( d1( j )-d3( j ) ) )
2643 1670 CONTINUE
2644 result( ntest ) = temp2 / max( unfl,
2645 $ ulp*max( temp1, temp2 ) )
2646
2647 1680 CONTINUE
2648
2649
2650 CALL dlacpy(
' ', n, n, a, lda, v, ldu )
2651 ntest = ntest + 1
2652 srnamt = 'DSYEVR'
2653 CALL dsyevr(
'V',
'A', uplo, n, a, ldu, vl, vu, il, iu,
2654 $ abstol, m, wa1, z, ldu, iwork, work, lwork,
2655 $ iwork(2*n+1), liwork-2*n, iinfo )
2656 IF( iinfo.NE.0 ) THEN
2657 WRITE( nounit, fmt = 9999 )'DSYEVR(V,A,' // uplo //
2658 $ ')', iinfo, n, jtype, ioldsd
2659 info = abs( iinfo )
2660 IF( iinfo.LT.0 ) THEN
2661 RETURN
2662 ELSE
2663 result( ntest ) = ulpinv
2664 result( ntest+1 ) = ulpinv
2665 result( ntest+2 ) = ulpinv
2666 GO TO 1700
2667 END IF
2668 END IF
2669
2670
2671
2672 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
2673
2674 CALL dsyt21( 1, uplo, n, 0, a, ldu, wa1, d2, z, ldu, v,
2675 $ ldu, tau, work, result( ntest ) )
2676
2677 ntest = ntest + 2
2678 srnamt = 'DSYEVR'
2679 CALL dsyevr(
'N',
'A', uplo, n, a, ldu, vl, vu, il, iu,
2680 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2681 $ iwork(2*n+1), liwork-2*n, iinfo )
2682 IF( iinfo.NE.0 ) THEN
2683 WRITE( nounit, fmt = 9999 )'DSYEVR(N,A,' // uplo //
2684 $ ')', iinfo, n, jtype, ioldsd
2685 info = abs( iinfo )
2686 IF( iinfo.LT.0 ) THEN
2687 RETURN
2688 ELSE
2689 result( ntest ) = ulpinv
2690 GO TO 1700
2691 END IF
2692 END IF
2693
2694
2695
2696 temp1 = zero
2697 temp2 = zero
2698 DO 1690 j = 1, n
2699 temp1 = max( temp1, abs( wa1( j ) ), abs( wa2( j ) ) )
2700 temp2 = max( temp2, abs( wa1( j )-wa2( j ) ) )
2701 1690 CONTINUE
2702 result( ntest ) = temp2 / max( unfl,
2703 $ ulp*max( temp1, temp2 ) )
2704
2705 1700 CONTINUE
2706
2707 ntest = ntest + 1
2708 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
2709 srnamt = 'DSYEVR'
2710 CALL dsyevr(
'V',
'I', uplo, n, a, ldu, vl, vu, il, iu,
2711 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2712 $ iwork(2*n+1), liwork-2*n, iinfo )
2713 IF( iinfo.NE.0 ) THEN
2714 WRITE( nounit, fmt = 9999 )'DSYEVR(V,I,' // uplo //
2715 $ ')', iinfo, n, jtype, ioldsd
2716 info = abs( iinfo )
2717 IF( iinfo.LT.0 ) THEN
2718 RETURN
2719 ELSE
2720 result( ntest ) = ulpinv
2721 result( ntest+1 ) = ulpinv
2722 result( ntest+2 ) = ulpinv
2723 GO TO 1710
2724 END IF
2725 END IF
2726
2727
2728
2729 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
2730
2731 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2732 $ v, ldu, tau, work, result( ntest ) )
2733
2734 ntest = ntest + 2
2735 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
2736 srnamt = 'DSYEVR'
2737 CALL dsyevr(
'N',
'I', uplo, n, a, ldu, vl, vu, il, iu,
2738 $ abstol, m3, wa3, z, ldu, iwork, work, lwork,
2739 $ iwork(2*n+1), liwork-2*n, iinfo )
2740 IF( iinfo.NE.0 ) THEN
2741 WRITE( nounit, fmt = 9999 )'DSYEVR(N,I,' // uplo //
2742 $ ')', iinfo, n, jtype, ioldsd
2743 info = abs( iinfo )
2744 IF( iinfo.LT.0 ) THEN
2745 RETURN
2746 ELSE
2747 result( ntest ) = ulpinv
2748 GO TO 1710
2749 END IF
2750 END IF
2751
2752
2753
2754 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2755 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2756 result( ntest ) = ( temp1+temp2 ) /
2757 $ max( unfl, ulp*temp3 )
2758 1710 CONTINUE
2759
2760 ntest = ntest + 1
2761 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
2762 srnamt = 'DSYEVR'
2763 CALL dsyevr(
'V',
'V', uplo, n, a, ldu, vl, vu, il, iu,
2764 $ abstol, m2, wa2, z, ldu, iwork, work, lwork,
2765 $ iwork(2*n+1), liwork-2*n, iinfo )
2766 IF( iinfo.NE.0 ) THEN
2767 WRITE( nounit, fmt = 9999 )'DSYEVR(V,V,' // uplo //
2768 $ ')', iinfo, n, jtype, ioldsd
2769 info = abs( iinfo )
2770 IF( iinfo.LT.0 ) THEN
2771 RETURN
2772 ELSE
2773 result( ntest ) = ulpinv
2774 result( ntest+1 ) = ulpinv
2775 result( ntest+2 ) = ulpinv
2776 GO TO 700
2777 END IF
2778 END IF
2779
2780
2781
2782 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
2783
2784 CALL dsyt22( 1, uplo, n, m2, 0, a, ldu, wa2, d2, z, ldu,
2785 $ v, ldu, tau, work, result( ntest ) )
2786
2787 ntest = ntest + 2
2788 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
2789 srnamt = 'DSYEVR'
2790 CALL dsyevr(
'N',
'V', uplo, n, a, ldu, vl, vu, il, iu,
2791 $ abstol, m3, wa3, z, ldu, iwork, work, lwork,
2792 $ iwork(2*n+1), liwork-2*n, iinfo )
2793 IF( iinfo.NE.0 ) THEN
2794 WRITE( nounit, fmt = 9999 )'DSYEVR(N,V,' // uplo //
2795 $ ')', iinfo, n, jtype, ioldsd
2796 info = abs( iinfo )
2797 IF( iinfo.LT.0 ) THEN
2798 RETURN
2799 ELSE
2800 result( ntest ) = ulpinv
2801 GO TO 700
2802 END IF
2803 END IF
2804
2805 IF( m3.EQ.0 .AND. n.GT.0 ) THEN
2806 result( ntest ) = ulpinv
2807 GO TO 700
2808 END IF
2809
2810
2811
2812 temp1 =
dsxt1( 1, wa2, m2, wa3, m3, abstol, ulp, unfl )
2813 temp2 =
dsxt1( 1, wa3, m3, wa2, m2, abstol, ulp, unfl )
2814 IF( n.GT.0 ) THEN
2815 temp3 = max( abs( wa1( 1 ) ), abs( wa1( n ) ) )
2816 ELSE
2817 temp3 = zero
2818 END IF
2819 result( ntest ) = ( temp1+temp2 ) /
2820 $ max( unfl, temp3*ulp )
2821
2822 CALL dlacpy(
' ', n, n, v, ldu, a, lda )
2823
2824 1720 CONTINUE
2825
2826
2827
2828 ntestt = ntestt + ntest
2829
2830 CALL dlafts(
'DST', n, n, jtype, ntest, result, ioldsd,
2831 $ thresh, nounit, nerrs )
2832
2833 1730 CONTINUE
2834 1740 CONTINUE
2835
2836
2837
2838 CALL alasvm(
'DST', nounit, nerrs, ntestt, 0 )
2839
2840 9999 FORMAT( ' DDRVST: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
2841 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
2842
2843 RETURN
2844
2845
2846
double precision function dlamch(CMACH)
DLAMCH
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY 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 xerbla(SRNAME, INFO)
XERBLA
subroutine alasvm(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASVM
double precision function dsxt1(IJOB, D1, N1, D2, N2, ABSTOL, ULP, UNFL)
DSXT1
subroutine dlafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
DLAFTS
subroutine dsyt22(ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU, V, LDV, TAU, WORK, RESULT)
DSYT22
subroutine dstt22(N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK, LDWORK, RESULT)
DSTT22
subroutine dsyt21(ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, LDV, TAU, WORK, RESULT)
DSYT21
subroutine dstt21(N, KBAND, AD, AE, SD, SE, U, LDU, WORK, RESULT)
DSTT21
subroutine dlatmr(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, PACK, A, LDA, IWORK, INFO)
DLATMR
double precision function dlarnd(IDIST, ISEED)
DLARND
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
subroutine dspevx(JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO)
DSPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
subroutine dstevd(JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSTEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
subroutine dstevr(JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSTEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
subroutine dsbevx(JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO)
DSBEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
subroutine dspevd(JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
subroutine dstevx(JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO)
DSTEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
subroutine dspev(JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO)
DSPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
subroutine dstev(JOBZ, N, D, E, Z, LDZ, WORK, INFO)
DSTEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
subroutine dsbev(JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO)
DSBEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrices
subroutine dsbevd(JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSBEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER matrice...
subroutine dsyev(JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO)
DSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
subroutine dsyevx(JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO)
DSYEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
subroutine dsyevd(JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO)
DSYEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices
subroutine dsyevr(JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO)
DSYEVR computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matrices