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