359
360
361
362
363
364
365 INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN,
366 $ NOUT, NSIZE
367 REAL THRESH
368
369
370 LOGICAL BWORK( * )
371 INTEGER IWORK( * )
372 REAL A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
373 $ ALPHAR( * ), B( LDA, * ), BETA( * ),
374 $ BI( LDA, * ), C( LDC, * ), Q( LDA, * ), S( * ),
375 $ WORK( * ), Z( LDA, * )
376
377
378
379
380
381 REAL ZERO, ONE, TEN
382 parameter( zero = 0.0e+0, one = 1.0e+0, ten = 1.0e+1 )
383
384
385 LOGICAL ILABAD
386 CHARACTER SENSE
387 INTEGER BDSPAC, I, I1, IFUNC, IINFO, J, LINFO, MAXWRK,
388 $ MINWRK, MM, MN2, NERRS, NPTKNT, NTEST, NTESTT,
389 $ PRTYPE, QBA, QBB
390 REAL ABNRM, BIGNUM, DIFTRU, PLTRU, SMLNUM, TEMP1,
391 $ TEMP2, THRSH2, ULP, ULPINV, WEIGHT
392
393
394 REAL DIFEST( 2 ), PL( 2 ), RESULT( 10 )
395
396
397 LOGICAL SLCTSX
398 INTEGER ILAENV
399 REAL SLAMCH, SLANGE
401
402
405
406
407 INTRINSIC abs, max, sqrt
408
409
410 LOGICAL FS
411 INTEGER K, M, MPLUSN, N
412
413
414 COMMON / mn / m, n, mplusn, k, fs
415
416
417
418
419
420 IF( nsize.LT.0 ) THEN
421 info = -1
422 ELSE IF( thresh.LT.zero ) THEN
423 info = -2
424 ELSE IF( nin.LE.0 ) THEN
425 info = -3
426 ELSE IF( nout.LE.0 ) THEN
427 info = -4
428 ELSE IF( lda.LT.1 .OR. lda.LT.nsize ) THEN
429 info = -6
430 ELSE IF( ldc.LT.1 .OR. ldc.LT.nsize*nsize / 2 ) THEN
431 info = -17
432 ELSE IF( liwork.LT.nsize+6 ) THEN
433 info = -21
434 END IF
435
436
437
438
439
440
441
442
443 minwrk = 1
444 IF( info.EQ.0 .AND. lwork.GE.1 ) THEN
445
446 minwrk = max( 10*( nsize+1 ), 5*nsize*nsize / 2 )
447
448
449
450 maxwrk = 9*( nsize+1 ) + nsize*
451 $
ilaenv( 1,
'SGEQRF',
' ', nsize, 1, nsize, 0 )
452 maxwrk = max( maxwrk, 9*( nsize+1 )+nsize*
453 $
ilaenv( 1,
'SORGQR',
' ', nsize, 1, nsize, -1 ) )
454
455
456
457 bdspac = 5*nsize*nsize / 2
458 maxwrk = max( maxwrk, 3*nsize*nsize / 2+nsize*nsize*
459 $
ilaenv( 1,
'SGEBRD',
' ', nsize*nsize / 2,
460 $ nsize*nsize / 2, -1, -1 ) )
461 maxwrk = max( maxwrk, bdspac )
462
463 maxwrk = max( maxwrk, minwrk )
464
465 work( 1 ) = maxwrk
466 END IF
467
468 IF( lwork.LT.minwrk )
469 $ info = -19
470
471 IF( info.NE.0 ) THEN
472 CALL xerbla(
'SDRGSX', -info )
473 RETURN
474 END IF
475
476
477
479 ulpinv = one / ulp
480 smlnum =
slamch(
'S' ) / ulp
481 bignum = one / smlnum
482 thrsh2 = ten*thresh
483 ntestt = 0
484 nerrs = 0
485
486
487
488 ifunc = 0
489 IF( nsize.EQ.0 )
490 $ GO TO 70
491
492
493
494
495
496 prtype = 0
497 qba = 3
498 qbb = 4
499 weight = sqrt( ulp )
500
501 DO 60 ifunc = 0, 3
502 DO 50 prtype = 1, 5
503 DO 40 m = 1, nsize - 1
504 DO 30 n = 1, nsize - m
505
506 weight = one / weight
507 mplusn = m + n
508
509
510
511 fs = .true.
512 k = 0
513
514 CALL slaset(
'Full', mplusn, mplusn, zero, zero, ai,
515 $ lda )
516 CALL slaset(
'Full', mplusn, mplusn, zero, zero, bi,
517 $ lda )
518
519 CALL slatm5( prtype, m, n, ai, lda, ai( m+1, m+1 ),
520 $ lda, ai( 1, m+1 ), lda, bi, lda,
521 $ bi( m+1, m+1 ), lda, bi( 1, m+1 ), lda,
522 $ q, lda, z, lda, weight, qba, qbb )
523
524
525
526
527
528
529 IF( ifunc.EQ.0 ) THEN
530 sense = 'N'
531 ELSE IF( ifunc.EQ.1 ) THEN
532 sense = 'E'
533 ELSE IF( ifunc.EQ.2 ) THEN
534 sense = 'V'
535 ELSE IF( ifunc.EQ.3 ) THEN
536 sense = 'B'
537 END IF
538
539 CALL slacpy(
'Full', mplusn, mplusn, ai, lda, a, lda )
540 CALL slacpy(
'Full', mplusn, mplusn, bi, lda, b, lda )
541
543 $ lda, bi, lda, mm, alphar, alphai, beta,
544 $ q, lda, z, lda, pl, difest, work, lwork,
545 $ iwork, liwork, bwork, linfo )
546
547 IF( linfo.NE.0 .AND. linfo.NE.mplusn+2 ) THEN
548 result( 1 ) = ulpinv
549 WRITE( nout, fmt = 9999 )'SGGESX', linfo, mplusn,
550 $ prtype
551 info = linfo
552 GO TO 30
553 END IF
554
555
556
557 CALL slacpy(
'Full', mplusn, mplusn, ai, lda, work,
558 $ mplusn )
559 CALL slacpy(
'Full', mplusn, mplusn, bi, lda,
560 $ work( mplusn*mplusn+1 ), mplusn )
561 abnrm =
slange(
'Fro', mplusn, 2*mplusn, work, mplusn,
562 $ work )
563
564
565
566 CALL sget51( 1, mplusn, a, lda, ai, lda, q, lda, z,
567 $ lda, work, result( 1 ) )
568 CALL sget51( 1, mplusn, b, lda, bi, lda, q, lda, z,
569 $ lda, work, result( 2 ) )
570 CALL sget51( 3, mplusn, b, lda, bi, lda, q, lda, q,
571 $ lda, work, result( 3 ) )
572 CALL sget51( 3, mplusn, b, lda, bi, lda, z, lda, z,
573 $ lda, work, result( 4 ) )
574 ntest = 4
575
576
577
578
579 temp1 = zero
580 result( 5 ) = zero
581 result( 6 ) = zero
582
583 DO 10 j = 1, mplusn
584 ilabad = .false.
585 IF( alphai( j ).EQ.zero ) THEN
586 temp2 = ( abs( alphar( j )-ai( j, j ) ) /
587 $ max( smlnum, abs( alphar( j ) ),
588 $ abs( ai( j, j ) ) )+
589 $ abs( beta( j )-bi( j, j ) ) /
590 $ max( smlnum, abs( beta( j ) ),
591 $ abs( bi( j, j ) ) ) ) / ulp
592 IF( j.LT.mplusn ) THEN
593 IF( ai( j+1, j ).NE.zero ) THEN
594 ilabad = .true.
595 result( 5 ) = ulpinv
596 END IF
597 END IF
598 IF( j.GT.1 ) THEN
599 IF( ai( j, j-1 ).NE.zero ) THEN
600 ilabad = .true.
601 result( 5 ) = ulpinv
602 END IF
603 END IF
604 ELSE
605 IF( alphai( j ).GT.zero ) THEN
606 i1 = j
607 ELSE
608 i1 = j - 1
609 END IF
610 IF( i1.LE.0 .OR. i1.GE.mplusn ) THEN
611 ilabad = .true.
612 ELSE IF( i1.LT.mplusn-1 ) THEN
613 IF( ai( i1+2, i1+1 ).NE.zero ) THEN
614 ilabad = .true.
615 result( 5 ) = ulpinv
616 END IF
617 ELSE IF( i1.GT.1 ) THEN
618 IF( ai( i1, i1-1 ).NE.zero ) THEN
619 ilabad = .true.
620 result( 5 ) = ulpinv
621 END IF
622 END IF
623 IF( .NOT.ilabad ) THEN
624 CALL sget53( ai( i1, i1 ), lda, bi( i1, i1 ),
625 $ lda, beta( j ), alphar( j ),
626 $ alphai( j ), temp2, iinfo )
627 IF( iinfo.GE.3 ) THEN
628 WRITE( nout, fmt = 9997 )iinfo, j,
629 $ mplusn, prtype
630 info = abs( iinfo )
631 END IF
632 ELSE
633 temp2 = ulpinv
634 END IF
635 END IF
636 temp1 = max( temp1, temp2 )
637 IF( ilabad ) THEN
638 WRITE( nout, fmt = 9996 )j, mplusn, prtype
639 END IF
640 10 CONTINUE
641 result( 6 ) = temp1
642 ntest = ntest + 2
643
644
645
646 result( 7 ) = zero
647 IF( linfo.EQ.mplusn+3 ) THEN
648 result( 7 ) = ulpinv
649 ELSE IF( mm.NE.n ) THEN
650 result( 7 ) = ulpinv
651 END IF
652 ntest = ntest + 1
653
654
655
656
657 result( 8 ) = zero
658 mn2 = mm*( mplusn-mm )*2
659 IF( ifunc.GE.2 .AND. mn2.LE.ncmax*ncmax ) THEN
660
661
662
663
664 CALL slakf2( mm, mplusn-mm, ai, lda,
665 $ ai( mm+1, mm+1 ), bi,
666 $ bi( mm+1, mm+1 ), c, ldc )
667
668 CALL sgesvd(
'N',
'N', mn2, mn2, c, ldc, s, work,
669 $ 1, work( 2 ), 1, work( 3 ), lwork-2,
670 $ info )
671 diftru = s( mn2 )
672
673 IF( difest( 2 ).EQ.zero ) THEN
674 IF( diftru.GT.abnrm*ulp )
675 $ result( 8 ) = ulpinv
676 ELSE IF( diftru.EQ.zero ) THEN
677 IF( difest( 2 ).GT.abnrm*ulp )
678 $ result( 8 ) = ulpinv
679 ELSE IF( ( diftru.GT.thrsh2*difest( 2 ) ) .OR.
680 $ ( diftru*thrsh2.LT.difest( 2 ) ) ) THEN
681 result( 8 ) = max( diftru / difest( 2 ),
682 $ difest( 2 ) / diftru )
683 END IF
684 ntest = ntest + 1
685 END IF
686
687
688
689 result( 9 ) = zero
690 IF( linfo.EQ.( mplusn+2 ) ) THEN
691 IF( diftru.GT.abnrm*ulp )
692 $ result( 9 ) = ulpinv
693 IF( ( ifunc.GT.1 ) .AND. ( difest( 2 ).NE.zero ) )
694 $ result( 9 ) = ulpinv
695 IF( ( ifunc.EQ.1 ) .AND. ( pl( 1 ).NE.zero ) )
696 $ result( 9 ) = ulpinv
697 ntest = ntest + 1
698 END IF
699
700 ntestt = ntestt + ntest
701
702
703
704 DO 20 j = 1, 9
705 IF( result( j ).GE.thresh ) THEN
706
707
708
709
710 IF( nerrs.EQ.0 ) THEN
711 WRITE( nout, fmt = 9995 )'SGX'
712
713
714
715 WRITE( nout, fmt = 9993 )
716
717
718
719 WRITE( nout, fmt = 9992 )'orthogonal', '''',
720 $ 'transpose', ( '''', i = 1, 4 )
721
722 END IF
723 nerrs = nerrs + 1
724 IF( result( j ).LT.10000.0 ) THEN
725 WRITE( nout, fmt = 9991 )mplusn, prtype,
726 $ weight, m, j, result( j )
727 ELSE
728 WRITE( nout, fmt = 9990 )mplusn, prtype,
729 $ weight, m, j, result( j )
730 END IF
731 END IF
732 20 CONTINUE
733
734 30 CONTINUE
735 40 CONTINUE
736 50 CONTINUE
737 60 CONTINUE
738
739 GO TO 150
740
741 70 CONTINUE
742
743
744
745
746 nptknt = 0
747
748 80 CONTINUE
749 READ( nin, fmt = *, END = 140 )mplusn
750 IF( mplusn.EQ.0 )
751 $ GO TO 140
752 READ( nin, fmt = *, END = 140 )n
753 DO 90 i = 1, mplusn
754 READ( nin, fmt = * )( ai( i, j ), j = 1, mplusn )
755 90 CONTINUE
756 DO 100 i = 1, mplusn
757 READ( nin, fmt = * )( bi( i, j ), j = 1, mplusn )
758 100 CONTINUE
759 READ( nin, fmt = * )pltru, diftru
760
761 nptknt = nptknt + 1
762 fs = .true.
763 k = 0
764 m = mplusn - n
765
766 CALL slacpy(
'Full', mplusn, mplusn, ai, lda, a, lda )
767 CALL slacpy(
'Full', mplusn, mplusn, bi, lda, b, lda )
768
769
770
771
772 CALL sggesx(
'V',
'V',
'S',
slctsx,
'B', mplusn, ai, lda, bi, lda,
773 $ mm, alphar, alphai, beta, q, lda, z, lda, pl, difest,
774 $ work, lwork, iwork, liwork, bwork, linfo )
775
776 IF( linfo.NE.0 .AND. linfo.NE.mplusn+2 ) THEN
777 result( 1 ) = ulpinv
778 WRITE( nout, fmt = 9998 )'SGGESX', linfo, mplusn, nptknt
779 GO TO 130
780 END IF
781
782
783
784
785 CALL slacpy(
'Full', mplusn, mplusn, ai, lda, work, mplusn )
786 CALL slacpy(
'Full', mplusn, mplusn, bi, lda,
787 $ work( mplusn*mplusn+1 ), mplusn )
788 abnrm =
slange(
'Fro', mplusn, 2*mplusn, work, mplusn, work )
789
790
791
792 CALL sget51( 1, mplusn, a, lda, ai, lda, q, lda, z, lda, work,
793 $ result( 1 ) )
794 CALL sget51( 1, mplusn, b, lda, bi, lda, q, lda, z, lda, work,
795 $ result( 2 ) )
796 CALL sget51( 3, mplusn, b, lda, bi, lda, q, lda, q, lda, work,
797 $ result( 3 ) )
798 CALL sget51( 3, mplusn, b, lda, bi, lda, z, lda, z, lda, work,
799 $ result( 4 ) )
800
801
802
803
804 ntest = 6
805 temp1 = zero
806 result( 5 ) = zero
807 result( 6 ) = zero
808
809 DO 110 j = 1, mplusn
810 ilabad = .false.
811 IF( alphai( j ).EQ.zero ) THEN
812 temp2 = ( abs( alphar( j )-ai( j, j ) ) /
813 $ max( smlnum, abs( alphar( j ) ), abs( ai( j,
814 $ j ) ) )+abs( beta( j )-bi( j, j ) ) /
815 $ max( smlnum, abs( beta( j ) ), abs( bi( j, j ) ) ) )
816 $ / ulp
817 IF( j.LT.mplusn ) THEN
818 IF( ai( j+1, j ).NE.zero ) THEN
819 ilabad = .true.
820 result( 5 ) = ulpinv
821 END IF
822 END IF
823 IF( j.GT.1 ) THEN
824 IF( ai( j, j-1 ).NE.zero ) THEN
825 ilabad = .true.
826 result( 5 ) = ulpinv
827 END IF
828 END IF
829 ELSE
830 IF( alphai( j ).GT.zero ) THEN
831 i1 = j
832 ELSE
833 i1 = j - 1
834 END IF
835 IF( i1.LE.0 .OR. i1.GE.mplusn ) THEN
836 ilabad = .true.
837 ELSE IF( i1.LT.mplusn-1 ) THEN
838 IF( ai( i1+2, i1+1 ).NE.zero ) THEN
839 ilabad = .true.
840 result( 5 ) = ulpinv
841 END IF
842 ELSE IF( i1.GT.1 ) THEN
843 IF( ai( i1, i1-1 ).NE.zero ) THEN
844 ilabad = .true.
845 result( 5 ) = ulpinv
846 END IF
847 END IF
848 IF( .NOT.ilabad ) THEN
849 CALL sget53( ai( i1, i1 ), lda, bi( i1, i1 ), lda,
850 $ beta( j ), alphar( j ), alphai( j ), temp2,
851 $ iinfo )
852 IF( iinfo.GE.3 ) THEN
853 WRITE( nout, fmt = 9997 )iinfo, j, mplusn, nptknt
854 info = abs( iinfo )
855 END IF
856 ELSE
857 temp2 = ulpinv
858 END IF
859 END IF
860 temp1 = max( temp1, temp2 )
861 IF( ilabad ) THEN
862 WRITE( nout, fmt = 9996 )j, mplusn, nptknt
863 END IF
864 110 CONTINUE
865 result( 6 ) = temp1
866
867
868
869 ntest = 7
870 result( 7 ) = zero
871 IF( linfo.EQ.mplusn+3 )
872 $ result( 7 ) = ulpinv
873
874
875
876 ntest = 8
877 result( 8 ) = zero
878 IF( difest( 2 ).EQ.zero ) THEN
879 IF( diftru.GT.abnrm*ulp )
880 $ result( 8 ) = ulpinv
881 ELSE IF( diftru.EQ.zero ) THEN
882 IF( difest( 2 ).GT.abnrm*ulp )
883 $ result( 8 ) = ulpinv
884 ELSE IF( ( diftru.GT.thrsh2*difest( 2 ) ) .OR.
885 $ ( diftru*thrsh2.LT.difest( 2 ) ) ) THEN
886 result( 8 ) = max( diftru / difest( 2 ), difest( 2 ) / diftru )
887 END IF
888
889
890
891 ntest = 9
892 result( 9 ) = zero
893 IF( linfo.EQ.( mplusn+2 ) ) THEN
894 IF( diftru.GT.abnrm*ulp )
895 $ result( 9 ) = ulpinv
896 IF( ( ifunc.GT.1 ) .AND. ( difest( 2 ).NE.zero ) )
897 $ result( 9 ) = ulpinv
898 IF( ( ifunc.EQ.1 ) .AND. ( pl( 1 ).NE.zero ) )
899 $ result( 9 ) = ulpinv
900 END IF
901
902
903
904 ntest = 10
905 result( 10 ) = zero
906 IF( pl( 1 ).EQ.zero ) THEN
907 IF( pltru.GT.abnrm*ulp )
908 $ result( 10 ) = ulpinv
909 ELSE IF( pltru.EQ.zero ) THEN
910 IF( pl( 1 ).GT.abnrm*ulp )
911 $ result( 10 ) = ulpinv
912 ELSE IF( ( pltru.GT.thresh*pl( 1 ) ) .OR.
913 $ ( pltru*thresh.LT.pl( 1 ) ) ) THEN
914 result( 10 ) = ulpinv
915 END IF
916
917 ntestt = ntestt + ntest
918
919
920
921 DO 120 j = 1, ntest
922 IF( result( j ).GE.thresh ) THEN
923
924
925
926
927 IF( nerrs.EQ.0 ) THEN
928 WRITE( nout, fmt = 9995 )'SGX'
929
930
931
932 WRITE( nout, fmt = 9994 )
933
934
935
936 WRITE( nout, fmt = 9992 )'orthogonal', '''',
937 $ 'transpose', ( '''', i = 1, 4 )
938
939 END IF
940 nerrs = nerrs + 1
941 IF( result( j ).LT.10000.0 ) THEN
942 WRITE( nout, fmt = 9989 )nptknt, mplusn, j, result( j )
943 ELSE
944 WRITE( nout, fmt = 9988 )nptknt, mplusn, j, result( j )
945 END IF
946 END IF
947
948 120 CONTINUE
949
950 130 CONTINUE
951 GO TO 80
952 140 CONTINUE
953
954 150 CONTINUE
955
956
957
958 CALL alasvm(
'SGX', nout, nerrs, ntestt, 0 )
959
960 work( 1 ) = maxwrk
961
962 RETURN
963
964 9999 FORMAT( ' SDRGSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
965 $ i6, ', JTYPE=', i6, ')' )
966
967 9998 FORMAT( ' SDRGSX: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
968 $ i6, ', Input Example #', i2, ')' )
969
970 9997 FORMAT( ' SDRGSX: SGET53 returned INFO=', i1, ' for eigenvalue ',
971 $ i6, '.', / 9x, 'N=', i6, ', JTYPE=', i6, ')' )
972
973 9996 FORMAT( ' SDRGSX: S not in Schur form at eigenvalue ', i6, '.',
974 $ / 9x, 'N=', i6, ', JTYPE=', i6, ')' )
975
976 9995 FORMAT( / 1x, a3, ' -- Real Expert Generalized Schur form',
977 $ ' problem driver' )
978
979 9994 FORMAT( 'Input Example' )
980
981 9993 FORMAT( ' Matrix types: ', /
982 $ ' 1: A is a block diagonal matrix of Jordan blocks ',
983 $ 'and B is the identity ', / ' matrix, ',
984 $ / ' 2: A and B are upper triangular matrices, ',
985 $ / ' 3: A and B are as type 2, but each second diagonal ',
986 $ 'block in A_11 and ', /
987 $ ' each third diagonal block in A_22 are 2x2 blocks,',
988 $ / ' 4: A and B are block diagonal matrices, ',
989 $ / ' 5: (A,B) has potentially close or common ',
990 $ 'eigenvalues.', / )
991
992 9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
993 $ 'Q and Z are ', a, ',', / 19x,
994 $ ' a is alpha, b is beta, and ', a, ' means ', a, '.)',
995 $ / ' 1 = | A - Q S Z', a,
996 $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', a,
997 $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', a,
998 $ ' | / ( n ulp ) 4 = | I - ZZ', a,
999 $ ' | / ( n ulp )', / ' 5 = 1/ULP if A is not in ',
1000 $ 'Schur form S', / ' 6 = difference between (alpha,beta)',
1001 $ ' and diagonals of (S,T)', /
1002 $ ' 7 = 1/ULP if SDIM is not the correct number of ',
1003 $ 'selected eigenvalues', /
1004 $ ' 8 = 1/ULP if DIFEST/DIFTRU > 10*THRESH or ',
1005 $ 'DIFTRU/DIFEST > 10*THRESH',
1006 $ / ' 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B) ',
1007 $ 'when reordering fails', /
1008 $ ' 10 = 1/ULP if PLEST/PLTRU > THRESH or ',
1009 $ 'PLTRU/PLEST > THRESH', /
1010 $ ' ( Test 10 is only for input examples )', / )
1011 9991 FORMAT( ' Matrix order=', i2, ', type=', i2, ', a=', e10.3,
1012 $ ', order(A_11)=', i2, ', result ', i2, ' is ', 0p, f8.2 )
1013 9990 FORMAT( ' Matrix order=', i2, ', type=', i2, ', a=', e10.3,
1014 $ ', order(A_11)=', i2, ', result ', i2, ' is ', 0p, e10.3 )
1015 9989 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
1016 $ ' result ', i2, ' is', 0p, f8.2 )
1017 9988 FORMAT( ' Input example #', i2, ', matrix order=', i4, ',',
1018 $ ' result ', i2, ' is', 1p, e10.3 )
1019
1020
1021
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
subroutine xerbla(srname, info)
subroutine sgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, info)
SGESVD computes the singular value decomposition (SVD) for GE matrices
subroutine sggesx(jobvsl, jobvsr, sort, selctg, sense, n, a, lda, b, ldb, sdim, alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, rconde, rcondv, work, lwork, iwork, liwork, bwork, info)
SGGESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
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
real function slange(norm, m, n, a, lda, work)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
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.
subroutine sget51(itype, n, a, lda, b, ldb, u, ldu, v, ldv, work, result)
SGET51
subroutine sget53(a, lda, b, ldb, scale, wr, wi, result, info)
SGET53
subroutine slakf2(m, n, a, lda, b, d, e, z, ldz)
SLAKF2
subroutine slatm5(prtype, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, r, ldr, l, ldl, alpha, qblcka, qblckb)
SLATM5
logical function slctsx(ar, ai, beta)
SLCTSX