1 SUBROUTINE clatms( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX,
2 $ KL, KU, PACK, A, LDA, WORK, INFO )
9 CHARACTER DIST, PACK, SYM
10 INTEGER INFO, KL, KU, LDA, M, MODE, N
16 COMPLEX A( LDA, * ), WORK( * )
265 parameter( zero = 0.0e+0 )
267 parameter( one = 1.0e+0 )
269 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
271 parameter( twopi = 6.2831853071795864769252867663e+0 )
274 LOGICAL CSYM, GIVENS, ILEXTR, ILTEMP, TOPDWN
275 INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
276 $ ioffg, ioffst, ipack, ipackg, ir, ir1, ir2,
277 $ irow, irsign, iskew, isym, isympk, j, jc, jch,
278 $ jkl, jku, jr, k, llb, minlda, mnmin, mr, nc,
280 REAL ALPHA, ANGLE, REALC, TEMP
281 COMPLEX C, CT, CTEMP, DUMMY, EXTRA, S, ST
287 EXTERNAL lsame, slarnd, clarnd
294 INTRINSIC abs,
cmplx, conjg, cos,
max,
min, mod, real,
306 IF( m.EQ.0 .OR. n.EQ.0 )
311 IF( lsame( dist,
'U' ) )
THEN
313 ELSE IF( lsame( dist,
'S' ) )
THEN
315 ELSE IF( lsame( dist,
'N' ) )
THEN
323 IF( lsame( sym,
'N' ) )
THEN
327 ELSE IF( lsame( sym,
'P' ) )
THEN
331 ELSE IF( lsame( sym,
'S' ) )
THEN
335 ELSE IF( lsame( sym,
'H' ) )
THEN
346 IF( lsame( pack,
'N' ) )
THEN
348 ELSE IF( lsame( pack,
'U' ) )
THEN
351 ELSE IF( lsame( pack,
'L' ) )
THEN
354 ELSE IF( lsame( pack,
'C' ) )
THEN
357 ELSE IF( lsame( pack,
'R' ) )
THEN
360 ELSE IF( lsame( pack,
'B' ) )
THEN
363 ELSE IF( lsame( pack,
'Q' ) )
THEN
366 ELSE IF( lsame( pack,
'Z' ) )
THEN
383 IF( ipack.EQ.5 .OR. ipack.EQ.6 )
THEN
385 ELSE IF( ipack.EQ.7 )
THEN
386 minlda = llb + uub + 1
396 IF( real( llb+uub ).LT.0.3*real(
max( 1, mr+nc ) ) )
402 IF( lda.LT.m .AND. lda.GE.minlda )
409 ELSE IF( m.NE.n .AND. isym.NE.1 )
THEN
411 ELSE IF( n.LT.0 )
THEN
413 ELSE IF( idist.EQ.-1 )
THEN
415 ELSE IF( isym.EQ.-1 )
THEN
417 ELSE IF( abs( mode ).GT.6 )
THEN
419 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
422 ELSE IF( kl.LT.0 )
THEN
424 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) )
THEN
426 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
427 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
428 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
429 $ ( isympk.NE.0 .AND. m.NE.n ) )
THEN
431 ELSE IF( lda.LT.
max( 1, minlda ) )
THEN
436 CALL xerbla(
'CLATMS', -info )
443 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
446 IF( mod( iseed( 4 ), 2 ).NE.1 )
447 $ iseed( 4 ) = iseed( 4 ) + 1
453 CALL slatm1( mode, cond, irsign, idist, iseed, d, mnmin, iinfo )
454 IF( iinfo.NE.0 )
THEN
462 IF( abs( d( 1 ) ).LE.abs( d( mnmin ) ) )
THEN
468 IF( mode.NE.0 .AND. abs( mode ).NE.6 )
THEN
474 temp =
max( temp, abs( d( i ) ) )
477 IF( temp.GT.zero )
THEN
484 CALL sscal( mnmin, alpha, d, 1 )
488 CALL claset(
'Full', lda, n, czero, czero, a, lda )
499 IF( ipack.GT.4 )
THEN
502 IF( ipack.GT.5 )
THEN
522 IF( llb.EQ.0 .AND. uub.EQ.0 )
THEN
524 a( ( 1-iskew )*j+ioffst, j ) =
cmplx( d( j ) )
527 IF( ipack.LE.2 .OR. ipack.GE.5 )
530 ELSE IF( givens )
THEN
539 IF( ipack.GT.4 )
THEN
546 a( ( 1-iskew )*j+ioffst, j ) =
cmplx( d( j ) )
558 DO 60 jr = 1,
min( m+jku, n ) + jkl - 1
560 angle = twopi*slarnd( 1, iseed )
561 c = cos( angle )*clarnd( 5, iseed )
562 s = sin( angle )*clarnd( 5, iseed )
563 icol =
max( 1, jr-jkl )
565 il =
min( n, jr+jku ) + 1 - icol
566 CALL clarot( .true., jr.GT.jkl, .false., il, c,
567 $ s, a( jr-iskew*icol+ioffst, icol ),
568 $ ilda, extra, dummy )
575 DO 50 jch = jr - jkl, 1, -jkl - jku
577 CALL clartg( a( ir+1-iskew*( ic+1 )+ioffst,
578 $ ic+1 ), extra, realc, s, dummy )
579 dummy = clarnd( 5, iseed )
580 c = conjg( realc*dummy )
581 s = conjg( -s*dummy )
583 irow =
max( 1, jch-jku )
587 CALL clarot( .false., iltemp, .true., il, c, s,
588 $ a( irow-iskew*ic+ioffst, ic ),
589 $ ilda, ctemp, extra )
591 CALL clartg( a( irow+1-iskew*( ic+1 )+ioffst,
592 $ ic+1 ), ctemp, realc, s, dummy )
593 dummy = clarnd( 5, iseed )
594 c = conjg( realc*dummy )
595 s = conjg( -s*dummy )
597 icol =
max( 1, jch-jku-jkl )
600 CALL clarot( .true., jch.GT.jku+jkl, .true.,
601 $ il, c, s, a( irow-iskew*icol+
602 $ ioffst, icol ), ilda, extra,
616 DO 90 jc = 1,
min( n+jkl, m ) + jku - 1
618 angle = twopi*slarnd( 1, iseed )
619 c = cos( angle )*clarnd( 5, iseed )
620 s = sin( angle )*clarnd( 5, iseed )
621 irow =
max( 1, jc-jku )
623 il =
min( m, jc+jkl ) + 1 - irow
624 CALL clarot( .false., jc.GT.jku, .false., il, c,
625 $ s, a( irow-iskew*jc+ioffst, jc ),
626 $ ilda, extra, dummy )
633 DO 80 jch = jc - jku, 1, -jkl - jku
635 CALL clartg( a( ir+1-iskew*( ic+1 )+ioffst,
636 $ ic+1 ), extra, realc, s, dummy )
637 dummy = clarnd( 5, iseed )
638 c = conjg( realc*dummy )
639 s = conjg( -s*dummy )
641 icol =
max( 1, jch-jkl )
645 CALL clarot( .true., iltemp, .true., il, c, s,
646 $ a( ir-iskew*icol+ioffst, icol ),
647 $ ilda, ctemp, extra )
649 CALL clartg( a( ir+1-iskew*( icol+1 )+ioffst,
650 $ icol+1 ), ctemp, realc, s,
652 dummy = clarnd( 5, iseed )
653 c = conjg( realc*dummy )
654 s = conjg( -s*dummy )
655 irow =
max( 1, jch-jkl-jku )
658 CALL clarot( .false., jch.GT.jkl+jku, .true.,
659 $ il, c, s, a( irow-iskew*icol+
660 $ ioffst, icol ), ilda, extra,
681 iendch =
min( m, n+jkl ) - 1
682 DO 120 jc =
min( m+jku, n ) - 1, 1 - jkl, -1
684 angle = twopi*slarnd( 1, iseed )
685 c = cos( angle )*clarnd( 5, iseed )
686 s = sin( angle )*clarnd( 5, iseed )
687 irow =
max( 1, jc-jku+1 )
689 il =
min( m, jc+jkl+1 ) + 1 - irow
690 CALL clarot( .false., .false., jc+jkl.LT.m, il,
691 $ c, s, a( irow-iskew*jc+ioffst,
692 $ jc ), ilda, dummy, extra )
698 DO 110 jch = jc + jkl, iendch, jkl + jku
701 CALL clartg( a( jch-iskew*ic+ioffst, ic ),
702 $ extra, realc, s, dummy )
703 dummy = clarnd( 5, iseed )
708 icol =
min( n-1, jch+jku )
709 iltemp = jch + jku.LT.n
711 CALL clarot( .true., ilextr, iltemp, icol+2-ic,
712 $ c, s, a( jch-iskew*ic+ioffst, ic ),
713 $ ilda, extra, ctemp )
715 CALL clartg( a( jch-iskew*icol+ioffst,
716 $ icol ), ctemp, realc, s, dummy )
717 dummy = clarnd( 5, iseed )
720 il =
min( iendch, jch+jkl+jku ) + 2 - jch
722 CALL clarot( .false., .true.,
723 $ jch+jkl+jku.LE.iendch, il, c, s,
724 $ a( jch-iskew*icol+ioffst,
725 $ icol ), ilda, ctemp, extra )
740 iendch =
min( n, m+jku ) - 1
741 DO 150 jr =
min( n+jkl, m ) - 1, 1 - jku, -1
743 angle = twopi*slarnd( 1, iseed )
744 c = cos( angle )*clarnd( 5, iseed )
745 s = sin( angle )*clarnd( 5, iseed )
746 icol =
max( 1, jr-jkl+1 )
748 il =
min( n, jr+jku+1 ) + 1 - icol
749 CALL clarot( .true., .false., jr+jku.LT.n, il,
750 $ c, s, a( jr-iskew*icol+ioffst,
751 $ icol ), ilda, dummy, extra )
757 DO 140 jch = jr + jku, iendch, jkl + jku
760 CALL clartg( a( ir-iskew*jch+ioffst, jch ),
761 $ extra, realc, s, dummy )
762 dummy = clarnd( 5, iseed )
767 irow =
min( m-1, jch+jkl )
768 iltemp = jch + jkl.LT.m
770 CALL clarot( .false., ilextr, iltemp, irow+2-ir,
771 $ c, s, a( ir-iskew*jch+ioffst,
772 $ jch ), ilda, extra, ctemp )
774 CALL clartg( a( irow-iskew*jch+ioffst, jch ),
775 $ ctemp, realc, s, dummy )
776 dummy = clarnd( 5, iseed )
779 il =
min( iendch, jch+jkl+jku ) + 2 - jch
781 CALL clarot( .true., .true.,
782 $ jch+jkl+jku.LE.iendch, il, c, s,
783 $ a( irow-iskew*jch+ioffst, jch ),
784 $ ilda, ctemp, extra )
805 IF( ipack.GE.5 )
THEN
813 a( ( 1-iskew )*j+ioffg, j ) =
cmplx( d( j ) )
818 irow =
max( 1, jc-k )
819 il =
min( jc+1, k+2 )
821 ctemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
822 angle = twopi*slarnd( 1, iseed )
823 c = cos( angle )*clarnd( 5, iseed )
824 s = sin( angle )*clarnd( 5, iseed )
829 ctemp = conjg( ctemp )
833 CALL clarot( .false., jc.GT.k, .true., il, c, s,
834 $ a( irow-iskew*jc+ioffg, jc ), ilda,
836 CALL clarot( .true., .true., .false.,
837 $
min( k, n-jc )+1, ct, st,
838 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
844 DO 180 jch = jc - k, 1, -k
845 CALL clartg( a( jch+1-iskew*( icol+1 )+ioffg,
846 $ icol+1 ), extra, realc, s, dummy )
847 dummy = clarnd( 5, iseed )
848 c = conjg( realc*dummy )
849 s = conjg( -s*dummy )
850 ctemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
855 ctemp = conjg( ctemp )
859 CALL clarot( .true., .true., .true., k+2, c, s,
860 $ a( ( 1-iskew )*jch+ioffg, jch ),
861 $ ilda, ctemp, extra )
862 irow =
max( 1, jch-k )
863 il =
min( jch+1, k+2 )
865 CALL clarot( .false., jch.GT.k, .true., il, ct,
866 $ st, a( irow-iskew*jch+ioffg, jch ),
867 $ ilda, extra, ctemp )
876 IF( ipack.NE.ipackg .AND. ipack.NE.3 )
THEN
878 irow = ioffst - iskew*jc
880 DO 210 jr = jc,
min( n, jc+uub )
881 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
884 DO 220 jr = jc,
min( n, jc+uub )
885 a( jr+irow, jc ) = conjg( a( jc-iskew*jr+
890 IF( ipack.EQ.5 )
THEN
891 DO 250 jc = n - uub + 1, n
892 DO 240 jr = n + 2 - jc, uub + 1
897 IF( ipackg.EQ.6 )
THEN
907 IF( ipack.GE.5 )
THEN
916 a( ( 1-iskew )*j+ioffg, j ) =
cmplx( d( j ) )
920 DO 280 jc = n - 1, 1, -1
921 il =
min( n+1-jc, k+2 )
923 ctemp = a( 1+( 1-iskew )*jc+ioffg, jc )
924 angle = twopi*slarnd( 1, iseed )
925 c = cos( angle )*clarnd( 5, iseed )
926 s = sin( angle )*clarnd( 5, iseed )
931 ctemp = conjg( ctemp )
935 CALL clarot( .false., .true., n-jc.GT.k, il, c, s,
936 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
938 icol =
max( 1, jc-k+1 )
939 CALL clarot( .true., .false., .true., jc+2-icol,
940 $ ct, st, a( jc-iskew*icol+ioffg,
941 $ icol ), ilda, dummy, ctemp )
946 DO 270 jch = jc + k, n - 1, k
947 CALL clartg( a( jch-iskew*icol+ioffg, icol ),
948 $ extra, realc, s, dummy )
949 dummy = clarnd( 5, iseed )
952 ctemp = a( 1+( 1-iskew )*jch+ioffg, jch )
957 ctemp = conjg( ctemp )
961 CALL clarot( .true., .true., .true., k+2, c, s,
962 $ a( jch-iskew*icol+ioffg, icol ),
963 $ ilda, extra, ctemp )
964 il =
min( n+1-jch, k+2 )
966 CALL clarot( .false., .true., n-jch.GT.k, il,
967 $ ct, st, a( ( 1-iskew )*jch+ioffg,
968 $ jch ), ilda, ctemp, extra )
977 IF( ipack.NE.ipackg .AND. ipack.NE.4 )
THEN
979 irow = ioffst - iskew*jc
981 DO 300 jr = jc,
max( 1, jc-uub ), -1
982 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
985 DO 310 jr = jc,
max( 1, jc-uub ), -1
986 a( jr+irow, jc ) = conjg( a( jc-iskew*jr+
991 IF( ipack.EQ.6 )
THEN
993 DO 330 jr = 1, uub + 1 - jc
998 IF( ipackg.EQ.5 )
THEN
1008 IF( .NOT.csym )
THEN
1010 irow = ioffst + ( 1-iskew )*jc
1011 a( irow, jc ) =
cmplx( real( a( irow, jc ) ) )
1026 IF( isym.EQ.1 )
THEN
1030 CALL clagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1038 CALL clagsy( m, llb, d, a, lda, iseed, work, iinfo )
1040 CALL claghe( m, llb, d, a, lda, iseed, work, iinfo )
1044 IF( iinfo.NE.0 )
THEN
1052 IF( ipack.NE.ipackg )
THEN
1053 IF( ipack.EQ.1 )
THEN
1063 ELSE IF( ipack.EQ.2 )
THEN
1073 ELSE IF( ipack.EQ.3 )
THEN
1082 IF( irow.GT.lda )
THEN
1086 a( irow, icol ) = a( i, j )
1090 ELSE IF( ipack.EQ.4 )
THEN
1099 IF( irow.GT.lda )
THEN
1103 a( irow, icol ) = a( i, j )
1107 ELSE IF( ipack.GE.5 )
THEN
1119 DO 440 i =
min( j+llb, m ), 1, -1
1120 a( i-j+uub+1, j ) = a( i, j )
1124 DO 470 j = uub + 2, n
1125 DO 460 i = j - uub,
min( j+llb, m )
1126 a( i-j+uub+1, j ) = a( i, j )
1136 IF( ipack.EQ.3 .OR. ipack.EQ.4 )
THEN
1138 DO 480 jr = irow + 1, lda
1144 ELSE IF( ipack.GE.5 )
THEN
1155 DO 500 jr = 1, uub + 1 - jc
1158 DO 510 jr =
max( 1,
min( ir1, ir2-jc ) ), lda