331 SUBROUTINE dlatmt( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
332 $ rank, kl, ku, pack, a, lda, work, info )
340 DOUBLE PRECISION cond, dmax
341 INTEGER info, kl, ku, lda, m, mode, n, rank
342 CHARACTER dist, pack, sym
345 DOUBLE PRECISION a( lda, * ), d( * ), work( * )
352 DOUBLE PRECISION zero
353 parameter( zero = 0.0d0 )
355 parameter( one = 1.0d0 )
356 DOUBLE PRECISION twopi
357 parameter( twopi = 6.2831853071795864769252867663d+0 )
360 DOUBLE PRECISION alpha, angle, c, dummy, extra, s, temp
361 INTEGER i, ic, icol, idist, iendch, iinfo, il, ilda,
362 $ ioffg, ioffst, ipack, ipackg, ir, ir1, ir2,
363 $ irow, irsign, iskew, isym, isympk, j, jc, jch,
364 $ jkl, jku, jr, k, llb, minlda, mnmin, mr, nc,
366 LOGICAL givens, ilextr, iltemp, topdwn
378 INTRINSIC abs, cos, dble, max, min, mod, sin
389 IF( m.EQ.0 .OR. n.EQ.0 )
394 IF(
lsame( dist,
'U' ) )
THEN
396 ELSE IF(
lsame( dist,
'S' ) )
THEN
398 ELSE IF(
lsame( dist,
'N' ) )
THEN
406 IF(
lsame( sym,
'N' ) )
THEN
409 ELSE IF(
lsame( sym,
'P' ) )
THEN
412 ELSE IF(
lsame( sym,
'S' ) )
THEN
415 ELSE IF(
lsame( sym,
'H' ) )
THEN
425 IF(
lsame( pack,
'N' ) )
THEN
427 ELSE IF(
lsame( pack,
'U' ) )
THEN
430 ELSE IF(
lsame( pack,
'L' ) )
THEN
433 ELSE IF(
lsame( pack,
'C' ) )
THEN
436 ELSE IF(
lsame( pack,
'R' ) )
THEN
439 ELSE IF(
lsame( pack,
'B' ) )
THEN
442 ELSE IF(
lsame( pack,
'Q' ) )
THEN
445 ELSE IF(
lsame( pack,
'Z' ) )
THEN
459 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
461 ELSE IF( ipack.EQ.7 )
THEN
462 minlda = llb + uub + 1
472 IF( dble( llb+uub ).LT.0.3d0*dble( max( 1, mr+nc ) ) )
478 IF( lda.LT.m .AND. lda.GE.minlda )
485 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
487 ELSE IF( n.LT.0 )
THEN
489 ELSE IF( idist.EQ.-1 )
THEN
491 ELSE IF( isym.EQ.-1 )
THEN
493 ELSE IF( abs( mode ).GT.6 )
THEN
495 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
498 ELSE IF( kl.LT.0 )
THEN
500 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
502 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
503 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
504 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
505 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
507 ELSE IF( lda.LT.max( 1, minlda ) )
THEN
512 CALL
xerbla(
'DLATMT', -info )
519 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
522 IF( mod( iseed( 4 ), 2 ).NE.1 )
523 $ iseed( 4 ) = iseed( 4 ) + 1
529 CALL
dlatm7( mode, cond, irsign, idist, iseed, d, mnmin, rank,
531 IF( iinfo.NE.0 )
THEN
539 IF( abs( d( 1 ) ).LE.abs( d( rank ) ) )
THEN
545 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
551 temp = max( temp, abs( d( i ) ) )
554 IF( temp.GT.zero )
THEN
561 CALL
dscal( rank, alpha, d, 1 )
574 IF( ipack.GT.4 )
THEN
577 IF( ipack.GT.5 )
THEN
593 CALL
dlaset(
'Full', lda, n, zero, zero, a, lda )
598 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
599 CALL
dcopy( mnmin, d, 1, a( 1-iskew+ioffst, 1 ), ilda+1 )
600 IF( ipack.LE.2 .OR. ipack.GE.5 )
603 ELSE IF( givens )
THEN
612 IF( ipack.GT.4 )
THEN
618 CALL
dcopy( mnmin, d, 1, a( 1-iskew+ioffst, 1 ), ilda+1 )
629 DO 130 jr = 1, min( m+jku, n ) + jkl - 1
631 angle = twopi*
dlarnd( 1, iseed )
634 icol = max( 1, jr-jkl )
636 il = min( n, jr+jku ) + 1 - icol
637 CALL
dlarot( .true., jr.GT.jkl, .false., il, c,
638 $ s, a( jr-iskew*icol+ioffst, icol ),
639 $ ilda, extra, dummy )
646 DO 120 jch = jr - jkl, 1, -jkl - jku
648 CALL
dlartg( a( ir+1-iskew*( ic+1 )+ioffst,
649 $ ic+1 ), extra, c, s, dummy )
651 irow = max( 1, jch-jku )
655 CALL
dlarot( .false., iltemp, .true., il, c, -s,
656 $ a( irow-iskew*ic+ioffst, ic ),
657 $ ilda, temp, extra )
659 CALL
dlartg( a( irow+1-iskew*( ic+1 )+ioffst,
660 $ ic+1 ), temp, c, s, dummy )
661 icol = max( 1, jch-jku-jkl )
664 CALL
dlarot( .true., jch.GT.jku+jkl, .true.,
665 $ il, c, -s, a( irow-iskew*icol+
666 $ ioffst, icol ), ilda, extra,
680 DO 160 jc = 1, min( n+jkl, m ) + jku - 1
682 angle = twopi*
dlarnd( 1, iseed )
685 irow = max( 1, jc-jku )
687 il = min( m, jc+jkl ) + 1 - irow
688 CALL
dlarot( .false., jc.GT.jku, .false., il, c,
689 $ s, a( irow-iskew*jc+ioffst, jc ),
690 $ ilda, extra, dummy )
697 DO 150 jch = jc - jku, 1, -jkl - jku
699 CALL
dlartg( a( ir+1-iskew*( ic+1 )+ioffst,
700 $ ic+1 ), extra, c, s, dummy )
702 icol = max( 1, jch-jkl )
706 CALL
dlarot( .true., iltemp, .true., il, c, -s,
707 $ a( ir-iskew*icol+ioffst, icol ),
708 $ ilda, temp, extra )
710 CALL
dlartg( a( ir+1-iskew*( icol+1 )+ioffst,
711 $ icol+1 ), temp, c, s, dummy )
712 irow = max( 1, jch-jkl-jku )
715 CALL
dlarot( .false., jch.GT.jkl+jku, .true.,
716 $ il, c, -s, a( irow-iskew*icol+
717 $ ioffst, icol ), ilda, extra,
738 iendch = min( m, n+jkl ) - 1
739 DO 190 jc = min( m+jku, n ) - 1, 1 - jkl, -1
741 angle = twopi*
dlarnd( 1, iseed )
744 irow = max( 1, jc-jku+1 )
746 il = min( m, jc+jkl+1 ) + 1 - irow
747 CALL
dlarot( .false., .false., jc+jkl.LT.m, il,
748 $ c, s, a( irow-iskew*jc+ioffst,
749 $ jc ), ilda, dummy, extra )
755 DO 180 jch = jc + jkl, iendch, jkl + jku
758 CALL
dlartg( a( jch-iskew*ic+ioffst, ic ),
759 $ extra, c, s, dummy )
762 icol = min( n-1, jch+jku )
763 iltemp = jch + jku.LT.n
765 CALL
dlarot( .true., ilextr, iltemp, icol+2-ic,
766 $ c, s, a( jch-iskew*ic+ioffst, ic ),
767 $ ilda, extra, temp )
769 CALL
dlartg( a( jch-iskew*icol+ioffst,
770 $ icol ), temp, c, s, dummy )
771 il = min( iendch, jch+jkl+jku ) + 2 - jch
773 CALL
dlarot( .false., .true.,
774 $ jch+jkl+jku.LE.iendch, il, c, s,
775 $ a( jch-iskew*icol+ioffst,
776 $ icol ), ilda, temp, extra )
791 iendch = min( n, m+jku ) - 1
792 DO 220 jr = min( n+jkl, m ) - 1, 1 - jku, -1
794 angle = twopi*
dlarnd( 1, iseed )
797 icol = max( 1, jr-jkl+1 )
799 il = min( n, jr+jku+1 ) + 1 - icol
800 CALL
dlarot( .true., .false., jr+jku.LT.n, il,
801 $ c, s, a( jr-iskew*icol+ioffst,
802 $ icol ), ilda, dummy, extra )
808 DO 210 jch = jr + jku, iendch, jkl + jku
811 CALL
dlartg( a( ir-iskew*jch+ioffst, jch ),
812 $ extra, c, s, dummy )
815 irow = min( m-1, jch+jkl )
816 iltemp = jch + jkl.LT.m
818 CALL
dlarot( .false., ilextr, iltemp, irow+2-ir,
819 $ c, s, a( ir-iskew*jch+ioffst,
820 $ jch ), ilda, extra, temp )
822 CALL
dlartg( a( irow-iskew*jch+ioffst, jch ),
823 $ temp, c, s, dummy )
824 il = min( iendch, jch+jkl+jku ) + 2 - jch
826 CALL
dlarot( .true., .true.,
827 $ jch+jkl+jku.LE.iendch, il, c, s,
828 $ a( irow-iskew*jch+ioffst, jch ),
829 $ ilda, temp, extra )
848 IF( ipack.GE.5 )
THEN
854 CALL
dcopy( mnmin, d, 1, a( 1-iskew+ioffg, 1 ), ilda+1 )
858 irow = max( 1, jc-k )
859 il = min( jc+1, k+2 )
861 temp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
862 angle = twopi*
dlarnd( 1, iseed )
865 CALL
dlarot( .false., jc.GT.k, .true., il, c, s,
866 $ a( irow-iskew*jc+ioffg, jc ), ilda,
868 CALL
dlarot( .true., .true., .false.,
869 $ min( k, n-jc )+1, c, s,
870 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
876 DO 240 jch = jc - k, 1, -k
877 CALL
dlartg( a( jch+1-iskew*( icol+1 )+ioffg,
878 $ icol+1 ), extra, c, s, dummy )
879 temp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
880 CALL
dlarot( .true., .true., .true., k+2, c, -s,
881 $ a( ( 1-iskew )*jch+ioffg, jch ),
882 $ ilda, temp, extra )
883 irow = max( 1, jch-k )
884 il = min( jch+1, k+2 )
886 CALL
dlarot( .false., jch.GT.k, .true., il, c,
887 $ -s, a( irow-iskew*jch+ioffg, jch ),
888 $ ilda, extra, temp )
897 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
899 irow = ioffst - iskew*jc
900 DO 270 jr = jc, min( n, jc+uub )
901 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
904 IF( ipack.EQ.5 )
THEN
905 DO 300 jc = n - uub + 1, n
906 DO 290 jr = n + 2 - jc, uub + 1
911 IF( ipackg.EQ.6 )
THEN
921 IF( ipack.GE.5 )
THEN
928 CALL
dcopy( mnmin, d, 1, a( 1-iskew+ioffg, 1 ), ilda+1 )
931 DO 320 jc = n - 1, 1, -1
932 il = min( n+1-jc, k+2 )
934 temp = a( 1+( 1-iskew )*jc+ioffg, jc )
935 angle = twopi*
dlarnd( 1, iseed )
938 CALL
dlarot( .false., .true., n-jc.GT.k, il, c, s,
939 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
941 icol = max( 1, jc-k+1 )
942 CALL
dlarot( .true., .false., .true., jc+2-icol, c,
943 $ s, a( jc-iskew*icol+ioffg, icol ),
944 $ ilda, dummy, temp )
949 DO 310 jch = jc + k, n - 1, k
950 CALL
dlartg( a( jch-iskew*icol+ioffg, icol ),
951 $ extra, c, s, dummy )
952 temp = a( 1+( 1-iskew )*jch+ioffg, jch )
953 CALL
dlarot( .true., .true., .true., k+2, c, s,
954 $ a( jch-iskew*icol+ioffg, icol ),
955 $ ilda, extra, temp )
956 il = min( n+1-jch, k+2 )
958 CALL
dlarot( .false., .true., n-jch.GT.k, il, c,
959 $ s, a( ( 1-iskew )*jch+ioffg, jch ),
960 $ ilda, temp, extra )
969 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
971 irow = ioffst - iskew*jc
972 DO 340 jr = jc, max( 1, jc-uub ), -1
973 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
976 IF( ipack.EQ.6 )
THEN
978 DO 360 jr = 1, uub + 1 - jc
983 IF( ipackg.EQ.5 )
THEN
1001 IF( isym.EQ.1 )
THEN
1005 CALL
dlagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1011 CALL
dlagsy( m, llb, d, a, lda, iseed, work, iinfo )
1014 IF( iinfo.NE.0 )
THEN
1022 IF( ipack.NE.ipackg )
THEN
1023 IF( ipack.EQ.1 )
THEN
1033 ELSE IF( ipack.EQ.2 )
THEN
1043 ELSE IF( ipack.EQ.3 )
THEN
1052 IF( irow.GT.lda )
THEN
1056 a( irow, icol ) = a( i, j )
1060 ELSE IF( ipack.EQ.4 )
THEN
1069 IF( irow.GT.lda )
THEN
1073 a( irow, icol ) = a( i, j )
1077 ELSE IF( ipack.GE.5 )
THEN
1089 DO 460 i = min( j+llb, m ), 1, -1
1090 a( i-j+uub+1, j ) = a( i, j )
1094 DO 490 j = uub + 2, n
1095 DO 480 i = j - uub, min( j+llb, m )
1096 a( i-j+uub+1, j ) = a( i, j )
1106 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1108 DO 500 jr = irow + 1, lda
1114 ELSE IF( ipack.GE.5 )
THEN
1125 DO 520 jr = 1, uub + 1 - jc
1128 DO 530 jr = max( 1, min( ir1, ir2-jc ) ), lda