321 SUBROUTINE dlatms( 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
332 DOUBLE PRECISION COND, DMAX
336 DOUBLE PRECISION A( lda, * ), D( * ), WORK( * )
342 DOUBLE PRECISION ZERO
343 parameter ( zero = 0.0d0 )
345 parameter ( one = 1.0d0 )
346 DOUBLE PRECISION TWOPI
347 parameter ( twopi = 6.2831853071795864769252867663d+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 DOUBLE PRECISION ALPHA, ANGLE, C, DUMMY, EXTRA, S, TEMP
360 DOUBLE PRECISION DLARND
361 EXTERNAL lsame, dlarnd
368 INTRINSIC abs, cos, dble, max, min, mod, 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( dble( llb+uub ).LT.0.3d0*dble( 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(
'DLATMS', -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 dlatm1( 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 dscal( mnmin, alpha, d, 1 )
563 IF( ipack.GT.4 )
THEN
566 IF( ipack.GT.5 )
THEN
582 CALL dlaset(
'Full', lda, n, zero, zero, a, lda )
587 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
588 CALL dcopy( 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 dcopy( mnmin, d, 1, a( 1-iskew+ioffst, 1 ), ilda+1 )
618 DO 40 jr = 1, min( m+jku, n ) + jkl - 1
620 angle = twopi*dlarnd( 1, iseed )
623 icol = max( 1, jr-jkl )
625 il = min( n, jr+jku ) + 1 - icol
626 CALL dlarot( .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 dlartg( a( ir+1-iskew*( ic+1 )+ioffst,
638 $ ic+1 ), extra, c, s, dummy )
640 irow = max( 1, jch-jku )
644 CALL dlarot( .false., iltemp, .true., il, c, -s,
645 $ a( irow-iskew*ic+ioffst, ic ),
646 $ ilda, temp, extra )
648 CALL dlartg( a( irow+1-iskew*( ic+1 )+ioffst,
649 $ ic+1 ), temp, c, s, dummy )
650 icol = max( 1, jch-jku-jkl )
653 CALL dlarot( .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*dlarnd( 1, iseed )
674 irow = max( 1, jc-jku )
676 il = min( m, jc+jkl ) + 1 - irow
677 CALL dlarot( .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 dlartg( a( ir+1-iskew*( ic+1 )+ioffst,
689 $ ic+1 ), extra, c, s, dummy )
691 icol = max( 1, jch-jkl )
695 CALL dlarot( .true., iltemp, .true., il, c, -s,
696 $ a( ir-iskew*icol+ioffst, icol ),
697 $ ilda, temp, extra )
699 CALL dlartg( a( ir+1-iskew*( icol+1 )+ioffst,
700 $ icol+1 ), temp, c, s, dummy )
701 irow = max( 1, jch-jkl-jku )
704 CALL dlarot( .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*dlarnd( 1, iseed )
733 irow = max( 1, jc-jku+1 )
735 il = min( m, jc+jkl+1 ) + 1 - irow
736 CALL dlarot( .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 dlartg( 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 dlarot( .true., ilextr, iltemp, icol+2-ic,
755 $ c, s, a( jch-iskew*ic+ioffst, ic ),
756 $ ilda, extra, temp )
758 CALL dlartg( a( jch-iskew*icol+ioffst,
759 $ icol ), temp, c, s, dummy )
760 il = min( iendch, jch+jkl+jku ) + 2 - jch
762 CALL dlarot( .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*dlarnd( 1, iseed )
786 icol = max( 1, jr-jkl+1 )
788 il = min( n, jr+jku+1 ) + 1 - icol
789 CALL dlarot( .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 dlartg( 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 dlarot( .false., ilextr, iltemp, irow+2-ir,
808 $ c, s, a( ir-iskew*jch+ioffst,
809 $ jch ), ilda, extra, temp )
811 CALL dlartg( a( irow-iskew*jch+ioffst, jch ),
812 $ temp, c, s, dummy )
813 il = min( iendch, jch+jkl+jku ) + 2 - jch
815 CALL dlarot( .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 dcopy( 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*dlarnd( 1, iseed )
854 CALL dlarot( .false., jc.GT.k, .true., il, c, s,
855 $ a( irow-iskew*jc+ioffg, jc ), ilda,
857 CALL dlarot( .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 dlartg( 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 dlarot( .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 dlarot( .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 dcopy( 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*dlarnd( 1, iseed )
927 CALL dlarot( .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 dlarot( .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 dlartg( a( jch-iskew*icol+ioffg, icol ),
940 $ extra, c, s, dummy )
941 temp = a( 1+( 1-iskew )*jch+ioffg, jch )
942 CALL dlarot( .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 dlarot( .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 dlagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1000 CALL dlagsy( 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 dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dlagsy(N, K, D, A, LDA, ISEED, WORK, INFO)
DLAGSY
subroutine dlatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
DLATM1
subroutine dlarot(LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, XRIGHT)
DLAROT
subroutine dlartg(F, G, CS, SN, R)
DLARTG generates a plane rotation with real cosine and real sine.
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...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine dlagge(M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO)
DLAGGE
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS