321 SUBROUTINE slatms( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
322 $ kl, ku, pack, a, lda, work, info )
330 CHARACTER DIST, PACK, SYM
331 INTEGER INFO, KL, KU, LDA, M, MODE, N
336 REAL A( lda, * ), D( * ), WORK( * )
343 parameter ( zero = 0.0e0 )
345 parameter ( one = 1.0e0 )
347 parameter ( twopi = 6.2831853071795864769252867663e+0 )
350 LOGICAL GIVENS, ILEXTR, ILTEMP, TOPDWN
351 INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
352 $ ioffg, ioffst, ipack, ipackg, ir, ir1, ir2,
353 $ irow, irsign, iskew, isym, isympk, j, jc, jch,
354 $ jkl, jku, jr, k, llb, minlda, mnmin, mr, nc,
356 REAL ALPHA, ANGLE, C, DUMMY, EXTRA, S, TEMP
361 EXTERNAL lsame, slarnd
368 INTRINSIC abs, cos, max, min, mod,
REAL, SIN
379 IF( m.EQ.0 .OR. n.EQ.0 )
384 IF( lsame( dist,
'U' ) )
THEN
386 ELSE IF( lsame( dist,
'S' ) )
THEN
388 ELSE IF( lsame( dist,
'N' ) )
THEN
396 IF( lsame( sym,
'N' ) )
THEN
399 ELSE IF( lsame( sym,
'P' ) )
THEN
402 ELSE IF( lsame( sym,
'S' ) )
THEN
405 ELSE IF( lsame( sym,
'H' ) )
THEN
415 IF( lsame( pack,
'N' ) )
THEN
417 ELSE IF( lsame( pack,
'U' ) )
THEN
420 ELSE IF( lsame( pack,
'L' ) )
THEN
423 ELSE IF( lsame( pack,
'C' ) )
THEN
426 ELSE IF( lsame( pack,
'R' ) )
THEN
429 ELSE IF( lsame( pack,
'B' ) )
THEN
432 ELSE IF( lsame( pack,
'Q' ) )
THEN
435 ELSE IF( lsame( pack,
'Z' ) )
THEN
449 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
451 ELSE IF( ipack.EQ.7 )
THEN
452 minlda = llb + uub + 1
462 IF(
REAL( llb+uub ).LT.0.3*
REAL( MAX( 1, MR+NC ) ) )
468 IF( lda.LT.m .AND. lda.GE.minlda )
475 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
477 ELSE IF( n.LT.0 )
THEN
479 ELSE IF( idist.EQ.-1 )
THEN
481 ELSE IF( isym.EQ.-1 )
THEN
483 ELSE IF( abs( mode ).GT.6 )
THEN
485 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
488 ELSE IF( kl.LT.0 )
THEN
490 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
492 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
493 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
494 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
495 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
497 ELSE IF( lda.LT.max( 1, minlda ) )
THEN
502 CALL xerbla(
'SLATMS', -info )
509 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
512 IF( mod( iseed( 4 ), 2 ).NE.1 )
513 $ iseed( 4 ) = iseed( 4 ) + 1
519 CALL slatm1( mode, cond, irsign, idist, iseed, d, mnmin, iinfo )
520 IF( iinfo.NE.0 )
THEN
528 IF( abs( d( 1 ) ).LE.abs( d( mnmin ) ) )
THEN
534 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
540 temp = max( temp, abs( d( i ) ) )
543 IF( temp.GT.zero )
THEN
550 CALL sscal( mnmin, alpha, d, 1 )
563 IF( ipack.GT.4 )
THEN
566 IF( ipack.GT.5 )
THEN
582 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
587 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
588 CALL scopy( mnmin, d, 1, a( 1-iskew+ioffst, 1 ), ilda+1 )
589 IF( ipack.LE.2 .OR. ipack.GE.5 )
592 ELSE IF( givens )
THEN
601 IF( ipack.GT.4 )
THEN
607 CALL scopy( mnmin, d, 1, a( 1-iskew+ioffst, 1 ), ilda+1 )
618 DO 40 jr = 1, min( m+jku, n ) + jkl - 1
620 angle = twopi*slarnd( 1, iseed )
623 icol = max( 1, jr-jkl )
625 il = min( n, jr+jku ) + 1 - icol
626 CALL slarot( .true., jr.GT.jkl, .false., il, c,
627 $ s, a( jr-iskew*icol+ioffst, icol ),
628 $ ilda, extra, dummy )
635 DO 30 jch = jr - jkl, 1, -jkl - jku
637 CALL slartg( a( ir+1-iskew*( ic+1 )+ioffst,
638 $ ic+1 ), extra, c, s, dummy )
640 irow = max( 1, jch-jku )
644 CALL slarot( .false., iltemp, .true., il, c, -s,
645 $ a( irow-iskew*ic+ioffst, ic ),
646 $ ilda, temp, extra )
648 CALL slartg( a( irow+1-iskew*( ic+1 )+ioffst,
649 $ ic+1 ), temp, c, s, dummy )
650 icol = max( 1, jch-jku-jkl )
653 CALL slarot( .true., jch.GT.jku+jkl, .true.,
654 $ il, c, -s, a( irow-iskew*icol+
655 $ ioffst, icol ), ilda, extra,
669 DO 70 jc = 1, min( n+jkl, m ) + jku - 1
671 angle = twopi*slarnd( 1, iseed )
674 irow = max( 1, jc-jku )
676 il = min( m, jc+jkl ) + 1 - irow
677 CALL slarot( .false., jc.GT.jku, .false., il, c,
678 $ s, a( irow-iskew*jc+ioffst, jc ),
679 $ ilda, extra, dummy )
686 DO 60 jch = jc - jku, 1, -jkl - jku
688 CALL slartg( a( ir+1-iskew*( ic+1 )+ioffst,
689 $ ic+1 ), extra, c, s, dummy )
691 icol = max( 1, jch-jkl )
695 CALL slarot( .true., iltemp, .true., il, c, -s,
696 $ a( ir-iskew*icol+ioffst, icol ),
697 $ ilda, temp, extra )
699 CALL slartg( a( ir+1-iskew*( icol+1 )+ioffst,
700 $ icol+1 ), temp, c, s, dummy )
701 irow = max( 1, jch-jkl-jku )
704 CALL slarot( .false., jch.GT.jkl+jku, .true.,
705 $ il, c, -s, a( irow-iskew*icol+
706 $ ioffst, icol ), ilda, extra,
727 iendch = min( m, n+jkl ) - 1
728 DO 100 jc = min( m+jku, n ) - 1, 1 - jkl, -1
730 angle = twopi*slarnd( 1, iseed )
733 irow = max( 1, jc-jku+1 )
735 il = min( m, jc+jkl+1 ) + 1 - irow
736 CALL slarot( .false., .false., jc+jkl.LT.m, il,
737 $ c, s, a( irow-iskew*jc+ioffst,
738 $ jc ), ilda, dummy, extra )
744 DO 90 jch = jc + jkl, iendch, jkl + jku
747 CALL slartg( a( jch-iskew*ic+ioffst, ic ),
748 $ extra, c, s, dummy )
751 icol = min( n-1, jch+jku )
752 iltemp = jch + jku.LT.n
754 CALL slarot( .true., ilextr, iltemp, icol+2-ic,
755 $ c, s, a( jch-iskew*ic+ioffst, ic ),
756 $ ilda, extra, temp )
758 CALL slartg( a( jch-iskew*icol+ioffst,
759 $ icol ), temp, c, s, dummy )
760 il = min( iendch, jch+jkl+jku ) + 2 - jch
762 CALL slarot( .false., .true.,
763 $ jch+jkl+jku.LE.iendch, il, c, s,
764 $ a( jch-iskew*icol+ioffst,
765 $ icol ), ilda, temp, extra )
780 iendch = min( n, m+jku ) - 1
781 DO 130 jr = min( n+jkl, m ) - 1, 1 - jku, -1
783 angle = twopi*slarnd( 1, iseed )
786 icol = max( 1, jr-jkl+1 )
788 il = min( n, jr+jku+1 ) + 1 - icol
789 CALL slarot( .true., .false., jr+jku.LT.n, il,
790 $ c, s, a( jr-iskew*icol+ioffst,
791 $ icol ), ilda, dummy, extra )
797 DO 120 jch = jr + jku, iendch, jkl + jku
800 CALL slartg( a( ir-iskew*jch+ioffst, jch ),
801 $ extra, c, s, dummy )
804 irow = min( m-1, jch+jkl )
805 iltemp = jch + jkl.LT.m
807 CALL slarot( .false., ilextr, iltemp, irow+2-ir,
808 $ c, s, a( ir-iskew*jch+ioffst,
809 $ jch ), ilda, extra, temp )
811 CALL slartg( a( irow-iskew*jch+ioffst, jch ),
812 $ temp, c, s, dummy )
813 il = min( iendch, jch+jkl+jku ) + 2 - jch
815 CALL slarot( .true., .true.,
816 $ jch+jkl+jku.LE.iendch, il, c, s,
817 $ a( irow-iskew*jch+ioffst, jch ),
818 $ ilda, temp, extra )
837 IF( ipack.GE.5 )
THEN
843 CALL scopy( mnmin, d, 1, a( 1-iskew+ioffg, 1 ), ilda+1 )
847 irow = max( 1, jc-k )
848 il = min( jc+1, k+2 )
850 temp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
851 angle = twopi*slarnd( 1, iseed )
854 CALL slarot( .false., jc.GT.k, .true., il, c, s,
855 $ a( irow-iskew*jc+ioffg, jc ), ilda,
857 CALL slarot( .true., .true., .false.,
858 $ min( k, n-jc )+1, c, s,
859 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
865 DO 150 jch = jc - k, 1, -k
866 CALL slartg( a( jch+1-iskew*( icol+1 )+ioffg,
867 $ icol+1 ), extra, c, s, dummy )
868 temp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
869 CALL slarot( .true., .true., .true., k+2, c, -s,
870 $ a( ( 1-iskew )*jch+ioffg, jch ),
871 $ ilda, temp, extra )
872 irow = max( 1, jch-k )
873 il = min( jch+1, k+2 )
875 CALL slarot( .false., jch.GT.k, .true., il, c,
876 $ -s, a( irow-iskew*jch+ioffg, jch ),
877 $ ilda, extra, temp )
886 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
888 irow = ioffst - iskew*jc
889 DO 180 jr = jc, min( n, jc+uub )
890 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
893 IF( ipack.EQ.5 )
THEN
894 DO 210 jc = n - uub + 1, n
895 DO 200 jr = n + 2 - jc, uub + 1
900 IF( ipackg.EQ.6 )
THEN
910 IF( ipack.GE.5 )
THEN
917 CALL scopy( mnmin, d, 1, a( 1-iskew+ioffg, 1 ), ilda+1 )
920 DO 230 jc = n - 1, 1, -1
921 il = min( n+1-jc, k+2 )
923 temp = a( 1+( 1-iskew )*jc+ioffg, jc )
924 angle = twopi*slarnd( 1, iseed )
927 CALL slarot( .false., .true., n-jc.GT.k, il, c, s,
928 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
930 icol = max( 1, jc-k+1 )
931 CALL slarot( .true., .false., .true., jc+2-icol, c,
932 $ s, a( jc-iskew*icol+ioffg, icol ),
933 $ ilda, dummy, temp )
938 DO 220 jch = jc + k, n - 1, k
939 CALL slartg( a( jch-iskew*icol+ioffg, icol ),
940 $ extra, c, s, dummy )
941 temp = a( 1+( 1-iskew )*jch+ioffg, jch )
942 CALL slarot( .true., .true., .true., k+2, c, s,
943 $ a( jch-iskew*icol+ioffg, icol ),
944 $ ilda, extra, temp )
945 il = min( n+1-jch, k+2 )
947 CALL slarot( .false., .true., n-jch.GT.k, il, c,
948 $ s, a( ( 1-iskew )*jch+ioffg, jch ),
949 $ ilda, temp, extra )
958 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
960 irow = ioffst - iskew*jc
961 DO 250 jr = jc, max( 1, jc-uub ), -1
962 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
965 IF( ipack.EQ.6 )
THEN
967 DO 270 jr = 1, uub + 1 - jc
972 IF( ipackg.EQ.5 )
THEN
994 CALL slagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1000 CALL slagsy( m, llb, d, a, lda, iseed, work, iinfo )
1003 IF( iinfo.NE.0 )
THEN
1011 IF( ipack.NE.ipackg )
THEN
1012 IF( ipack.EQ.1 )
THEN
1022 ELSE IF( ipack.EQ.2 )
THEN
1032 ELSE IF( ipack.EQ.3 )
THEN
1041 IF( irow.GT.lda )
THEN
1045 a( irow, icol ) = a( i, j )
1049 ELSE IF( ipack.EQ.4 )
THEN
1058 IF( irow.GT.lda )
THEN
1062 a( irow, icol ) = a( i, j )
1066 ELSE IF( ipack.GE.5 )
THEN
1078 DO 370 i = min( j+llb, m ), 1, -1
1079 a( i-j+uub+1, j ) = a( i, j )
1083 DO 400 j = uub + 2, n
1084 DO 390 i = j - uub, min( j+llb, m )
1085 a( i-j+uub+1, j ) = a( i, j )
1095 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1097 DO 410 jr = irow + 1, lda
1103 ELSE IF( ipack.GE.5 )
THEN
1114 DO 430 jr = 1, uub + 1 - jc
1117 DO 440 jr = max( 1, min( ir1, ir2-jc ) ), lda
subroutine slarot(LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, XRIGHT)
SLAROT
subroutine slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine slagsy(N, K, D, A, LDA, ISEED, WORK, INFO)
SLAGSY
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 sscal(N, SA, SX, INCX)
SSCAL
subroutine slagge(M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO)
SLAGGE
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine slatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
SLATM1