376
377 IMPLICIT NONE
378
379
380
381
382
383
384 INTEGER INFO, LDA, LDB, LDZ, LIWORK, LRWORK, NOUNIT,
385 $ NSIZES, NTYPES, NWORK
386 DOUBLE PRECISION THRESH
387
388
389 LOGICAL DOTYPE( * )
390 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
391 DOUBLE PRECISION D( * ), D2( * ), RESULT( * ), RWORK( * )
392 COMPLEX*16 A( LDA, * ), AB( LDA, * ), AP( * ),
393 $ B( LDB, * ), BB( LDB, * ), BP( * ), WORK( * ),
394 $ Z( LDZ, * )
395
396
397
398
399
400 DOUBLE PRECISION ZERO, ONE, TEN
401 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 10.0d+0 )
402 COMPLEX*16 CZERO, CONE
403 parameter( czero = ( 0.0d+0, 0.0d+0 ),
404 $ cone = ( 1.0d+0, 0.0d+0 ) )
405 INTEGER MAXTYP
406 parameter( maxtyp = 21 )
407
408
409 LOGICAL BADNN
410 CHARACTER UPLO
411 INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
412 $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB,
413 $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
414 $ NTESTT
415 DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
416 $ RTUNFL, ULP, ULPINV, UNFL, VL, VU, TEMP1, TEMP2
417
418
419 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
420 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
421 $ KTYPE( MAXTYP )
422
423
424 LOGICAL LSAME
425 DOUBLE PRECISION DLAMCH, DLARND
427
428
433
434
435 INTRINSIC abs, dble, max, min, sqrt
436
437
438 DATA ktype / 1, 2, 5*4, 5*5, 3*8, 6*9 /
439 DATA kmagn / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
440 $ 2, 3, 6*1 /
441 DATA kmode / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
442 $ 0, 0, 6*4 /
443
444
445
446
447
448 ntestt = 0
449 info = 0
450
451 badnn = .false.
452 nmax = 0
453 DO 10 j = 1, nsizes
454 nmax = max( nmax, nn( j ) )
455 IF( nn( j ).LT.0 )
456 $ badnn = .true.
457 10 CONTINUE
458
459
460
461 IF( nsizes.LT.0 ) THEN
462 info = -1
463 ELSE IF( badnn ) THEN
464 info = -2
465 ELSE IF( ntypes.LT.0 ) THEN
466 info = -3
467 ELSE IF( lda.LE.1 .OR. lda.LT.nmax ) THEN
468 info = -9
469 ELSE IF( ldz.LE.1 .OR. ldz.LT.nmax ) THEN
470 info = -16
471 ELSE IF( 2*max( nmax, 2 )**2.GT.nwork ) THEN
472 info = -21
473 ELSE IF( 2*max( nmax, 2 )**2.GT.lrwork ) THEN
474 info = -23
475 ELSE IF( 2*max( nmax, 2 )**2.GT.liwork ) THEN
476 info = -25
477 END IF
478
479 IF( info.NE.0 ) THEN
480 CALL xerbla(
'ZDRVSG2STG', -info )
481 RETURN
482 END IF
483
484
485
486 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
487 $ RETURN
488
489
490
491 unfl =
dlamch(
'Safe minimum' )
492 ovfl =
dlamch(
'Overflow' )
495 ulpinv = one / ulp
496 rtunfl = sqrt( unfl )
497 rtovfl = sqrt( ovfl )
498
499 DO 20 i = 1, 4
500 iseed2( i ) = iseed( i )
501 20 CONTINUE
502
503
504
505 nerrs = 0
506 nmats = 0
507
508 DO 650 jsize = 1, nsizes
509 n = nn( jsize )
510 aninv = one / dble( max( 1, n ) )
511
512 IF( nsizes.NE.1 ) THEN
513 mtypes = min( maxtyp, ntypes )
514 ELSE
515 mtypes = min( maxtyp+1, ntypes )
516 END IF
517
518 ka9 = 0
519 kb9 = 0
520 DO 640 jtype = 1, mtypes
521 IF( .NOT.dotype( jtype ) )
522 $ GO TO 640
523 nmats = nmats + 1
524 ntest = 0
525
526 DO 30 j = 1, 4
527 ioldsd( j ) = iseed( j )
528 30 CONTINUE
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545 IF( mtypes.GT.maxtyp )
546 $ GO TO 90
547
548 itype = ktype( jtype )
549 imode = kmode( jtype )
550
551
552
553 GO TO ( 40, 50, 60 )kmagn( jtype )
554
555 40 CONTINUE
556 anorm = one
557 GO TO 70
558
559 50 CONTINUE
560 anorm = ( rtovfl*ulp )*aninv
561 GO TO 70
562
563 60 CONTINUE
564 anorm = rtunfl*n*ulpinv
565 GO TO 70
566
567 70 CONTINUE
568
569 iinfo = 0
570 cond = ulpinv
571
572
573
574 IF( itype.EQ.1 ) THEN
575
576
577
578 ka = 0
579 kb = 0
580 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
581
582 ELSE IF( itype.EQ.2 ) THEN
583
584
585
586 ka = 0
587 kb = 0
588 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
589 DO 80 jcol = 1, n
590 a( jcol, jcol ) = anorm
591 80 CONTINUE
592
593 ELSE IF( itype.EQ.4 ) THEN
594
595
596
597 ka = 0
598 kb = 0
599 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
600 $ anorm, 0, 0, 'N', a, lda, work, iinfo )
601
602 ELSE IF( itype.EQ.5 ) THEN
603
604
605
606 ka = max( 0, n-1 )
607 kb = ka
608 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
609 $ anorm, n, n, 'N', a, lda, work, iinfo )
610
611 ELSE IF( itype.EQ.7 ) THEN
612
613
614
615 ka = 0
616 kb = 0
617 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
618 $ 'T', 'N', work( n+1 ), 1, one,
619 $ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
620 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
621
622 ELSE IF( itype.EQ.8 ) THEN
623
624
625
626 ka = max( 0, n-1 )
627 kb = ka
628 CALL zlatmr( n, n,
'S', iseed,
'H', work, 6, one, cone,
629 $ 'T', 'N', work( n+1 ), 1, one,
630 $ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
631 $ zero, anorm, 'NO', a, lda, iwork, iinfo )
632
633 ELSE IF( itype.EQ.9 ) THEN
634
635
636
637
638
639
640
641
642
643
644
645
646 kb9 = kb9 + 1
647 IF( kb9.GT.ka9 ) THEN
648 ka9 = ka9 + 1
649 kb9 = 1
650 END IF
651 ka = max( 0, min( n-1, ka9 ) )
652 kb = max( 0, min( n-1, kb9 ) )
653 CALL zlatms( n, n,
'S', iseed,
'H', rwork, imode, cond,
654 $ anorm, ka, ka, 'N', a, lda, work, iinfo )
655
656 ELSE
657
658 iinfo = 1
659 END IF
660
661 IF( iinfo.NE.0 ) THEN
662 WRITE( nounit, fmt = 9999 )'Generator', iinfo, n, jtype,
663 $ ioldsd
664 info = abs( iinfo )
665 RETURN
666 END IF
667
668 90 CONTINUE
669
670 abstol = unfl + unfl
671 IF( n.LE.1 ) THEN
672 il = 1
673 iu = n
674 ELSE
675 il = 1 + int( ( n-1 )*
dlarnd( 1, iseed2 ) )
676 iu = 1 + int( ( n-1 )*
dlarnd( 1, iseed2 ) )
677 IF( il.GT.iu ) THEN
678 itemp = il
679 il = iu
680 iu = itemp
681 END IF
682 END IF
683
684
685
686
687
688
689
690
691
692 DO 630 ibtype = 1, 3
693
694
695
696 DO 620 ibuplo = 1, 2
697 IF( ibuplo.EQ.1 )
698 $ uplo = 'U'
699 IF( ibuplo.EQ.2 )
700 $ uplo = 'L'
701
702
703
704
705 CALL zlatms( n, n,
'U', iseed,
'P', rwork, 5, ten,
706 $ one, kb, kb, uplo, b, ldb, work( n+1 ),
707 $ iinfo )
708
709
710
711 ntest = ntest + 1
712
713 CALL zlacpy(
' ', n, n, a, lda, z, ldz )
714 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
715
716 CALL zhegv( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
717 $ work, nwork, rwork, iinfo )
718 IF( iinfo.NE.0 ) THEN
719 WRITE( nounit, fmt = 9999 )'ZHEGV(V,' // uplo //
720 $ ')', iinfo, n, jtype, ioldsd
721 info = abs( iinfo )
722 IF( iinfo.LT.0 ) THEN
723 RETURN
724 ELSE
725 result( ntest ) = ulpinv
726 GO TO 100
727 END IF
728 END IF
729
730
731
732 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
733 $ ldz, d, work, rwork, result( ntest ) )
734
735
736
737 ntest = ntest + 1
738
739 CALL zlacpy(
' ', n, n, a, lda, z, ldz )
740 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
741
743 $ bb, ldb, d2, work, nwork, rwork,
744 $ iinfo )
745 IF( iinfo.NE.0 ) THEN
746 WRITE( nounit, fmt = 9999 )
747 $ 'ZHEGV_2STAGE(V,' // uplo //
748 $ ')', iinfo, n, jtype, ioldsd
749 info = abs( iinfo )
750 IF( iinfo.LT.0 ) THEN
751 RETURN
752 ELSE
753 result( ntest ) = ulpinv
754 GO TO 100
755 END IF
756 END IF
757
758
759
760
761
762
763
764
765
766
767 temp1 = zero
768 temp2 = zero
769 DO 151 j = 1, n
770 temp1 = max( temp1, abs( d( j ) ),
771 $ abs( d2( j ) ) )
772 temp2 = max( temp2, abs( d( j )-d2( j ) ) )
773 151 CONTINUE
774
775 result( ntest ) = temp2 /
776 $ max( unfl, ulp*max( temp1, temp2 ) )
777
778
779
780 ntest = ntest + 1
781
782 CALL zlacpy(
' ', n, n, a, lda, z, ldz )
783 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
784
785 CALL zhegvd( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
786 $ work, nwork, rwork, lrwork, iwork,
787 $ liwork, iinfo )
788 IF( iinfo.NE.0 ) THEN
789 WRITE( nounit, fmt = 9999 )'ZHEGVD(V,' // uplo //
790 $ ')', iinfo, n, jtype, ioldsd
791 info = abs( iinfo )
792 IF( iinfo.LT.0 ) THEN
793 RETURN
794 ELSE
795 result( ntest ) = ulpinv
796 GO TO 100
797 END IF
798 END IF
799
800
801
802 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
803 $ ldz, d, work, rwork, result( ntest ) )
804
805
806
807 ntest = ntest + 1
808
809 CALL zlacpy(
' ', n, n, a, lda, ab, lda )
810 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
811
812 CALL zhegvx( ibtype,
'V',
'A', uplo, n, ab, lda, bb,
813 $ ldb, vl, vu, il, iu, abstol, m, d, z,
814 $ ldz, work, nwork, rwork, iwork( n+1 ),
815 $ iwork, iinfo )
816 IF( iinfo.NE.0 ) THEN
817 WRITE( nounit, fmt = 9999 )'ZHEGVX(V,A' // uplo //
818 $ ')', iinfo, n, jtype, ioldsd
819 info = abs( iinfo )
820 IF( iinfo.LT.0 ) THEN
821 RETURN
822 ELSE
823 result( ntest ) = ulpinv
824 GO TO 100
825 END IF
826 END IF
827
828
829
830 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
831 $ ldz, d, work, rwork, result( ntest ) )
832
833 ntest = ntest + 1
834
835 CALL zlacpy(
' ', n, n, a, lda, ab, lda )
836 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
837
838
839
840
841
842
843 vl = zero
844 vu = anorm
845 CALL zhegvx( ibtype,
'V',
'V', uplo, n, ab, lda, bb,
846 $ ldb, vl, vu, il, iu, abstol, m, d, z,
847 $ ldz, work, nwork, rwork, iwork( n+1 ),
848 $ iwork, iinfo )
849 IF( iinfo.NE.0 ) THEN
850 WRITE( nounit, fmt = 9999 )'ZHEGVX(V,V,' //
851 $ uplo // ')', iinfo, n, jtype, ioldsd
852 info = abs( iinfo )
853 IF( iinfo.LT.0 ) THEN
854 RETURN
855 ELSE
856 result( ntest ) = ulpinv
857 GO TO 100
858 END IF
859 END IF
860
861
862
863 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
864 $ ldz, d, work, rwork, result( ntest ) )
865
866 ntest = ntest + 1
867
868 CALL zlacpy(
' ', n, n, a, lda, ab, lda )
869 CALL zlacpy( uplo, n, n, b, ldb, bb, ldb )
870
871 CALL zhegvx( ibtype,
'V',
'I', uplo, n, ab, lda, bb,
872 $ ldb, vl, vu, il, iu, abstol, m, d, z,
873 $ ldz, work, nwork, rwork, iwork( n+1 ),
874 $ iwork, iinfo )
875 IF( iinfo.NE.0 ) THEN
876 WRITE( nounit, fmt = 9999 )'ZHEGVX(V,I,' //
877 $ uplo // ')', iinfo, n, jtype, ioldsd
878 info = abs( iinfo )
879 IF( iinfo.LT.0 ) THEN
880 RETURN
881 ELSE
882 result( ntest ) = ulpinv
883 GO TO 100
884 END IF
885 END IF
886
887
888
889 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
890 $ ldz, d, work, rwork, result( ntest ) )
891
892 100 CONTINUE
893
894
895
896 ntest = ntest + 1
897
898
899
900 IF(
lsame( uplo,
'U' ) )
THEN
901 ij = 1
902 DO 120 j = 1, n
903 DO 110 i = 1, j
904 ap( ij ) = a( i, j )
905 bp( ij ) = b( i, j )
906 ij = ij + 1
907 110 CONTINUE
908 120 CONTINUE
909 ELSE
910 ij = 1
911 DO 140 j = 1, n
912 DO 130 i = j, n
913 ap( ij ) = a( i, j )
914 bp( ij ) = b( i, j )
915 ij = ij + 1
916 130 CONTINUE
917 140 CONTINUE
918 END IF
919
920 CALL zhpgv( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
921 $ work, rwork, iinfo )
922 IF( iinfo.NE.0 ) THEN
923 WRITE( nounit, fmt = 9999 )'ZHPGV(V,' // uplo //
924 $ ')', iinfo, n, jtype, ioldsd
925 info = abs( iinfo )
926 IF( iinfo.LT.0 ) THEN
927 RETURN
928 ELSE
929 result( ntest ) = ulpinv
930 GO TO 310
931 END IF
932 END IF
933
934
935
936 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
937 $ ldz, d, work, rwork, result( ntest ) )
938
939
940
941 ntest = ntest + 1
942
943
944
945 IF(
lsame( uplo,
'U' ) )
THEN
946 ij = 1
947 DO 160 j = 1, n
948 DO 150 i = 1, j
949 ap( ij ) = a( i, j )
950 bp( ij ) = b( i, j )
951 ij = ij + 1
952 150 CONTINUE
953 160 CONTINUE
954 ELSE
955 ij = 1
956 DO 180 j = 1, n
957 DO 170 i = j, n
958 ap( ij ) = a( i, j )
959 bp( ij ) = b( i, j )
960 ij = ij + 1
961 170 CONTINUE
962 180 CONTINUE
963 END IF
964
965 CALL zhpgvd( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
966 $ work, nwork, rwork, lrwork, iwork,
967 $ liwork, iinfo )
968 IF( iinfo.NE.0 ) THEN
969 WRITE( nounit, fmt = 9999 )'ZHPGVD(V,' // uplo //
970 $ ')', iinfo, n, jtype, ioldsd
971 info = abs( iinfo )
972 IF( iinfo.LT.0 ) THEN
973 RETURN
974 ELSE
975 result( ntest ) = ulpinv
976 GO TO 310
977 END IF
978 END IF
979
980
981
982 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
983 $ ldz, d, work, rwork, result( ntest ) )
984
985
986
987 ntest = ntest + 1
988
989
990
991 IF(
lsame( uplo,
'U' ) )
THEN
992 ij = 1
993 DO 200 j = 1, n
994 DO 190 i = 1, j
995 ap( ij ) = a( i, j )
996 bp( ij ) = b( i, j )
997 ij = ij + 1
998 190 CONTINUE
999 200 CONTINUE
1000 ELSE
1001 ij = 1
1002 DO 220 j = 1, n
1003 DO 210 i = j, n
1004 ap( ij ) = a( i, j )
1005 bp( ij ) = b( i, j )
1006 ij = ij + 1
1007 210 CONTINUE
1008 220 CONTINUE
1009 END IF
1010
1011 CALL zhpgvx( ibtype,
'V',
'A', uplo, n, ap, bp, vl,
1012 $ vu, il, iu, abstol, m, d, z, ldz, work,
1013 $ rwork, iwork( n+1 ), iwork, info )
1014 IF( iinfo.NE.0 ) THEN
1015 WRITE( nounit, fmt = 9999 )'ZHPGVX(V,A' // uplo //
1016 $ ')', iinfo, n, jtype, ioldsd
1017 info = abs( iinfo )
1018 IF( iinfo.LT.0 ) THEN
1019 RETURN
1020 ELSE
1021 result( ntest ) = ulpinv
1022 GO TO 310
1023 END IF
1024 END IF
1025
1026
1027
1028 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1029 $ ldz, d, work, rwork, result( ntest ) )
1030
1031 ntest = ntest + 1
1032
1033
1034
1035 IF(
lsame( uplo,
'U' ) )
THEN
1036 ij = 1
1037 DO 240 j = 1, n
1038 DO 230 i = 1, j
1039 ap( ij ) = a( i, j )
1040 bp( ij ) = b( i, j )
1041 ij = ij + 1
1042 230 CONTINUE
1043 240 CONTINUE
1044 ELSE
1045 ij = 1
1046 DO 260 j = 1, n
1047 DO 250 i = j, n
1048 ap( ij ) = a( i, j )
1049 bp( ij ) = b( i, j )
1050 ij = ij + 1
1051 250 CONTINUE
1052 260 CONTINUE
1053 END IF
1054
1055 vl = zero
1056 vu = anorm
1057 CALL zhpgvx( ibtype,
'V',
'V', uplo, n, ap, bp, vl,
1058 $ vu, il, iu, abstol, m, d, z, ldz, work,
1059 $ rwork, iwork( n+1 ), iwork, info )
1060 IF( iinfo.NE.0 ) THEN
1061 WRITE( nounit, fmt = 9999 )'ZHPGVX(V,V' // uplo //
1062 $ ')', iinfo, n, jtype, ioldsd
1063 info = abs( iinfo )
1064 IF( iinfo.LT.0 ) THEN
1065 RETURN
1066 ELSE
1067 result( ntest ) = ulpinv
1068 GO TO 310
1069 END IF
1070 END IF
1071
1072
1073
1074 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1075 $ ldz, d, work, rwork, result( ntest ) )
1076
1077 ntest = ntest + 1
1078
1079
1080
1081 IF(
lsame( uplo,
'U' ) )
THEN
1082 ij = 1
1083 DO 280 j = 1, n
1084 DO 270 i = 1, j
1085 ap( ij ) = a( i, j )
1086 bp( ij ) = b( i, j )
1087 ij = ij + 1
1088 270 CONTINUE
1089 280 CONTINUE
1090 ELSE
1091 ij = 1
1092 DO 300 j = 1, n
1093 DO 290 i = j, n
1094 ap( ij ) = a( i, j )
1095 bp( ij ) = b( i, j )
1096 ij = ij + 1
1097 290 CONTINUE
1098 300 CONTINUE
1099 END IF
1100
1101 CALL zhpgvx( ibtype,
'V',
'I', uplo, n, ap, bp, vl,
1102 $ vu, il, iu, abstol, m, d, z, ldz, work,
1103 $ rwork, iwork( n+1 ), iwork, info )
1104 IF( iinfo.NE.0 ) THEN
1105 WRITE( nounit, fmt = 9999 )'ZHPGVX(V,I' // uplo //
1106 $ ')', iinfo, n, jtype, ioldsd
1107 info = abs( iinfo )
1108 IF( iinfo.LT.0 ) THEN
1109 RETURN
1110 ELSE
1111 result( ntest ) = ulpinv
1112 GO TO 310
1113 END IF
1114 END IF
1115
1116
1117
1118 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1119 $ ldz, d, work, rwork, result( ntest ) )
1120
1121 310 CONTINUE
1122
1123 IF( ibtype.EQ.1 ) THEN
1124
1125
1126
1127 ntest = ntest + 1
1128
1129
1130
1131 IF(
lsame( uplo,
'U' ) )
THEN
1132 DO 340 j = 1, n
1133 DO 320 i = max( 1, j-ka ), j
1134 ab( ka+1+i-j, j ) = a( i, j )
1135 320 CONTINUE
1136 DO 330 i = max( 1, j-kb ), j
1137 bb( kb+1+i-j, j ) = b( i, j )
1138 330 CONTINUE
1139 340 CONTINUE
1140 ELSE
1141 DO 370 j = 1, n
1142 DO 350 i = j, min( n, j+ka )
1143 ab( 1+i-j, j ) = a( i, j )
1144 350 CONTINUE
1145 DO 360 i = j, min( n, j+kb )
1146 bb( 1+i-j, j ) = b( i, j )
1147 360 CONTINUE
1148 370 CONTINUE
1149 END IF
1150
1151 CALL zhbgv(
'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1152 $ d, z, ldz, work, rwork, iinfo )
1153 IF( iinfo.NE.0 ) THEN
1154 WRITE( nounit, fmt = 9999 )'ZHBGV(V,' //
1155 $ uplo // ')', iinfo, n, jtype, ioldsd
1156 info = abs( iinfo )
1157 IF( iinfo.LT.0 ) THEN
1158 RETURN
1159 ELSE
1160 result( ntest ) = ulpinv
1161 GO TO 620
1162 END IF
1163 END IF
1164
1165
1166
1167 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1168 $ ldz, d, work, rwork, result( ntest ) )
1169
1170
1171
1172 ntest = ntest + 1
1173
1174
1175
1176 IF(
lsame( uplo,
'U' ) )
THEN
1177 DO 400 j = 1, n
1178 DO 380 i = max( 1, j-ka ), j
1179 ab( ka+1+i-j, j ) = a( i, j )
1180 380 CONTINUE
1181 DO 390 i = max( 1, j-kb ), j
1182 bb( kb+1+i-j, j ) = b( i, j )
1183 390 CONTINUE
1184 400 CONTINUE
1185 ELSE
1186 DO 430 j = 1, n
1187 DO 410 i = j, min( n, j+ka )
1188 ab( 1+i-j, j ) = a( i, j )
1189 410 CONTINUE
1190 DO 420 i = j, min( n, j+kb )
1191 bb( 1+i-j, j ) = b( i, j )
1192 420 CONTINUE
1193 430 CONTINUE
1194 END IF
1195
1196 CALL zhbgvd(
'V', uplo, n, ka, kb, ab, lda, bb,
1197 $ ldb, d, z, ldz, work, nwork, rwork,
1198 $ lrwork, iwork, liwork, iinfo )
1199 IF( iinfo.NE.0 ) THEN
1200 WRITE( nounit, fmt = 9999 )'ZHBGVD(V,' //
1201 $ uplo // ')', iinfo, n, jtype, ioldsd
1202 info = abs( iinfo )
1203 IF( iinfo.LT.0 ) THEN
1204 RETURN
1205 ELSE
1206 result( ntest ) = ulpinv
1207 GO TO 620
1208 END IF
1209 END IF
1210
1211
1212
1213 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1214 $ ldz, d, work, rwork, result( ntest ) )
1215
1216
1217
1218 ntest = ntest + 1
1219
1220
1221
1222 IF(
lsame( uplo,
'U' ) )
THEN
1223 DO 460 j = 1, n
1224 DO 440 i = max( 1, j-ka ), j
1225 ab( ka+1+i-j, j ) = a( i, j )
1226 440 CONTINUE
1227 DO 450 i = max( 1, j-kb ), j
1228 bb( kb+1+i-j, j ) = b( i, j )
1229 450 CONTINUE
1230 460 CONTINUE
1231 ELSE
1232 DO 490 j = 1, n
1233 DO 470 i = j, min( n, j+ka )
1234 ab( 1+i-j, j ) = a( i, j )
1235 470 CONTINUE
1236 DO 480 i = j, min( n, j+kb )
1237 bb( 1+i-j, j ) = b( i, j )
1238 480 CONTINUE
1239 490 CONTINUE
1240 END IF
1241
1242 CALL zhbgvx(
'V',
'A', uplo, n, ka, kb, ab, lda,
1243 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1244 $ iu, abstol, m, d, z, ldz, work, rwork,
1245 $ iwork( n+1 ), iwork, iinfo )
1246 IF( iinfo.NE.0 ) THEN
1247 WRITE( nounit, fmt = 9999 )'ZHBGVX(V,A' //
1248 $ uplo // ')', iinfo, n, jtype, ioldsd
1249 info = abs( iinfo )
1250 IF( iinfo.LT.0 ) THEN
1251 RETURN
1252 ELSE
1253 result( ntest ) = ulpinv
1254 GO TO 620
1255 END IF
1256 END IF
1257
1258
1259
1260 CALL zsgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1261 $ ldz, d, work, rwork, result( ntest ) )
1262
1263 ntest = ntest + 1
1264
1265
1266
1267 IF(
lsame( uplo,
'U' ) )
THEN
1268 DO 520 j = 1, n
1269 DO 500 i = max( 1, j-ka ), j
1270 ab( ka+1+i-j, j ) = a( i, j )
1271 500 CONTINUE
1272 DO 510 i = max( 1, j-kb ), j
1273 bb( kb+1+i-j, j ) = b( i, j )
1274 510 CONTINUE
1275 520 CONTINUE
1276 ELSE
1277 DO 550 j = 1, n
1278 DO 530 i = j, min( n, j+ka )
1279 ab( 1+i-j, j ) = a( i, j )
1280 530 CONTINUE
1281 DO 540 i = j, min( n, j+kb )
1282 bb( 1+i-j, j ) = b( i, j )
1283 540 CONTINUE
1284 550 CONTINUE
1285 END IF
1286
1287 vl = zero
1288 vu = anorm
1289 CALL zhbgvx(
'V',
'V', uplo, n, ka, kb, ab, lda,
1290 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1291 $ iu, abstol, m, d, z, ldz, work, rwork,
1292 $ iwork( n+1 ), iwork, iinfo )
1293 IF( iinfo.NE.0 ) THEN
1294 WRITE( nounit, fmt = 9999 )'ZHBGVX(V,V' //
1295 $ uplo // ')', iinfo, n, jtype, ioldsd
1296 info = abs( iinfo )
1297 IF( iinfo.LT.0 ) THEN
1298 RETURN
1299 ELSE
1300 result( ntest ) = ulpinv
1301 GO TO 620
1302 END IF
1303 END IF
1304
1305
1306
1307 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1308 $ ldz, d, work, rwork, result( ntest ) )
1309
1310 ntest = ntest + 1
1311
1312
1313
1314 IF(
lsame( uplo,
'U' ) )
THEN
1315 DO 580 j = 1, n
1316 DO 560 i = max( 1, j-ka ), j
1317 ab( ka+1+i-j, j ) = a( i, j )
1318 560 CONTINUE
1319 DO 570 i = max( 1, j-kb ), j
1320 bb( kb+1+i-j, j ) = b( i, j )
1321 570 CONTINUE
1322 580 CONTINUE
1323 ELSE
1324 DO 610 j = 1, n
1325 DO 590 i = j, min( n, j+ka )
1326 ab( 1+i-j, j ) = a( i, j )
1327 590 CONTINUE
1328 DO 600 i = j, min( n, j+kb )
1329 bb( 1+i-j, j ) = b( i, j )
1330 600 CONTINUE
1331 610 CONTINUE
1332 END IF
1333
1334 CALL zhbgvx(
'V',
'I', uplo, n, ka, kb, ab, lda,
1335 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1336 $ iu, abstol, m, d, z, ldz, work, rwork,
1337 $ iwork( n+1 ), iwork, iinfo )
1338 IF( iinfo.NE.0 ) THEN
1339 WRITE( nounit, fmt = 9999 )'ZHBGVX(V,I' //
1340 $ uplo // ')', iinfo, n, jtype, ioldsd
1341 info = abs( iinfo )
1342 IF( iinfo.LT.0 ) THEN
1343 RETURN
1344 ELSE
1345 result( ntest ) = ulpinv
1346 GO TO 620
1347 END IF
1348 END IF
1349
1350
1351
1352 CALL zsgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1353 $ ldz, d, work, rwork, result( ntest ) )
1354
1355 END IF
1356
1357 620 CONTINUE
1358 630 CONTINUE
1359
1360
1361
1362 ntestt = ntestt + ntest
1363 CALL dlafts(
'ZSG', n, n, jtype, ntest, result, ioldsd,
1364 $ thresh, nounit, nerrs )
1365 640 CONTINUE
1366 650 CONTINUE
1367
1368
1369
1370 CALL dlasum(
'ZSG', nounit, nerrs, ntestt )
1371
1372 RETURN
1373
1374 9999 FORMAT( ' ZDRVSG2STG: ', a, ' returned INFO=', i6, '.', / 9x,
1375 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
1376
1377
1378
double precision function dlamch(CMACH)
DLAMCH
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
subroutine zsgt01(ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D, WORK, RWORK, RESULT)
ZSGT01
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
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 zhegv_2stage(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO)
ZHEGV_2STAGE
subroutine zhegvd(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZHEGVD
subroutine zhegvx(ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO)
ZHEGVX
subroutine zhegv(ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO)
ZHEGV
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
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 zhbgvd(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZHBGVD
subroutine zhbgv(JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO)
ZHBGV
subroutine zhpgvx(ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO)
ZHPGVX
subroutine zhbgvx(JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO)
ZHBGVX
subroutine zhpgv(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO)
ZHPGV
subroutine zhpgvd(ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO)
ZHPGVD
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine dlafts(TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, THRESH, IOUNIT, IE)
DLAFTS
double precision function dlarnd(IDIST, ISEED)
DLARND