362
363 IMPLICIT NONE
364
365
366
367
368
369
370 INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES,
371 $ NTYPES, NWORK
372 REAL THRESH
373
374
375 LOGICAL DOTYPE( * )
376 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
377 REAL A( LDA, * ), AB( LDA, * ), AP( * ),
378 $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ),
379 $ D2( * ), RESULT( * ), WORK( * ), Z( LDZ, * )
380
381
382
383
384
385 REAL ZERO, ONE, TEN
386 parameter( zero = 0.0e0, one = 1.0e0, ten = 10.0e0 )
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 REAL 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 REAL SLAMCH, SLARND
409
410
415
416
417 INTRINSIC abs, real, 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(
'SDRVSG2STG', -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 =
slamch(
'Safe minimum' )
472 ovfl =
slamch(
'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 / real( 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 slaset(
'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 slaset(
'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 slatms( 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 slatms( 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 slatmr( 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 slatmr( 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 slatms( 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 )*
slarnd( 1, iseed2 ) )
658 iu = 1 + int( ( n-1 )*
slarnd( 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 slatms( 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 slacpy(
' ', n, n, a, lda, z, ldz )
696 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
697
698 CALL ssygv( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
699 $ work, nwork, iinfo )
700 IF( iinfo.NE.0 ) THEN
701 WRITE( nounit, fmt = 9999 )'SSYGV(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 ssgt01( 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 slacpy(
' ', n, n, a, lda, z, ldz )
722 CALL slacpy( 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 $ 'SSYGV_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
749 temp1 = zero
750 temp2 = zero
751 DO 151 j = 1, n
752 temp1 = max( temp1, abs( d( j ) ),
753 $ abs( d2( j ) ) )
754 temp2 = max( temp2, abs( d( j )-d2( j ) ) )
755 151 CONTINUE
756
757 result( ntest ) = temp2 /
758 $ max( unfl, ulp*max( temp1, temp2 ) )
759
760
761
762 ntest = ntest + 1
763
764 CALL slacpy(
' ', n, n, a, lda, z, ldz )
765 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
766
767 CALL ssygvd( ibtype,
'V', uplo, n, z, ldz, bb, ldb, d,
768 $ work, nwork, iwork, liwork, iinfo )
769 IF( iinfo.NE.0 ) THEN
770 WRITE( nounit, fmt = 9999 )'SSYGVD(V,' // uplo //
771 $ ')', iinfo, n, jtype, ioldsd
772 info = abs( iinfo )
773 IF( iinfo.LT.0 ) THEN
774 RETURN
775 ELSE
776 result( ntest ) = ulpinv
777 GO TO 100
778 END IF
779 END IF
780
781
782
783 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
784 $ ldz, d, work, result( ntest ) )
785
786
787
788 ntest = ntest + 1
789
790 CALL slacpy(
' ', n, n, a, lda, ab, lda )
791 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
792
793 CALL ssygvx( ibtype,
'V',
'A', uplo, n, ab, lda, bb,
794 $ ldb, vl, vu, il, iu, abstol, m, d, z,
795 $ ldz, work, nwork, iwork( n+1 ), iwork,
796 $ iinfo )
797 IF( iinfo.NE.0 ) THEN
798 WRITE( nounit, fmt = 9999 )'SSYGVX(V,A' // uplo //
799 $ ')', iinfo, n, jtype, ioldsd
800 info = abs( iinfo )
801 IF( iinfo.LT.0 ) THEN
802 RETURN
803 ELSE
804 result( ntest ) = ulpinv
805 GO TO 100
806 END IF
807 END IF
808
809
810
811 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
812 $ ldz, d, work, result( ntest ) )
813
814 ntest = ntest + 1
815
816 CALL slacpy(
' ', n, n, a, lda, ab, lda )
817 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
818
819
820
821
822
823
824 vl = zero
825 vu = anorm
826 CALL ssygvx( ibtype,
'V',
'V', uplo, n, ab, lda, bb,
827 $ ldb, vl, vu, il, iu, abstol, m, d, z,
828 $ ldz, work, nwork, iwork( n+1 ), iwork,
829 $ iinfo )
830 IF( iinfo.NE.0 ) THEN
831 WRITE( nounit, fmt = 9999 )'SSYGVX(V,V,' //
832 $ uplo // ')', iinfo, n, jtype, ioldsd
833 info = abs( iinfo )
834 IF( iinfo.LT.0 ) THEN
835 RETURN
836 ELSE
837 result( ntest ) = ulpinv
838 GO TO 100
839 END IF
840 END IF
841
842
843
844 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
845 $ ldz, d, work, result( ntest ) )
846
847 ntest = ntest + 1
848
849 CALL slacpy(
' ', n, n, a, lda, ab, lda )
850 CALL slacpy( uplo, n, n, b, ldb, bb, ldb )
851
852 CALL ssygvx( ibtype,
'V',
'I', uplo, n, ab, lda, bb,
853 $ ldb, vl, vu, il, iu, abstol, m, d, z,
854 $ ldz, work, nwork, iwork( n+1 ), iwork,
855 $ iinfo )
856 IF( iinfo.NE.0 ) THEN
857 WRITE( nounit, fmt = 9999 )'SSYGVX(V,I,' //
858 $ uplo // ')', iinfo, n, jtype, ioldsd
859 info = abs( iinfo )
860 IF( iinfo.LT.0 ) THEN
861 RETURN
862 ELSE
863 result( ntest ) = ulpinv
864 GO TO 100
865 END IF
866 END IF
867
868
869
870 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
871 $ ldz, d, work, result( ntest ) )
872
873 100 CONTINUE
874
875
876
877 ntest = ntest + 1
878
879
880
881 IF(
lsame( uplo,
'U' ) )
THEN
882 ij = 1
883 DO 120 j = 1, n
884 DO 110 i = 1, j
885 ap( ij ) = a( i, j )
886 bp( ij ) = b( i, j )
887 ij = ij + 1
888 110 CONTINUE
889 120 CONTINUE
890 ELSE
891 ij = 1
892 DO 140 j = 1, n
893 DO 130 i = j, n
894 ap( ij ) = a( i, j )
895 bp( ij ) = b( i, j )
896 ij = ij + 1
897 130 CONTINUE
898 140 CONTINUE
899 END IF
900
901 CALL sspgv( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
902 $ work, iinfo )
903 IF( iinfo.NE.0 ) THEN
904 WRITE( nounit, fmt = 9999 )'SSPGV(V,' // uplo //
905 $ ')', iinfo, n, jtype, ioldsd
906 info = abs( iinfo )
907 IF( iinfo.LT.0 ) THEN
908 RETURN
909 ELSE
910 result( ntest ) = ulpinv
911 GO TO 310
912 END IF
913 END IF
914
915
916
917 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
918 $ ldz, d, work, result( ntest ) )
919
920
921
922 ntest = ntest + 1
923
924
925
926 IF(
lsame( uplo,
'U' ) )
THEN
927 ij = 1
928 DO 160 j = 1, n
929 DO 150 i = 1, j
930 ap( ij ) = a( i, j )
931 bp( ij ) = b( i, j )
932 ij = ij + 1
933 150 CONTINUE
934 160 CONTINUE
935 ELSE
936 ij = 1
937 DO 180 j = 1, n
938 DO 170 i = j, n
939 ap( ij ) = a( i, j )
940 bp( ij ) = b( i, j )
941 ij = ij + 1
942 170 CONTINUE
943 180 CONTINUE
944 END IF
945
946 CALL sspgvd( ibtype,
'V', uplo, n, ap, bp, d, z, ldz,
947 $ work, nwork, iwork, liwork, iinfo )
948 IF( iinfo.NE.0 ) THEN
949 WRITE( nounit, fmt = 9999 )'SSPGVD(V,' // uplo //
950 $ ')', iinfo, n, jtype, ioldsd
951 info = abs( iinfo )
952 IF( iinfo.LT.0 ) THEN
953 RETURN
954 ELSE
955 result( ntest ) = ulpinv
956 GO TO 310
957 END IF
958 END IF
959
960
961
962 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
963 $ ldz, d, work, result( ntest ) )
964
965
966
967 ntest = ntest + 1
968
969
970
971 IF(
lsame( uplo,
'U' ) )
THEN
972 ij = 1
973 DO 200 j = 1, n
974 DO 190 i = 1, j
975 ap( ij ) = a( i, j )
976 bp( ij ) = b( i, j )
977 ij = ij + 1
978 190 CONTINUE
979 200 CONTINUE
980 ELSE
981 ij = 1
982 DO 220 j = 1, n
983 DO 210 i = j, n
984 ap( ij ) = a( i, j )
985 bp( ij ) = b( i, j )
986 ij = ij + 1
987 210 CONTINUE
988 220 CONTINUE
989 END IF
990
991 CALL sspgvx( ibtype,
'V',
'A', uplo, n, ap, bp, vl,
992 $ vu, il, iu, abstol, m, d, z, ldz, work,
993 $ iwork( n+1 ), iwork, info )
994 IF( iinfo.NE.0 ) THEN
995 WRITE( nounit, fmt = 9999 )'SSPGVX(V,A' // uplo //
996 $ ')', iinfo, n, jtype, ioldsd
997 info = abs( iinfo )
998 IF( iinfo.LT.0 ) THEN
999 RETURN
1000 ELSE
1001 result( ntest ) = ulpinv
1002 GO TO 310
1003 END IF
1004 END IF
1005
1006
1007
1008 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1009 $ ldz, d, work, result( ntest ) )
1010
1011 ntest = ntest + 1
1012
1013
1014
1015 IF(
lsame( uplo,
'U' ) )
THEN
1016 ij = 1
1017 DO 240 j = 1, n
1018 DO 230 i = 1, j
1019 ap( ij ) = a( i, j )
1020 bp( ij ) = b( i, j )
1021 ij = ij + 1
1022 230 CONTINUE
1023 240 CONTINUE
1024 ELSE
1025 ij = 1
1026 DO 260 j = 1, n
1027 DO 250 i = j, n
1028 ap( ij ) = a( i, j )
1029 bp( ij ) = b( i, j )
1030 ij = ij + 1
1031 250 CONTINUE
1032 260 CONTINUE
1033 END IF
1034
1035 vl = zero
1036 vu = anorm
1037 CALL sspgvx( ibtype,
'V',
'V', uplo, n, ap, bp, vl,
1038 $ vu, il, iu, abstol, m, d, z, ldz, work,
1039 $ iwork( n+1 ), iwork, info )
1040 IF( iinfo.NE.0 ) THEN
1041 WRITE( nounit, fmt = 9999 )'SSPGVX(V,V' // uplo //
1042 $ ')', iinfo, n, jtype, ioldsd
1043 info = abs( iinfo )
1044 IF( iinfo.LT.0 ) THEN
1045 RETURN
1046 ELSE
1047 result( ntest ) = ulpinv
1048 GO TO 310
1049 END IF
1050 END IF
1051
1052
1053
1054 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1055 $ ldz, d, work, result( ntest ) )
1056
1057 ntest = ntest + 1
1058
1059
1060
1061 IF(
lsame( uplo,
'U' ) )
THEN
1062 ij = 1
1063 DO 280 j = 1, n
1064 DO 270 i = 1, j
1065 ap( ij ) = a( i, j )
1066 bp( ij ) = b( i, j )
1067 ij = ij + 1
1068 270 CONTINUE
1069 280 CONTINUE
1070 ELSE
1071 ij = 1
1072 DO 300 j = 1, n
1073 DO 290 i = j, n
1074 ap( ij ) = a( i, j )
1075 bp( ij ) = b( i, j )
1076 ij = ij + 1
1077 290 CONTINUE
1078 300 CONTINUE
1079 END IF
1080
1081 CALL sspgvx( ibtype,
'V',
'I', uplo, n, ap, bp, vl,
1082 $ vu, il, iu, abstol, m, d, z, ldz, work,
1083 $ iwork( n+1 ), iwork, info )
1084 IF( iinfo.NE.0 ) THEN
1085 WRITE( nounit, fmt = 9999 )'SSPGVX(V,I' // uplo //
1086 $ ')', iinfo, n, jtype, ioldsd
1087 info = abs( iinfo )
1088 IF( iinfo.LT.0 ) THEN
1089 RETURN
1090 ELSE
1091 result( ntest ) = ulpinv
1092 GO TO 310
1093 END IF
1094 END IF
1095
1096
1097
1098 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1099 $ ldz, d, work, result( ntest ) )
1100
1101 310 CONTINUE
1102
1103 IF( ibtype.EQ.1 ) THEN
1104
1105
1106
1107 ntest = ntest + 1
1108
1109
1110
1111 IF(
lsame( uplo,
'U' ) )
THEN
1112 DO 340 j = 1, n
1113 DO 320 i = max( 1, j-ka ), j
1114 ab( ka+1+i-j, j ) = a( i, j )
1115 320 CONTINUE
1116 DO 330 i = max( 1, j-kb ), j
1117 bb( kb+1+i-j, j ) = b( i, j )
1118 330 CONTINUE
1119 340 CONTINUE
1120 ELSE
1121 DO 370 j = 1, n
1122 DO 350 i = j, min( n, j+ka )
1123 ab( 1+i-j, j ) = a( i, j )
1124 350 CONTINUE
1125 DO 360 i = j, min( n, j+kb )
1126 bb( 1+i-j, j ) = b( i, j )
1127 360 CONTINUE
1128 370 CONTINUE
1129 END IF
1130
1131 CALL ssbgv(
'V', uplo, n, ka, kb, ab, lda, bb, ldb,
1132 $ d, z, ldz, work, iinfo )
1133 IF( iinfo.NE.0 ) THEN
1134 WRITE( nounit, fmt = 9999 )'SSBGV(V,' //
1135 $ uplo // ')', iinfo, n, jtype, ioldsd
1136 info = abs( iinfo )
1137 IF( iinfo.LT.0 ) THEN
1138 RETURN
1139 ELSE
1140 result( ntest ) = ulpinv
1141 GO TO 620
1142 END IF
1143 END IF
1144
1145
1146
1147 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1148 $ ldz, d, work, result( ntest ) )
1149
1150
1151
1152 ntest = ntest + 1
1153
1154
1155
1156 IF(
lsame( uplo,
'U' ) )
THEN
1157 DO 400 j = 1, n
1158 DO 380 i = max( 1, j-ka ), j
1159 ab( ka+1+i-j, j ) = a( i, j )
1160 380 CONTINUE
1161 DO 390 i = max( 1, j-kb ), j
1162 bb( kb+1+i-j, j ) = b( i, j )
1163 390 CONTINUE
1164 400 CONTINUE
1165 ELSE
1166 DO 430 j = 1, n
1167 DO 410 i = j, min( n, j+ka )
1168 ab( 1+i-j, j ) = a( i, j )
1169 410 CONTINUE
1170 DO 420 i = j, min( n, j+kb )
1171 bb( 1+i-j, j ) = b( i, j )
1172 420 CONTINUE
1173 430 CONTINUE
1174 END IF
1175
1176 CALL ssbgvd(
'V', uplo, n, ka, kb, ab, lda, bb,
1177 $ ldb, d, z, ldz, work, nwork, iwork,
1178 $ liwork, iinfo )
1179 IF( iinfo.NE.0 ) THEN
1180 WRITE( nounit, fmt = 9999 )'SSBGVD(V,' //
1181 $ uplo // ')', iinfo, n, jtype, ioldsd
1182 info = abs( iinfo )
1183 IF( iinfo.LT.0 ) THEN
1184 RETURN
1185 ELSE
1186 result( ntest ) = ulpinv
1187 GO TO 620
1188 END IF
1189 END IF
1190
1191
1192
1193 CALL ssgt01( ibtype, uplo, n, n, a, lda, b, ldb, z,
1194 $ ldz, d, work, result( ntest ) )
1195
1196
1197
1198 ntest = ntest + 1
1199
1200
1201
1202 IF(
lsame( uplo,
'U' ) )
THEN
1203 DO 460 j = 1, n
1204 DO 440 i = max( 1, j-ka ), j
1205 ab( ka+1+i-j, j ) = a( i, j )
1206 440 CONTINUE
1207 DO 450 i = max( 1, j-kb ), j
1208 bb( kb+1+i-j, j ) = b( i, j )
1209 450 CONTINUE
1210 460 CONTINUE
1211 ELSE
1212 DO 490 j = 1, n
1213 DO 470 i = j, min( n, j+ka )
1214 ab( 1+i-j, j ) = a( i, j )
1215 470 CONTINUE
1216 DO 480 i = j, min( n, j+kb )
1217 bb( 1+i-j, j ) = b( i, j )
1218 480 CONTINUE
1219 490 CONTINUE
1220 END IF
1221
1222 CALL ssbgvx(
'V',
'A', uplo, n, ka, kb, ab, lda,
1223 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1224 $ iu, abstol, m, d, z, ldz, work,
1225 $ iwork( n+1 ), iwork, iinfo )
1226 IF( iinfo.NE.0 ) THEN
1227 WRITE( nounit, fmt = 9999 )'SSBGVX(V,A' //
1228 $ uplo // ')', iinfo, n, jtype, ioldsd
1229 info = abs( iinfo )
1230 IF( iinfo.LT.0 ) THEN
1231 RETURN
1232 ELSE
1233 result( ntest ) = ulpinv
1234 GO TO 620
1235 END IF
1236 END IF
1237
1238
1239
1240 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1241 $ ldz, d, work, result( ntest ) )
1242
1243
1244 ntest = ntest + 1
1245
1246
1247
1248 IF(
lsame( uplo,
'U' ) )
THEN
1249 DO 520 j = 1, n
1250 DO 500 i = max( 1, j-ka ), j
1251 ab( ka+1+i-j, j ) = a( i, j )
1252 500 CONTINUE
1253 DO 510 i = max( 1, j-kb ), j
1254 bb( kb+1+i-j, j ) = b( i, j )
1255 510 CONTINUE
1256 520 CONTINUE
1257 ELSE
1258 DO 550 j = 1, n
1259 DO 530 i = j, min( n, j+ka )
1260 ab( 1+i-j, j ) = a( i, j )
1261 530 CONTINUE
1262 DO 540 i = j, min( n, j+kb )
1263 bb( 1+i-j, j ) = b( i, j )
1264 540 CONTINUE
1265 550 CONTINUE
1266 END IF
1267
1268 vl = zero
1269 vu = anorm
1270 CALL ssbgvx(
'V',
'V', uplo, n, ka, kb, ab, lda,
1271 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1272 $ iu, abstol, m, d, z, ldz, work,
1273 $ iwork( n+1 ), iwork, iinfo )
1274 IF( iinfo.NE.0 ) THEN
1275 WRITE( nounit, fmt = 9999 )'SSBGVX(V,V' //
1276 $ uplo // ')', iinfo, n, jtype, ioldsd
1277 info = abs( iinfo )
1278 IF( iinfo.LT.0 ) THEN
1279 RETURN
1280 ELSE
1281 result( ntest ) = ulpinv
1282 GO TO 620
1283 END IF
1284 END IF
1285
1286
1287
1288 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1289 $ ldz, d, work, result( ntest ) )
1290
1291 ntest = ntest + 1
1292
1293
1294
1295 IF(
lsame( uplo,
'U' ) )
THEN
1296 DO 580 j = 1, n
1297 DO 560 i = max( 1, j-ka ), j
1298 ab( ka+1+i-j, j ) = a( i, j )
1299 560 CONTINUE
1300 DO 570 i = max( 1, j-kb ), j
1301 bb( kb+1+i-j, j ) = b( i, j )
1302 570 CONTINUE
1303 580 CONTINUE
1304 ELSE
1305 DO 610 j = 1, n
1306 DO 590 i = j, min( n, j+ka )
1307 ab( 1+i-j, j ) = a( i, j )
1308 590 CONTINUE
1309 DO 600 i = j, min( n, j+kb )
1310 bb( 1+i-j, j ) = b( i, j )
1311 600 CONTINUE
1312 610 CONTINUE
1313 END IF
1314
1315 CALL ssbgvx(
'V',
'I', uplo, n, ka, kb, ab, lda,
1316 $ bb, ldb, bp, max( 1, n ), vl, vu, il,
1317 $ iu, abstol, m, d, z, ldz, work,
1318 $ iwork( n+1 ), iwork, iinfo )
1319 IF( iinfo.NE.0 ) THEN
1320 WRITE( nounit, fmt = 9999 )'SSBGVX(V,I' //
1321 $ uplo // ')', iinfo, n, jtype, ioldsd
1322 info = abs( iinfo )
1323 IF( iinfo.LT.0 ) THEN
1324 RETURN
1325 ELSE
1326 result( ntest ) = ulpinv
1327 GO TO 620
1328 END IF
1329 END IF
1330
1331
1332
1333 CALL ssgt01( ibtype, uplo, n, m, a, lda, b, ldb, z,
1334 $ ldz, d, work, result( ntest ) )
1335
1336 END IF
1337
1338 620 CONTINUE
1339 630 CONTINUE
1340
1341
1342
1343 ntestt = ntestt + ntest
1344 CALL slafts(
'SSG', n, n, jtype, ntest, result, ioldsd,
1345 $ thresh, nounit, nerrs )
1346 640 CONTINUE
1347 650 CONTINUE
1348
1349
1350
1351 CALL slasum(
'SSG', nounit, nerrs, ntestt )
1352
1353 RETURN
1354
1355
1356
1357 9999 FORMAT( ' SDRVSG2STG: ', a, ' returned INFO=', i6, '.', / 9x,
1358 $ 'N=', i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
subroutine xerbla(srname, info)
subroutine ssbgv(jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, ldz, work, info)
SSBGV
subroutine ssbgvd(jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, ldz, work, lwork, iwork, liwork, info)
SSBGVD
subroutine ssbgvx(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)
SSBGVX
subroutine ssygv_2stage(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, info)
SSYGV_2STAGE
subroutine ssygv(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, info)
SSYGV
subroutine ssygvd(itype, jobz, uplo, n, a, lda, b, ldb, w, work, lwork, iwork, liwork, info)
SSYGVD
subroutine ssygvx(itype, jobz, range, uplo, n, a, lda, b, ldb, vl, vu, il, iu, abstol, m, w, z, ldz, work, lwork, iwork, ifail, info)
SSYGVX
subroutine sspgv(itype, jobz, uplo, n, ap, bp, w, z, ldz, work, info)
SSPGV
subroutine sspgvd(itype, jobz, uplo, n, ap, bp, w, z, ldz, work, lwork, iwork, liwork, info)
SSPGVD
subroutine sspgvx(itype, jobz, range, uplo, n, ap, bp, vl, vu, il, iu, abstol, m, w, z, ldz, work, iwork, ifail, info)
SSPGVX
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
real function slamch(cmach)
SLAMCH
subroutine slaset(uplo, m, n, alpha, beta, a, lda)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
logical function lsame(ca, cb)
LSAME
subroutine slafts(type, m, n, imat, ntests, result, iseed, thresh, iounit, ie)
SLAFTS
real function slarnd(idist, iseed)
SLARND
subroutine slasum(type, iounit, ie, nrun)
SLASUM
subroutine slatmr(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)
SLATMR
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
subroutine ssgt01(itype, uplo, n, m, a, lda, b, ldb, z, ldz, d, work, result)
SSGT01