332 SUBROUTINE zlatms( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
333 $ kl, ku, pack, a, lda, work, info )
341 CHARACTER DIST, PACK, SYM
342 INTEGER INFO, KL, KU, LDA, M, MODE, N
343 DOUBLE PRECISION COND, DMAX
347 DOUBLE PRECISION D( * )
348 COMPLEX*16 A( lda, * ), WORK( * )
354 DOUBLE PRECISION ZERO
355 parameter ( zero = 0.0d+0 )
357 parameter ( one = 1.0d+0 )
359 parameter ( czero = ( 0.0d+0, 0.0d+0 ) )
360 DOUBLE PRECISION TWOPI
361 parameter ( twopi = 6.2831853071795864769252867663d+0 )
364 LOGICAL GIVENS, ILEXTR, ILTEMP, TOPDWN, ZSYM
365 INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
366 $ ioffg, ioffst, ipack, ipackg, ir, ir1, ir2,
367 $ irow, irsign, iskew, isym, isympk, j, jc, jch,
368 $ jkl, jku, jr, k, llb, minlda, mnmin, mr, nc,
370 DOUBLE PRECISION ALPHA, ANGLE, REALC, TEMP
371 COMPLEX*16 C, CT, CTEMP, DUMMY, EXTRA, S, ST
375 DOUBLE PRECISION DLARND
377 EXTERNAL lsame, dlarnd, zlarnd
384 INTRINSIC abs, cos, dble, dcmplx, dconjg, max, min, mod,
396 IF( m.EQ.0 .OR. n.EQ.0 )
401 IF( lsame( dist,
'U' ) )
THEN
403 ELSE IF( lsame( dist,
'S' ) )
THEN
405 ELSE IF( lsame( dist,
'N' ) )
THEN
413 IF( lsame( sym,
'N' ) )
THEN
417 ELSE IF( lsame( sym,
'P' ) )
THEN
421 ELSE IF( lsame( sym,
'S' ) )
THEN
425 ELSE IF( lsame( sym,
'H' ) )
THEN
436 IF( lsame( pack,
'N' ) )
THEN
438 ELSE IF( lsame( pack,
'U' ) )
THEN
441 ELSE IF( lsame( pack,
'L' ) )
THEN
444 ELSE IF( lsame( pack,
'C' ) )
THEN
447 ELSE IF( lsame( pack,
'R' ) )
THEN
450 ELSE IF( lsame( pack,
'B' ) )
THEN
453 ELSE IF( lsame( pack,
'Q' ) )
THEN
456 ELSE IF( lsame( pack,
'Z' ) )
THEN
470 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
472 ELSE IF( ipack.EQ.7 )
THEN
473 minlda = llb + uub + 1
483 IF( dble( llb+uub ).LT.0.3d0*dble( max( 1, mr+nc ) ) )
489 IF( lda.LT.m .AND. lda.GE.minlda )
496 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
498 ELSE IF( n.LT.0 )
THEN
500 ELSE IF( idist.EQ.-1 )
THEN
502 ELSE IF( isym.EQ.-1 )
THEN
504 ELSE IF( abs( mode ).GT.6 )
THEN
506 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
509 ELSE IF( kl.LT.0 )
THEN
511 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
513 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
514 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
515 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
516 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
518 ELSE IF( lda.LT.max( 1, minlda ) )
THEN
523 CALL xerbla(
'ZLATMS', -info )
530 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
533 IF( mod( iseed( 4 ), 2 ).NE.1 )
534 $ iseed( 4 ) = iseed( 4 ) + 1
540 CALL dlatm1( mode, cond, irsign, idist, iseed, d, mnmin, iinfo )
541 IF( iinfo.NE.0 )
THEN
549 IF( abs( d( 1 ) ).LE.abs( d( mnmin ) ) )
THEN
555 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
561 temp = max( temp, abs( d( i ) ) )
564 IF( temp.GT.zero )
THEN
571 CALL dscal( mnmin, alpha, d, 1 )
575 CALL zlaset(
'Full', lda, n, czero, czero, a, lda )
586 IF( ipack.GT.4 )
THEN
589 IF( ipack.GT.5 )
THEN
609 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
611 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
614 IF( ipack.LE.2 .OR. ipack.GE.5 )
617 ELSE IF( givens )
THEN
626 IF( ipack.GT.4 )
THEN
633 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
645 DO 60 jr = 1, min( m+jku, n ) + jkl - 1
647 angle = twopi*dlarnd( 1, iseed )
648 c = cos( angle )*zlarnd( 5, iseed )
649 s = sin( angle )*zlarnd( 5, iseed )
650 icol = max( 1, jr-jkl )
652 il = min( n, jr+jku ) + 1 - icol
653 CALL zlarot( .true., jr.GT.jkl, .false., il, c,
654 $ s, a( jr-iskew*icol+ioffst, icol ),
655 $ ilda, extra, dummy )
662 DO 50 jch = jr - jkl, 1, -jkl - jku
664 CALL zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
665 $ ic+1 ), extra, realc, s, dummy )
666 dummy = zlarnd( 5, iseed )
667 c = dconjg( realc*dummy )
668 s = dconjg( -s*dummy )
670 irow = max( 1, jch-jku )
674 CALL zlarot( .false., iltemp, .true., il, c, s,
675 $ a( irow-iskew*ic+ioffst, ic ),
676 $ ilda, ctemp, extra )
678 CALL zlartg( a( irow+1-iskew*( ic+1 )+ioffst,
679 $ ic+1 ), ctemp, realc, s, dummy )
680 dummy = zlarnd( 5, iseed )
681 c = dconjg( realc*dummy )
682 s = dconjg( -s*dummy )
684 icol = max( 1, jch-jku-jkl )
687 CALL zlarot( .true., jch.GT.jku+jkl, .true.,
688 $ il, c, s, a( irow-iskew*icol+
689 $ ioffst, icol ), ilda, extra,
703 DO 90 jc = 1, min( n+jkl, m ) + jku - 1
705 angle = twopi*dlarnd( 1, iseed )
706 c = cos( angle )*zlarnd( 5, iseed )
707 s = sin( angle )*zlarnd( 5, iseed )
708 irow = max( 1, jc-jku )
710 il = min( m, jc+jkl ) + 1 - irow
711 CALL zlarot( .false., jc.GT.jku, .false., il, c,
712 $ s, a( irow-iskew*jc+ioffst, jc ),
713 $ ilda, extra, dummy )
720 DO 80 jch = jc - jku, 1, -jkl - jku
722 CALL zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
723 $ ic+1 ), extra, realc, s, dummy )
724 dummy = zlarnd( 5, iseed )
725 c = dconjg( realc*dummy )
726 s = dconjg( -s*dummy )
728 icol = max( 1, jch-jkl )
732 CALL zlarot( .true., iltemp, .true., il, c, s,
733 $ a( ir-iskew*icol+ioffst, icol ),
734 $ ilda, ctemp, extra )
736 CALL zlartg( a( ir+1-iskew*( icol+1 )+ioffst,
737 $ icol+1 ), ctemp, realc, s,
739 dummy = zlarnd( 5, iseed )
740 c = dconjg( realc*dummy )
741 s = dconjg( -s*dummy )
742 irow = max( 1, jch-jkl-jku )
745 CALL zlarot( .false., jch.GT.jkl+jku, .true.,
746 $ il, c, s, a( irow-iskew*icol+
747 $ ioffst, icol ), ilda, extra,
768 iendch = min( m, n+jkl ) - 1
769 DO 120 jc = min( m+jku, n ) - 1, 1 - jkl, -1
771 angle = twopi*dlarnd( 1, iseed )
772 c = cos( angle )*zlarnd( 5, iseed )
773 s = sin( angle )*zlarnd( 5, iseed )
774 irow = max( 1, jc-jku+1 )
776 il = min( m, jc+jkl+1 ) + 1 - irow
777 CALL zlarot( .false., .false., jc+jkl.LT.m, il,
778 $ c, s, a( irow-iskew*jc+ioffst,
779 $ jc ), ilda, dummy, extra )
785 DO 110 jch = jc + jkl, iendch, jkl + jku
788 CALL zlartg( a( jch-iskew*ic+ioffst, ic ),
789 $ extra, realc, s, dummy )
790 dummy = zlarnd( 5, iseed )
795 icol = min( n-1, jch+jku )
796 iltemp = jch + jku.LT.n
798 CALL zlarot( .true., ilextr, iltemp, icol+2-ic,
799 $ c, s, a( jch-iskew*ic+ioffst, ic ),
800 $ ilda, extra, ctemp )
802 CALL zlartg( a( jch-iskew*icol+ioffst,
803 $ icol ), ctemp, realc, s, dummy )
804 dummy = zlarnd( 5, iseed )
807 il = min( iendch, jch+jkl+jku ) + 2 - jch
809 CALL zlarot( .false., .true.,
810 $ jch+jkl+jku.LE.iendch, il, c, s,
811 $ a( jch-iskew*icol+ioffst,
812 $ icol ), ilda, ctemp, extra )
827 iendch = min( n, m+jku ) - 1
828 DO 150 jr = min( n+jkl, m ) - 1, 1 - jku, -1
830 angle = twopi*dlarnd( 1, iseed )
831 c = cos( angle )*zlarnd( 5, iseed )
832 s = sin( angle )*zlarnd( 5, iseed )
833 icol = max( 1, jr-jkl+1 )
835 il = min( n, jr+jku+1 ) + 1 - icol
836 CALL zlarot( .true., .false., jr+jku.LT.n, il,
837 $ c, s, a( jr-iskew*icol+ioffst,
838 $ icol ), ilda, dummy, extra )
844 DO 140 jch = jr + jku, iendch, jkl + jku
847 CALL zlartg( a( ir-iskew*jch+ioffst, jch ),
848 $ extra, realc, s, dummy )
849 dummy = zlarnd( 5, iseed )
854 irow = min( m-1, jch+jkl )
855 iltemp = jch + jkl.LT.m
857 CALL zlarot( .false., ilextr, iltemp, irow+2-ir,
858 $ c, s, a( ir-iskew*jch+ioffst,
859 $ jch ), ilda, extra, ctemp )
861 CALL zlartg( a( irow-iskew*jch+ioffst, jch ),
862 $ ctemp, realc, s, dummy )
863 dummy = zlarnd( 5, iseed )
866 il = min( iendch, jch+jkl+jku ) + 2 - jch
868 CALL zlarot( .true., .true.,
869 $ jch+jkl+jku.LE.iendch, il, c, s,
870 $ a( irow-iskew*jch+ioffst, jch ),
871 $ ilda, ctemp, extra )
892 IF( ipack.GE.5 )
THEN
900 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
905 irow = max( 1, jc-k )
906 il = min( jc+1, k+2 )
908 ctemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
909 angle = twopi*dlarnd( 1, iseed )
910 c = cos( angle )*zlarnd( 5, iseed )
911 s = sin( angle )*zlarnd( 5, iseed )
916 ctemp = dconjg( ctemp )
920 CALL zlarot( .false., jc.GT.k, .true., il, c, s,
921 $ a( irow-iskew*jc+ioffg, jc ), ilda,
923 CALL zlarot( .true., .true., .false.,
924 $ min( k, n-jc )+1, ct, st,
925 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
931 DO 180 jch = jc - k, 1, -k
932 CALL zlartg( a( jch+1-iskew*( icol+1 )+ioffg,
933 $ icol+1 ), extra, realc, s, dummy )
934 dummy = zlarnd( 5, iseed )
935 c = dconjg( realc*dummy )
936 s = dconjg( -s*dummy )
937 ctemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
942 ctemp = dconjg( ctemp )
946 CALL zlarot( .true., .true., .true., k+2, c, s,
947 $ a( ( 1-iskew )*jch+ioffg, jch ),
948 $ ilda, ctemp, extra )
949 irow = max( 1, jch-k )
950 il = min( jch+1, k+2 )
952 CALL zlarot( .false., jch.GT.k, .true., il, ct,
953 $ st, a( irow-iskew*jch+ioffg, jch ),
954 $ ilda, extra, ctemp )
963 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
965 irow = ioffst - iskew*jc
967 DO 210 jr = jc, min( n, jc+uub )
968 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
971 DO 220 jr = jc, min( n, jc+uub )
972 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
977 IF( ipack.EQ.5 )
THEN
978 DO 250 jc = n - uub + 1, n
979 DO 240 jr = n + 2 - jc, uub + 1
984 IF( ipackg.EQ.6 )
THEN
994 IF( ipack.GE.5 )
THEN
1003 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
1007 DO 280 jc = n - 1, 1, -1
1008 il = min( n+1-jc, k+2 )
1010 ctemp = a( 1+( 1-iskew )*jc+ioffg, jc )
1011 angle = twopi*dlarnd( 1, iseed )
1012 c = cos( angle )*zlarnd( 5, iseed )
1013 s = sin( angle )*zlarnd( 5, iseed )
1018 ctemp = dconjg( ctemp )
1022 CALL zlarot( .false., .true., n-jc.GT.k, il, c, s,
1023 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
1025 icol = max( 1, jc-k+1 )
1026 CALL zlarot( .true., .false., .true., jc+2-icol,
1027 $ ct, st, a( jc-iskew*icol+ioffg,
1028 $ icol ), ilda, dummy, ctemp )
1033 DO 270 jch = jc + k, n - 1, k
1034 CALL zlartg( a( jch-iskew*icol+ioffg, icol ),
1035 $ extra, realc, s, dummy )
1036 dummy = zlarnd( 5, iseed )
1039 ctemp = a( 1+( 1-iskew )*jch+ioffg, jch )
1044 ctemp = dconjg( ctemp )
1048 CALL zlarot( .true., .true., .true., k+2, c, s,
1049 $ a( jch-iskew*icol+ioffg, icol ),
1050 $ ilda, extra, ctemp )
1051 il = min( n+1-jch, k+2 )
1053 CALL zlarot( .false., .true., n-jch.GT.k, il,
1054 $ ct, st, a( ( 1-iskew )*jch+ioffg,
1055 $ jch ), ilda, ctemp, extra )
1064 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
1065 DO 320 jc = n, 1, -1
1066 irow = ioffst - iskew*jc
1068 DO 300 jr = jc, max( 1, jc-uub ), -1
1069 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
1072 DO 310 jr = jc, max( 1, jc-uub ), -1
1073 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
1078 IF( ipack.EQ.6 )
THEN
1080 DO 330 jr = 1, uub + 1 - jc
1085 IF( ipackg.EQ.5 )
THEN
1095 IF( .NOT.zsym )
THEN
1097 irow = ioffst + ( 1-iskew )*jc
1098 a( irow, jc ) = dcmplx( dble( a( irow, jc ) ) )
1113 IF( isym.EQ.1 )
THEN
1117 CALL zlagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1125 CALL zlagsy( m, llb, d, a, lda, iseed, work, iinfo )
1127 CALL zlaghe( m, llb, d, a, lda, iseed, work, iinfo )
1131 IF( iinfo.NE.0 )
THEN
1139 IF( ipack.NE.ipackg )
THEN
1140 IF( ipack.EQ.1 )
THEN
1150 ELSE IF( ipack.EQ.2 )
THEN
1160 ELSE IF( ipack.EQ.3 )
THEN
1169 IF( irow.GT.lda )
THEN
1173 a( irow, icol ) = a( i, j )
1177 ELSE IF( ipack.EQ.4 )
THEN
1186 IF( irow.GT.lda )
THEN
1190 a( irow, icol ) = a( i, j )
1194 ELSE IF( ipack.GE.5 )
THEN
1206 DO 440 i = min( j+llb, m ), 1, -1
1207 a( i-j+uub+1, j ) = a( i, j )
1211 DO 470 j = uub + 2, n
1212 DO 460 i = j - uub, min( j+llb, m )
1213 a( i-j+uub+1, j ) = a( i, j )
1223 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1225 DO 480 jr = irow + 1, lda
1231 ELSE IF( ipack.GE.5 )
THEN
1242 DO 500 jr = 1, uub + 1 - jc
1245 DO 510 jr = max( 1, min( ir1, ir2-jc ) ), lda
subroutine dlatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
DLATM1
subroutine zlaghe(N, K, D, A, LDA, ISEED, WORK, INFO)
ZLAGHE
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine zlagsy(N, K, D, A, LDA, ISEED, WORK, INFO)
ZLAGSY
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dscal(N, DA, DX, INCX)
DSCAL
subroutine zlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
ZLATMS
subroutine zlagge(M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO)
ZLAGGE
subroutine zlarot(LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, XRIGHT)
ZLAROT
subroutine zlartg(F, G, CS, SN, R)
ZLARTG generates a plane rotation with real cosine and complex sine.