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
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