340 SUBROUTINE clatmt( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
341 $ rank, kl, ku, pack, a, lda, work, info )
350 INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK
351 CHARACTER DIST, PACK, SYM
354 COMPLEX A( lda, * ), WORK( * )
363 parameter ( zero = 0.0e+0 )
365 parameter ( one = 1.0e+0 )
367 parameter ( czero = ( 0.0e+0, 0.0e+0 ) )
369 parameter ( twopi = 6.2831853071795864769252867663e+0 )
372 COMPLEX C, CT, CTEMP, DUMMY, EXTRA, S, ST
373 REAL ALPHA, ANGLE, REALC, TEMP
374 INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
375 $ ioffg, ioffst, ipack, ipackg, ir, ir1, ir2,
376 $ irow, irsign, iskew, isym, isympk, j, jc, jch,
377 $ jkl, jku, jr, k, llb, minlda, mnmin, mr, nc,
379 LOGICAL CSYM, GIVENS, ILEXTR, ILTEMP, TOPDWN
385 EXTERNAL clarnd, slarnd, lsame
392 INTRINSIC abs, cmplx, conjg, cos, max, min, mod,
REAL,
404 IF( m.EQ.0 .OR. n.EQ.0 )
409 IF( lsame( dist,
'U' ) )
THEN
411 ELSE IF( lsame( dist,
'S' ) )
THEN
413 ELSE IF( lsame( dist,
'N' ) )
THEN
421 IF( lsame( sym,
'N' ) )
THEN
425 ELSE IF( lsame( sym,
'P' ) )
THEN
429 ELSE IF( lsame( sym,
'S' ) )
THEN
433 ELSE IF( lsame( sym,
'H' ) )
THEN
444 IF( lsame( pack,
'N' ) )
THEN
446 ELSE IF( lsame( pack,
'U' ) )
THEN
449 ELSE IF( lsame( pack,
'L' ) )
THEN
452 ELSE IF( lsame( pack,
'C' ) )
THEN
455 ELSE IF( lsame( pack,
'R' ) )
THEN
458 ELSE IF( lsame( pack,
'B' ) )
THEN
461 ELSE IF( lsame( pack,
'Q' ) )
THEN
464 ELSE IF( lsame( pack,
'Z' ) )
THEN
478 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
480 ELSE IF( ipack.EQ.7 )
THEN
481 minlda = llb + uub + 1
491 IF(
REAL( llb+uub ).LT.0.3*
REAL( MAX( 1, MR+NC ) ) )
497 IF( lda.LT.m .AND. lda.GE.minlda )
504 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
506 ELSE IF( n.LT.0 )
THEN
508 ELSE IF( idist.EQ.-1 )
THEN
510 ELSE IF( isym.EQ.-1 )
THEN
512 ELSE IF( abs( mode ).GT.6 )
THEN
514 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
517 ELSE IF( kl.LT.0 )
THEN
519 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
521 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
522 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
523 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
524 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
526 ELSE IF( lda.LT.max( 1, minlda ) )
THEN
531 CALL xerbla(
'CLATMT', -info )
538 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
541 IF( mod( iseed( 4 ), 2 ).NE.1 )
542 $ iseed( 4 ) = iseed( 4 ) + 1
548 CALL slatm7( mode, cond, irsign, idist, iseed, d, mnmin, rank,
550 IF( iinfo.NE.0 )
THEN
558 IF( abs( d( 1 ) ).LE.abs( d( rank ) ) )
THEN
564 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
570 temp = max( temp, abs( d( i ) ) )
573 IF( temp.GT.zero )
THEN
580 CALL sscal( rank, alpha, d, 1 )
584 CALL claset(
'Full', lda, n, czero, czero, a, lda )
595 IF( ipack.GT.4 )
THEN
598 IF( ipack.GT.5 )
THEN
618 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
620 a( ( 1-iskew )*j+ioffst, j ) = cmplx( d( j ) )
623 IF( ipack.LE.2 .OR. ipack.GE.5 )
626 ELSE IF( givens )
THEN
635 IF( ipack.GT.4 )
THEN
642 a( ( 1-iskew )*j+ioffst, j ) = cmplx( d( j ) )
654 DO 150 jr = 1, min( m+jku, n ) + jkl - 1
656 angle = twopi*slarnd( 1, iseed )
657 c = cos( angle )*clarnd( 5, iseed )
658 s = sin( angle )*clarnd( 5, iseed )
659 icol = max( 1, jr-jkl )
661 il = min( n, jr+jku ) + 1 - icol
662 CALL clarot( .true., jr.GT.jkl, .false., il, c,
663 $ s, a( jr-iskew*icol+ioffst, icol ),
664 $ ilda, extra, dummy )
671 DO 140 jch = jr - jkl, 1, -jkl - jku
673 CALL clartg( a( ir+1-iskew*( ic+1 )+ioffst,
674 $ ic+1 ), extra, realc, s, dummy )
675 dummy = clarnd( 5, iseed )
676 c = conjg( realc*dummy )
677 s = conjg( -s*dummy )
679 irow = max( 1, jch-jku )
683 CALL clarot( .false., iltemp, .true., il, c, s,
684 $ a( irow-iskew*ic+ioffst, ic ),
685 $ ilda, ctemp, extra )
687 CALL clartg( a( irow+1-iskew*( ic+1 )+ioffst,
688 $ ic+1 ), ctemp, realc, s, dummy )
689 dummy = clarnd( 5, iseed )
690 c = conjg( realc*dummy )
691 s = conjg( -s*dummy )
693 icol = max( 1, jch-jku-jkl )
696 CALL clarot( .true., jch.GT.jku+jkl, .true.,
697 $ il, c, s, a( irow-iskew*icol+
698 $ ioffst, icol ), ilda, extra,
712 DO 180 jc = 1, min( n+jkl, m ) + jku - 1
714 angle = twopi*slarnd( 1, iseed )
715 c = cos( angle )*clarnd( 5, iseed )
716 s = sin( angle )*clarnd( 5, iseed )
717 irow = max( 1, jc-jku )
719 il = min( m, jc+jkl ) + 1 - irow
720 CALL clarot( .false., jc.GT.jku, .false., il, c,
721 $ s, a( irow-iskew*jc+ioffst, jc ),
722 $ ilda, extra, dummy )
729 DO 170 jch = jc - jku, 1, -jkl - jku
731 CALL clartg( a( ir+1-iskew*( ic+1 )+ioffst,
732 $ ic+1 ), extra, realc, s, dummy )
733 dummy = clarnd( 5, iseed )
734 c = conjg( realc*dummy )
735 s = conjg( -s*dummy )
737 icol = max( 1, jch-jkl )
741 CALL clarot( .true., iltemp, .true., il, c, s,
742 $ a( ir-iskew*icol+ioffst, icol ),
743 $ ilda, ctemp, extra )
745 CALL clartg( a( ir+1-iskew*( icol+1 )+ioffst,
746 $ icol+1 ), ctemp, realc, s,
748 dummy = clarnd( 5, iseed )
749 c = conjg( realc*dummy )
750 s = conjg( -s*dummy )
751 irow = max( 1, jch-jkl-jku )
754 CALL clarot( .false., jch.GT.jkl+jku, .true.,
755 $ il, c, s, a( irow-iskew*icol+
756 $ ioffst, icol ), ilda, extra,
777 iendch = min( m, n+jkl ) - 1
778 DO 210 jc = min( m+jku, n ) - 1, 1 - jkl, -1
780 angle = twopi*slarnd( 1, iseed )
781 c = cos( angle )*clarnd( 5, iseed )
782 s = sin( angle )*clarnd( 5, iseed )
783 irow = max( 1, jc-jku+1 )
785 il = min( m, jc+jkl+1 ) + 1 - irow
786 CALL clarot( .false., .false., jc+jkl.LT.m, il,
787 $ c, s, a( irow-iskew*jc+ioffst,
788 $ jc ), ilda, dummy, extra )
794 DO 200 jch = jc + jkl, iendch, jkl + jku
797 CALL clartg( a( jch-iskew*ic+ioffst, ic ),
798 $ extra, realc, s, dummy )
799 dummy = clarnd( 5, iseed )
804 icol = min( n-1, jch+jku )
805 iltemp = jch + jku.LT.n
807 CALL clarot( .true., ilextr, iltemp, icol+2-ic,
808 $ c, s, a( jch-iskew*ic+ioffst, ic ),
809 $ ilda, extra, ctemp )
811 CALL clartg( a( jch-iskew*icol+ioffst,
812 $ icol ), ctemp, realc, s, dummy )
813 dummy = clarnd( 5, iseed )
816 il = min( iendch, jch+jkl+jku ) + 2 - jch
818 CALL clarot( .false., .true.,
819 $ jch+jkl+jku.LE.iendch, il, c, s,
820 $ a( jch-iskew*icol+ioffst,
821 $ icol ), ilda, ctemp, extra )
836 iendch = min( n, m+jku ) - 1
837 DO 240 jr = min( n+jkl, m ) - 1, 1 - jku, -1
839 angle = twopi*slarnd( 1, iseed )
840 c = cos( angle )*clarnd( 5, iseed )
841 s = sin( angle )*clarnd( 5, iseed )
842 icol = max( 1, jr-jkl+1 )
844 il = min( n, jr+jku+1 ) + 1 - icol
845 CALL clarot( .true., .false., jr+jku.LT.n, il,
846 $ c, s, a( jr-iskew*icol+ioffst,
847 $ icol ), ilda, dummy, extra )
853 DO 230 jch = jr + jku, iendch, jkl + jku
856 CALL clartg( a( ir-iskew*jch+ioffst, jch ),
857 $ extra, realc, s, dummy )
858 dummy = clarnd( 5, iseed )
863 irow = min( m-1, jch+jkl )
864 iltemp = jch + jkl.LT.m
866 CALL clarot( .false., ilextr, iltemp, irow+2-ir,
867 $ c, s, a( ir-iskew*jch+ioffst,
868 $ jch ), ilda, extra, ctemp )
870 CALL clartg( a( irow-iskew*jch+ioffst, jch ),
871 $ ctemp, realc, s, dummy )
872 dummy = clarnd( 5, iseed )
875 il = min( iendch, jch+jkl+jku ) + 2 - jch
877 CALL clarot( .true., .true.,
878 $ jch+jkl+jku.LE.iendch, il, c, s,
879 $ a( irow-iskew*jch+ioffst, jch ),
880 $ ilda, ctemp, extra )
901 IF( ipack.GE.5 )
THEN
909 a( ( 1-iskew )*j+ioffg, j ) = cmplx( d( j ) )
914 irow = max( 1, jc-k )
915 il = min( jc+1, k+2 )
917 ctemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
918 angle = twopi*slarnd( 1, iseed )
919 c = cos( angle )*clarnd( 5, iseed )
920 s = sin( angle )*clarnd( 5, iseed )
925 ctemp = conjg( ctemp )
929 CALL clarot( .false., jc.GT.k, .true., il, c, s,
930 $ a( irow-iskew*jc+ioffg, jc ), ilda,
932 CALL clarot( .true., .true., .false.,
933 $ min( k, n-jc )+1, ct, st,
934 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
940 DO 270 jch = jc - k, 1, -k
941 CALL clartg( a( jch+1-iskew*( icol+1 )+ioffg,
942 $ icol+1 ), extra, realc, s, dummy )
943 dummy = clarnd( 5, iseed )
944 c = conjg( realc*dummy )
945 s = conjg( -s*dummy )
946 ctemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
951 ctemp = conjg( ctemp )
955 CALL clarot( .true., .true., .true., k+2, c, s,
956 $ a( ( 1-iskew )*jch+ioffg, jch ),
957 $ ilda, ctemp, extra )
958 irow = max( 1, jch-k )
959 il = min( jch+1, k+2 )
961 CALL clarot( .false., jch.GT.k, .true., il, ct,
962 $ st, a( irow-iskew*jch+ioffg, jch ),
963 $ ilda, extra, ctemp )
972 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
974 irow = ioffst - iskew*jc
976 DO 300 jr = jc, min( n, jc+uub )
977 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
980 DO 310 jr = jc, min( n, jc+uub )
981 a( jr+irow, jc ) = conjg( a( jc-iskew*jr+
986 IF( ipack.EQ.5 )
THEN
987 DO 340 jc = n - uub + 1, n
988 DO 330 jr = n + 2 - jc, uub + 1
993 IF( ipackg.EQ.6 )
THEN
1003 IF( ipack.GE.5 )
THEN
1012 a( ( 1-iskew )*j+ioffg, j ) = cmplx( d( j ) )
1016 DO 370 jc = n - 1, 1, -1
1017 il = min( n+1-jc, k+2 )
1019 ctemp = a( 1+( 1-iskew )*jc+ioffg, jc )
1020 angle = twopi*slarnd( 1, iseed )
1021 c = cos( angle )*clarnd( 5, iseed )
1022 s = sin( angle )*clarnd( 5, iseed )
1027 ctemp = conjg( ctemp )
1031 CALL clarot( .false., .true., n-jc.GT.k, il, c, s,
1032 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
1034 icol = max( 1, jc-k+1 )
1035 CALL clarot( .true., .false., .true., jc+2-icol,
1036 $ ct, st, a( jc-iskew*icol+ioffg,
1037 $ icol ), ilda, dummy, ctemp )
1042 DO 360 jch = jc + k, n - 1, k
1043 CALL clartg( a( jch-iskew*icol+ioffg, icol ),
1044 $ extra, realc, s, dummy )
1045 dummy = clarnd( 5, iseed )
1048 ctemp = a( 1+( 1-iskew )*jch+ioffg, jch )
1053 ctemp = conjg( ctemp )
1057 CALL clarot( .true., .true., .true., k+2, c, s,
1058 $ a( jch-iskew*icol+ioffg, icol ),
1059 $ ilda, extra, ctemp )
1060 il = min( n+1-jch, k+2 )
1062 CALL clarot( .false., .true., n-jch.GT.k, il,
1063 $ ct, st, a( ( 1-iskew )*jch+ioffg,
1064 $ jch ), ilda, ctemp, extra )
1073 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
1074 DO 410 jc = n, 1, -1
1075 irow = ioffst - iskew*jc
1077 DO 390 jr = jc, max( 1, jc-uub ), -1
1078 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
1081 DO 400 jr = jc, max( 1, jc-uub ), -1
1082 a( jr+irow, jc ) = conjg( a( jc-iskew*jr+
1087 IF( ipack.EQ.6 )
THEN
1089 DO 420 jr = 1, uub + 1 - jc
1094 IF( ipackg.EQ.5 )
THEN
1104 IF( .NOT.csym )
THEN
1106 irow = ioffst + ( 1-iskew )*jc
1107 a( irow, jc ) = cmplx(
REAL( A( IROW, JC ) ) )
1122 IF( isym.EQ.1 )
THEN
1126 CALL clagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1134 CALL clagsy( m, llb, d, a, lda, iseed, work, iinfo )
1136 CALL claghe( m, llb, d, a, lda, iseed, work, iinfo )
1140 IF( iinfo.NE.0 )
THEN
1148 IF( ipack.NE.ipackg )
THEN
1149 IF( ipack.EQ.1 )
THEN
1159 ELSE IF( ipack.EQ.2 )
THEN
1169 ELSE IF( ipack.EQ.3 )
THEN
1178 IF( irow.GT.lda )
THEN
1182 a( irow, icol ) = a( i, j )
1186 ELSE IF( ipack.EQ.4 )
THEN
1195 IF( irow.GT.lda )
THEN
1199 a( irow, icol ) = a( i, j )
1203 ELSE IF( ipack.GE.5 )
THEN
1215 DO 530 i = min( j+llb, m ), 1, -1
1216 a( i-j+uub+1, j ) = a( i, j )
1220 DO 560 j = uub + 2, n
1221 DO 550 i = j - uub, min( j+llb, m )
1222 a( i-j+uub+1, j ) = a( i, j )
1232 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1234 DO 570 jr = irow + 1, lda
1240 ELSE IF( ipack.GE.5 )
THEN
1251 DO 590 jr = 1, uub + 1 - jc
1254 DO 600 jr = max( 1, min( ir1, ir2-jc ) ), lda
subroutine clartg(F, G, CS, SN, R)
CLARTG generates a plane rotation with real cosine and complex sine.
subroutine clatmt(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, RANK, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMT
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine clarot(LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, XRIGHT)
CLAROT
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine slatm7(MODE, COND, IRSIGN, IDIST, ISEED, D, N, RANK, INFO)
SLATM7
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine clagge(M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO)
CLAGGE
subroutine claghe(N, K, D, A, LDA, ISEED, WORK, INFO)
CLAGHE
subroutine clagsy(N, K, D, A, LDA, ISEED, WORK, INFO)
CLAGSY