LAPACK  3.6.1 LAPACK: Linear Algebra PACKage
 subroutine clatmr ( integer M, integer N, character DIST, integer, dimension( 4 ) ISEED, character SYM, complex, dimension( * ) D, integer MODE, real COND, complex DMAX, character RSIGN, character GRADE, complex, dimension( * ) DL, integer MODEL, real CONDL, complex, dimension( * ) DR, integer MODER, real CONDR, character PIVTNG, integer, dimension( * ) IPIVOT, integer KL, integer KU, real SPARSE, real ANORM, character PACK, complex, dimension( lda, * ) A, integer LDA, integer, dimension( * ) IWORK, integer INFO )

CLATMR

Purpose:
CLATMR generates random matrices of various types for testing
LAPACK programs.

CLATMR operates by applying the following sequence of
operations:

Generate a matrix A with random entries of distribution DIST
which is symmetric if SYM='S', Hermitian if SYM='H', and
nonsymmetric if SYM='N'.

Set the diagonal to D, where D may be input or
computed according to MODE, COND, DMAX and RSIGN
as described below.

Grade the matrix, if desired, from the left and/or right
as specified by GRADE. The inputs DL, MODEL, CONDL, DR,
MODER and CONDR also determine the grading as described
below.

Permute, if desired, the rows and/or columns as specified by
PIVTNG and IPIVOT.

Set random entries to zero, if desired, to get a random sparse
matrix as specified by SPARSE.

Make A a band matrix, if desired, by zeroing out the matrix
outside a band of lower bandwidth KL and upper bandwidth KU.

Scale A, if desired, to have maximum entry ANORM.

Pack the matrix if desired. Options specified by PACK are:
no packing
zero out upper half (if symmetric or Hermitian)
zero out lower half (if symmetric or Hermitian)
store the upper half columnwise (if symmetric or Hermitian
or square upper triangular)
store the lower half columnwise (if symmetric or Hermitian
or square lower triangular)
same as upper half rowwise if symmetric
same as conjugate upper half rowwise if Hermitian
store the lower triangle in banded format
(if symmetric or Hermitian)
store the upper triangle in banded format
(if symmetric or Hermitian)
store the entire matrix in banded format

Note: If two calls to CLATMR differ only in the PACK parameter,
they will generate mathematically equivalent matrices.

If two calls to CLATMR both have full bandwidth (KL = M-1
and KU = N-1), and differ only in the PIVTNG and PACK
parameters, then the matrices generated will differ only
in the order of the rows and/or columns, and otherwise
contain the same data. This consistency cannot be and
is not maintained with less than full bandwidth.
Parameters
Date
November 2011

Definition at line 492 of file clatmr.f.

492 *
493 * -- LAPACK computational routine (version 3.4.0) --
494 * -- LAPACK is a software package provided by Univ. of Tennessee, --
495 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
496 * November 2011
497 *
498 * .. Scalar Arguments ..
499  CHARACTER dist, grade, pack, pivtng, rsign, sym
500  INTEGER info, kl, ku, lda, m, mode, model, moder, n
501  REAL anorm, cond, condl, condr, sparse
502  COMPLEX dmax
503 * ..
504 * .. Array Arguments ..
505  INTEGER ipivot( * ), iseed( 4 ), iwork( * )
506  COMPLEX a( lda, * ), d( * ), dl( * ), dr( * )
507 * ..
508 *
509 * =====================================================================
510 *
511 * .. Parameters ..
512  REAL zero
513  parameter ( zero = 0.0e0 )
514  REAL one
515  parameter ( one = 1.0e0 )
516  COMPLEX cone
517  parameter ( cone = ( 1.0e0, 0.0e0 ) )
518  COMPLEX czero
519  parameter ( czero = ( 0.0e0, 0.0e0 ) )
520 * ..
521 * .. Local Scalars ..
523  INTEGER i, idist, igrade, iisub, ipack, ipvtng, irsign,
524  \$ isub, isym, j, jjsub, jsub, k, kll, kuu, mnmin,
525  \$ mnsub, mxsub, npvts
526  REAL onorm, temp
527  COMPLEX calpha, ctemp
528 * ..
529 * .. Local Arrays ..
530  REAL tempa( 1 )
531 * ..
532 * .. External Functions ..
533  LOGICAL lsame
534  REAL clangb, clange, clansb, clansp, clansy
535  COMPLEX clatm2, clatm3
536  EXTERNAL lsame, clangb, clange, clansb, clansp, clansy,
537  \$ clatm2, clatm3
538 * ..
539 * .. External Subroutines ..
540  EXTERNAL clatm1, csscal, xerbla
541 * ..
542 * .. Intrinsic Functions ..
543  INTRINSIC abs, conjg, max, min, mod, real
544 * ..
545 * .. Executable Statements ..
546 *
547 * 1) Decode and Test the input parameters.
548 * Initialize flags & seed.
549 *
550  info = 0
551 *
552 * Quick return if possible
553 *
554  IF( m.EQ.0 .OR. n.EQ.0 )
555  \$ RETURN
556 *
557 * Decode DIST
558 *
559  IF( lsame( dist, 'U' ) ) THEN
560  idist = 1
561  ELSE IF( lsame( dist, 'S' ) ) THEN
562  idist = 2
563  ELSE IF( lsame( dist, 'N' ) ) THEN
564  idist = 3
565  ELSE IF( lsame( dist, 'D' ) ) THEN
566  idist = 4
567  ELSE
568  idist = -1
569  END IF
570 *
571 * Decode SYM
572 *
573  IF( lsame( sym, 'H' ) ) THEN
574  isym = 0
575  ELSE IF( lsame( sym, 'N' ) ) THEN
576  isym = 1
577  ELSE IF( lsame( sym, 'S' ) ) THEN
578  isym = 2
579  ELSE
580  isym = -1
581  END IF
582 *
583 * Decode RSIGN
584 *
585  IF( lsame( rsign, 'F' ) ) THEN
586  irsign = 0
587  ELSE IF( lsame( rsign, 'T' ) ) THEN
588  irsign = 1
589  ELSE
590  irsign = -1
591  END IF
592 *
593 * Decode PIVTNG
594 *
595  IF( lsame( pivtng, 'N' ) ) THEN
596  ipvtng = 0
597  ELSE IF( lsame( pivtng, ' ' ) ) THEN
598  ipvtng = 0
599  ELSE IF( lsame( pivtng, 'L' ) ) THEN
600  ipvtng = 1
601  npvts = m
602  ELSE IF( lsame( pivtng, 'R' ) ) THEN
603  ipvtng = 2
604  npvts = n
605  ELSE IF( lsame( pivtng, 'B' ) ) THEN
606  ipvtng = 3
607  npvts = min( n, m )
608  ELSE IF( lsame( pivtng, 'F' ) ) THEN
609  ipvtng = 3
610  npvts = min( n, m )
611  ELSE
612  ipvtng = -1
613  END IF
614 *
616 *
617  IF( lsame( grade, 'N' ) ) THEN
619  ELSE IF( lsame( grade, 'L' ) ) THEN
621  ELSE IF( lsame( grade, 'R' ) ) THEN
623  ELSE IF( lsame( grade, 'B' ) ) THEN
625  ELSE IF( lsame( grade, 'E' ) ) THEN
627  ELSE IF( lsame( grade, 'H' ) ) THEN
629  ELSE IF( lsame( grade, 'S' ) ) THEN
631  ELSE
633  END IF
634 *
635 * Decode PACK
636 *
637  IF( lsame( pack, 'N' ) ) THEN
638  ipack = 0
639  ELSE IF( lsame( pack, 'U' ) ) THEN
640  ipack = 1
641  ELSE IF( lsame( pack, 'L' ) ) THEN
642  ipack = 2
643  ELSE IF( lsame( pack, 'C' ) ) THEN
644  ipack = 3
645  ELSE IF( lsame( pack, 'R' ) ) THEN
646  ipack = 4
647  ELSE IF( lsame( pack, 'B' ) ) THEN
648  ipack = 5
649  ELSE IF( lsame( pack, 'Q' ) ) THEN
650  ipack = 6
651  ELSE IF( lsame( pack, 'Z' ) ) THEN
652  ipack = 7
653  ELSE
654  ipack = -1
655  END IF
656 *
657 * Set certain internal parameters
658 *
659  mnmin = min( m, n )
660  kll = min( kl, m-1 )
661  kuu = min( ku, n-1 )
662 *
663 * If inv(DL) is used, check to see if DL has a zero entry.
664 *
665  dzero = .false.
666  IF( igrade.EQ.4 .AND. model.EQ.0 ) THEN
667  DO 10 i = 1, m
668  IF( dl( i ).EQ.czero )
669  \$ dzero = .true.
670  10 CONTINUE
671  END IF
672 *
673 * Check values in IPIVOT
674 *
676  IF( ipvtng.GT.0 ) THEN
677  DO 20 j = 1, npvts
678  IF( ipivot( j ).LE.0 .OR. ipivot( j ).GT.npvts )
680  20 CONTINUE
681  END IF
682 *
683 * Set INFO if an error
684 *
685  IF( m.LT.0 ) THEN
686  info = -1
687  ELSE IF( m.NE.n .AND. ( isym.EQ.0 .OR. isym.EQ.2 ) ) THEN
688  info = -1
689  ELSE IF( n.LT.0 ) THEN
690  info = -2
691  ELSE IF( idist.EQ.-1 ) THEN
692  info = -3
693  ELSE IF( isym.EQ.-1 ) THEN
694  info = -5
695  ELSE IF( mode.LT.-6 .OR. mode.GT.6 ) THEN
696  info = -7
697  ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
698  \$ cond.LT.one ) THEN
699  info = -8
700  ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
701  \$ irsign.EQ.-1 ) THEN
702  info = -10
708  info = -11
709  ELSE IF( igrade.EQ.4 .AND. dzero ) THEN
710  info = -12
713  \$ ( model.LT.-6 .OR. model.GT.6 ) ) THEN
714  info = -13
717  \$ ( model.NE.-6 .AND. model.NE.0 .AND. model.NE.6 ) .AND.
718  \$ condl.LT.one ) THEN
719  info = -14
721  \$ ( moder.LT.-6 .OR. moder.GT.6 ) ) THEN
722  info = -16
724  \$ ( moder.NE.-6 .AND. moder.NE.0 .AND. moder.NE.6 ) .AND.
725  \$ condr.LT.one ) THEN
726  info = -17
727  ELSE IF( ipvtng.EQ.-1 .OR. ( ipvtng.EQ.3 .AND. m.NE.n ) .OR.
728  \$ ( ( ipvtng.EQ.1 .OR. ipvtng.EQ.2 ) .AND. ( isym.EQ.0 .OR.
729  \$ isym.EQ.2 ) ) ) THEN
730  info = -18
731  ELSE IF( ipvtng.NE.0 .AND. badpvt ) THEN
732  info = -19
733  ELSE IF( kl.LT.0 ) THEN
734  info = -20
735  ELSE IF( ku.LT.0 .OR. ( ( isym.EQ.0 .OR. isym.EQ.2 ) .AND. kl.NE.
736  \$ ku ) ) THEN
737  info = -21
738  ELSE IF( sparse.LT.zero .OR. sparse.GT.one ) THEN
739  info = -22
740  ELSE IF( ipack.EQ.-1 .OR. ( ( ipack.EQ.1 .OR. ipack.EQ.2 .OR.
741  \$ ipack.EQ.5 .OR. ipack.EQ.6 ) .AND. isym.EQ.1 ) .OR.
742  \$ ( ipack.EQ.3 .AND. isym.EQ.1 .AND. ( kl.NE.0 .OR. m.NE.
743  \$ n ) ) .OR. ( ipack.EQ.4 .AND. isym.EQ.1 .AND. ( ku.NE.
744  \$ 0 .OR. m.NE.n ) ) ) THEN
745  info = -24
746  ELSE IF( ( ( ipack.EQ.0 .OR. ipack.EQ.1 .OR. ipack.EQ.2 ) .AND.
747  \$ lda.LT.max( 1, m ) ) .OR. ( ( ipack.EQ.3 .OR. ipack.EQ.
748  \$ 4 ) .AND. lda.LT.1 ) .OR. ( ( ipack.EQ.5 .OR. ipack.EQ.
749  \$ 6 ) .AND. lda.LT.kuu+1 ) .OR.
750  \$ ( ipack.EQ.7 .AND. lda.LT.kll+kuu+1 ) ) THEN
751  info = -26
752  END IF
753 *
754  IF( info.NE.0 ) THEN
755  CALL xerbla( 'CLATMR', -info )
756  RETURN
757  END IF
758 *
759 * Decide if we can pivot consistently
760 *
761  fulbnd = .false.
762  IF( kuu.EQ.n-1 .AND. kll.EQ.m-1 )
763  \$ fulbnd = .true.
764 *
765 * Initialize random number generator
766 *
767  DO 30 i = 1, 4
768  iseed( i ) = mod( abs( iseed( i ) ), 4096 )
769  30 CONTINUE
770 *
771  iseed( 4 ) = 2*( iseed( 4 ) / 2 ) + 1
772 *
773 * 2) Set up D, DL, and DR, if indicated.
774 *
775 * Compute D according to COND and MODE
776 *
777  CALL clatm1( mode, cond, irsign, idist, iseed, d, mnmin, info )
778  IF( info.NE.0 ) THEN
779  info = 1
780  RETURN
781  END IF
782  IF( mode.NE.0 .AND. mode.NE.-6 .AND. mode.NE.6 ) THEN
783 *
784 * Scale by DMAX
785 *
786  temp = abs( d( 1 ) )
787  DO 40 i = 2, mnmin
788  temp = max( temp, abs( d( i ) ) )
789  40 CONTINUE
790  IF( temp.EQ.zero .AND. dmax.NE.czero ) THEN
791  info = 2
792  RETURN
793  END IF
794  IF( temp.NE.zero ) THEN
795  calpha = dmax / temp
796  ELSE
797  calpha = cone
798  END IF
799  DO 50 i = 1, mnmin
800  d( i ) = calpha*d( i )
801  50 CONTINUE
802 *
803  END IF
804 *
805 * If matrix Hermitian, make D real
806 *
807  IF( isym.EQ.0 ) THEN
808  DO 60 i = 1, mnmin
809  d( i ) = REAL( D( I ) )
810  60 CONTINUE
811  END IF
812 *
813 * Compute DL if grading set
814 *
816  \$ 5 .OR. igrade.EQ.6 ) THEN
817  CALL clatm1( model, condl, 0, idist, iseed, dl, m, info )
818  IF( info.NE.0 ) THEN
819  info = 3
820  RETURN
821  END IF
822  END IF
823 *
824 * Compute DR if grading set
825 *
827  CALL clatm1( moder, condr, 0, idist, iseed, dr, n, info )
828  IF( info.NE.0 ) THEN
829  info = 4
830  RETURN
831  END IF
832  END IF
833 *
834 * 3) Generate IWORK if pivoting
835 *
836  IF( ipvtng.GT.0 ) THEN
837  DO 70 i = 1, npvts
838  iwork( i ) = i
839  70 CONTINUE
840  IF( fulbnd ) THEN
841  DO 80 i = 1, npvts
842  k = ipivot( i )
843  j = iwork( i )
844  iwork( i ) = iwork( k )
845  iwork( k ) = j
846  80 CONTINUE
847  ELSE
848  DO 90 i = npvts, 1, -1
849  k = ipivot( i )
850  j = iwork( i )
851  iwork( i ) = iwork( k )
852  iwork( k ) = j
853  90 CONTINUE
854  END IF
855  END IF
856 *
857 * 4) Generate matrices for each kind of PACKing
858 * Always sweep matrix columnwise (if symmetric, upper
859 * half only) so that matrix generated does not depend
860 * on PACK
861 *
862  IF( fulbnd ) THEN
863 *
864 * Use CLATM3 so matrices generated with differing PIVOTing only
865 * differ only in the order of their rows and/or columns.
866 *
867  IF( ipack.EQ.0 ) THEN
868  IF( isym.EQ.0 ) THEN
869  DO 110 j = 1, n
870  DO 100 i = 1, j
871  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku,
872  \$ idist, iseed, d, igrade, dl, dr, ipvtng,
873  \$ iwork, sparse )
874  a( isub, jsub ) = ctemp
875  a( jsub, isub ) = conjg( ctemp )
876  100 CONTINUE
877  110 CONTINUE
878  ELSE IF( isym.EQ.1 ) THEN
879  DO 130 j = 1, n
880  DO 120 i = 1, m
881  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku,
882  \$ idist, iseed, d, igrade, dl, dr, ipvtng,
883  \$ iwork, sparse )
884  a( isub, jsub ) = ctemp
885  120 CONTINUE
886  130 CONTINUE
887  ELSE IF( isym.EQ.2 ) THEN
888  DO 150 j = 1, n
889  DO 140 i = 1, j
890  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku,
891  \$ idist, iseed, d, igrade, dl, dr, ipvtng,
892  \$ iwork, sparse )
893  a( isub, jsub ) = ctemp
894  a( jsub, isub ) = ctemp
895  140 CONTINUE
896  150 CONTINUE
897  END IF
898 *
899  ELSE IF( ipack.EQ.1 ) THEN
900 *
901  DO 170 j = 1, n
902  DO 160 i = 1, j
903  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku, idist,
904  \$ iseed, d, igrade, dl, dr, ipvtng, iwork,
905  \$ sparse )
906  mnsub = min( isub, jsub )
907  mxsub = max( isub, jsub )
908  IF( mxsub.EQ.isub .AND. isym.EQ.0 ) THEN
909  a( mnsub, mxsub ) = conjg( ctemp )
910  ELSE
911  a( mnsub, mxsub ) = ctemp
912  END IF
913  IF( mnsub.NE.mxsub )
914  \$ a( mxsub, mnsub ) = czero
915  160 CONTINUE
916  170 CONTINUE
917 *
918  ELSE IF( ipack.EQ.2 ) THEN
919 *
920  DO 190 j = 1, n
921  DO 180 i = 1, j
922  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku, idist,
923  \$ iseed, d, igrade, dl, dr, ipvtng, iwork,
924  \$ sparse )
925  mnsub = min( isub, jsub )
926  mxsub = max( isub, jsub )
927  IF( mxsub.EQ.jsub .AND. isym.EQ.0 ) THEN
928  a( mxsub, mnsub ) = conjg( ctemp )
929  ELSE
930  a( mxsub, mnsub ) = ctemp
931  END IF
932  IF( mnsub.NE.mxsub )
933  \$ a( mnsub, mxsub ) = czero
934  180 CONTINUE
935  190 CONTINUE
936 *
937  ELSE IF( ipack.EQ.3 ) THEN
938 *
939  DO 210 j = 1, n
940  DO 200 i = 1, j
941  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku, idist,
942  \$ iseed, d, igrade, dl, dr, ipvtng, iwork,
943  \$ sparse )
944 *
945 * Compute K = location of (ISUB,JSUB) entry in packed
946 * array
947 *
948  mnsub = min( isub, jsub )
949  mxsub = max( isub, jsub )
950  k = mxsub*( mxsub-1 ) / 2 + mnsub
951 *
952 * Convert K to (IISUB,JJSUB) location
953 *
954  jjsub = ( k-1 ) / lda + 1
955  iisub = k - lda*( jjsub-1 )
956 *
957  IF( mxsub.EQ.isub .AND. isym.EQ.0 ) THEN
958  a( iisub, jjsub ) = conjg( ctemp )
959  ELSE
960  a( iisub, jjsub ) = ctemp
961  END IF
962  200 CONTINUE
963  210 CONTINUE
964 *
965  ELSE IF( ipack.EQ.4 ) THEN
966 *
967  DO 230 j = 1, n
968  DO 220 i = 1, j
969  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku, idist,
970  \$ iseed, d, igrade, dl, dr, ipvtng, iwork,
971  \$ sparse )
972 *
973 * Compute K = location of (I,J) entry in packed array
974 *
975  mnsub = min( isub, jsub )
976  mxsub = max( isub, jsub )
977  IF( mnsub.EQ.1 ) THEN
978  k = mxsub
979  ELSE
980  k = n*( n+1 ) / 2 - ( n-mnsub+1 )*( n-mnsub+2 ) /
981  \$ 2 + mxsub - mnsub + 1
982  END IF
983 *
984 * Convert K to (IISUB,JJSUB) location
985 *
986  jjsub = ( k-1 ) / lda + 1
987  iisub = k - lda*( jjsub-1 )
988 *
989  IF( mxsub.EQ.jsub .AND. isym.EQ.0 ) THEN
990  a( iisub, jjsub ) = conjg( ctemp )
991  ELSE
992  a( iisub, jjsub ) = ctemp
993  END IF
994  220 CONTINUE
995  230 CONTINUE
996 *
997  ELSE IF( ipack.EQ.5 ) THEN
998 *
999  DO 250 j = 1, n
1000  DO 240 i = j - kuu, j
1001  IF( i.LT.1 ) THEN
1002  a( j-i+1, i+n ) = czero
1003  ELSE
1004  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku,
1005  \$ idist, iseed, d, igrade, dl, dr, ipvtng,
1006  \$ iwork, sparse )
1007  mnsub = min( isub, jsub )
1008  mxsub = max( isub, jsub )
1009  IF( mxsub.EQ.jsub .AND. isym.EQ.0 ) THEN
1010  a( mxsub-mnsub+1, mnsub ) = conjg( ctemp )
1011  ELSE
1012  a( mxsub-mnsub+1, mnsub ) = ctemp
1013  END IF
1014  END IF
1015  240 CONTINUE
1016  250 CONTINUE
1017 *
1018  ELSE IF( ipack.EQ.6 ) THEN
1019 *
1020  DO 270 j = 1, n
1021  DO 260 i = j - kuu, j
1022  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku, idist,
1023  \$ iseed, d, igrade, dl, dr, ipvtng, iwork,
1024  \$ sparse )
1025  mnsub = min( isub, jsub )
1026  mxsub = max( isub, jsub )
1027  IF( mxsub.EQ.isub .AND. isym.EQ.0 ) THEN
1028  a( mnsub-mxsub+kuu+1, mxsub ) = conjg( ctemp )
1029  ELSE
1030  a( mnsub-mxsub+kuu+1, mxsub ) = ctemp
1031  END IF
1032  260 CONTINUE
1033  270 CONTINUE
1034 *
1035  ELSE IF( ipack.EQ.7 ) THEN
1036 *
1037  IF( isym.NE.1 ) THEN
1038  DO 290 j = 1, n
1039  DO 280 i = j - kuu, j
1040  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku,
1041  \$ idist, iseed, d, igrade, dl, dr, ipvtng,
1042  \$ iwork, sparse )
1043  mnsub = min( isub, jsub )
1044  mxsub = max( isub, jsub )
1045  IF( i.LT.1 )
1046  \$ a( j-i+1+kuu, i+n ) = czero
1047  IF( mxsub.EQ.isub .AND. isym.EQ.0 ) THEN
1048  a( mnsub-mxsub+kuu+1, mxsub ) = conjg( ctemp )
1049  ELSE
1050  a( mnsub-mxsub+kuu+1, mxsub ) = ctemp
1051  END IF
1052  IF( i.GE.1 .AND. mnsub.NE.mxsub ) THEN
1053  IF( mnsub.EQ.isub .AND. isym.EQ.0 ) THEN
1054  a( mxsub-mnsub+1+kuu,
1055  \$ mnsub ) = conjg( ctemp )
1056  ELSE
1057  a( mxsub-mnsub+1+kuu, mnsub ) = ctemp
1058  END IF
1059  END IF
1060  280 CONTINUE
1061  290 CONTINUE
1062  ELSE IF( isym.EQ.1 ) THEN
1063  DO 310 j = 1, n
1064  DO 300 i = j - kuu, j + kll
1065  ctemp = clatm3( m, n, i, j, isub, jsub, kl, ku,
1066  \$ idist, iseed, d, igrade, dl, dr, ipvtng,
1067  \$ iwork, sparse )
1068  a( isub-jsub+kuu+1, jsub ) = ctemp
1069  300 CONTINUE
1070  310 CONTINUE
1071  END IF
1072 *
1073  END IF
1074 *
1075  ELSE
1076 *
1077 * Use CLATM2
1078 *
1079  IF( ipack.EQ.0 ) THEN
1080  IF( isym.EQ.0 ) THEN
1081  DO 330 j = 1, n
1082  DO 320 i = 1, j
1083  a( i, j ) = clatm2( m, n, i, j, kl, ku, idist,
1084  \$ iseed, d, igrade, dl, dr, ipvtng,
1085  \$ iwork, sparse )
1086  a( j, i ) = conjg( a( i, j ) )
1087  320 CONTINUE
1088  330 CONTINUE
1089  ELSE IF( isym.EQ.1 ) THEN
1090  DO 350 j = 1, n
1091  DO 340 i = 1, m
1092  a( i, j ) = clatm2( m, n, i, j, kl, ku, idist,
1093  \$ iseed, d, igrade, dl, dr, ipvtng,
1094  \$ iwork, sparse )
1095  340 CONTINUE
1096  350 CONTINUE
1097  ELSE IF( isym.EQ.2 ) THEN
1098  DO 370 j = 1, n
1099  DO 360 i = 1, j
1100  a( i, j ) = clatm2( m, n, i, j, kl, ku, idist,
1101  \$ iseed, d, igrade, dl, dr, ipvtng,
1102  \$ iwork, sparse )
1103  a( j, i ) = a( i, j )
1104  360 CONTINUE
1105  370 CONTINUE
1106  END IF
1107 *
1108  ELSE IF( ipack.EQ.1 ) THEN
1109 *
1110  DO 390 j = 1, n
1111  DO 380 i = 1, j
1112  a( i, j ) = clatm2( m, n, i, j, kl, ku, idist, iseed,
1113  \$ d, igrade, dl, dr, ipvtng, iwork, sparse )
1114  IF( i.NE.j )
1115  \$ a( j, i ) = czero
1116  380 CONTINUE
1117  390 CONTINUE
1118 *
1119  ELSE IF( ipack.EQ.2 ) THEN
1120 *
1121  DO 410 j = 1, n
1122  DO 400 i = 1, j
1123  IF( isym.EQ.0 ) THEN
1124  a( j, i ) = conjg( clatm2( m, n, i, j, kl, ku,
1125  \$ idist, iseed, d, igrade, dl, dr,
1126  \$ ipvtng, iwork, sparse ) )
1127  ELSE
1128  a( j, i ) = clatm2( m, n, i, j, kl, ku, idist,
1129  \$ iseed, d, igrade, dl, dr, ipvtng,
1130  \$ iwork, sparse )
1131  END IF
1132  IF( i.NE.j )
1133  \$ a( i, j ) = czero
1134  400 CONTINUE
1135  410 CONTINUE
1136 *
1137  ELSE IF( ipack.EQ.3 ) THEN
1138 *
1139  isub = 0
1140  jsub = 1
1141  DO 430 j = 1, n
1142  DO 420 i = 1, j
1143  isub = isub + 1
1144  IF( isub.GT.lda ) THEN
1145  isub = 1
1146  jsub = jsub + 1
1147  END IF
1148  a( isub, jsub ) = clatm2( m, n, i, j, kl, ku, idist,
1149  \$ iseed, d, igrade, dl, dr, ipvtng,
1150  \$ iwork, sparse )
1151  420 CONTINUE
1152  430 CONTINUE
1153 *
1154  ELSE IF( ipack.EQ.4 ) THEN
1155 *
1156  IF( isym.EQ.0 .OR. isym.EQ.2 ) THEN
1157  DO 450 j = 1, n
1158  DO 440 i = 1, j
1159 *
1160 * Compute K = location of (I,J) entry in packed array
1161 *
1162  IF( i.EQ.1 ) THEN
1163  k = j
1164  ELSE
1165  k = n*( n+1 ) / 2 - ( n-i+1 )*( n-i+2 ) / 2 +
1166  \$ j - i + 1
1167  END IF
1168 *
1169 * Convert K to (ISUB,JSUB) location
1170 *
1171  jsub = ( k-1 ) / lda + 1
1172  isub = k - lda*( jsub-1 )
1173 *
1174  a( isub, jsub ) = clatm2( m, n, i, j, kl, ku,
1175  \$ idist, iseed, d, igrade, dl, dr,
1176  \$ ipvtng, iwork, sparse )
1177  IF( isym.EQ.0 )
1178  \$ a( isub, jsub ) = conjg( a( isub, jsub ) )
1179  440 CONTINUE
1180  450 CONTINUE
1181  ELSE
1182  isub = 0
1183  jsub = 1
1184  DO 470 j = 1, n
1185  DO 460 i = j, m
1186  isub = isub + 1
1187  IF( isub.GT.lda ) THEN
1188  isub = 1
1189  jsub = jsub + 1
1190  END IF
1191  a( isub, jsub ) = clatm2( m, n, i, j, kl, ku,
1192  \$ idist, iseed, d, igrade, dl, dr,
1193  \$ ipvtng, iwork, sparse )
1194  460 CONTINUE
1195  470 CONTINUE
1196  END IF
1197 *
1198  ELSE IF( ipack.EQ.5 ) THEN
1199 *
1200  DO 490 j = 1, n
1201  DO 480 i = j - kuu, j
1202  IF( i.LT.1 ) THEN
1203  a( j-i+1, i+n ) = czero
1204  ELSE
1205  IF( isym.EQ.0 ) THEN
1206  a( j-i+1, i ) = conjg( clatm2( m, n, i, j, kl,
1207  \$ ku, idist, iseed, d, igrade, dl,
1208  \$ dr, ipvtng, iwork, sparse ) )
1209  ELSE
1210  a( j-i+1, i ) = clatm2( m, n, i, j, kl, ku,
1211  \$ idist, iseed, d, igrade, dl, dr,
1212  \$ ipvtng, iwork, sparse )
1213  END IF
1214  END IF
1215  480 CONTINUE
1216  490 CONTINUE
1217 *
1218  ELSE IF( ipack.EQ.6 ) THEN
1219 *
1220  DO 510 j = 1, n
1221  DO 500 i = j - kuu, j
1222  a( i-j+kuu+1, j ) = clatm2( m, n, i, j, kl, ku, idist,
1223  \$ iseed, d, igrade, dl, dr, ipvtng,
1224  \$ iwork, sparse )
1225  500 CONTINUE
1226  510 CONTINUE
1227 *
1228  ELSE IF( ipack.EQ.7 ) THEN
1229 *
1230  IF( isym.NE.1 ) THEN
1231  DO 530 j = 1, n
1232  DO 520 i = j - kuu, j
1233  a( i-j+kuu+1, j ) = clatm2( m, n, i, j, kl, ku,
1234  \$ idist, iseed, d, igrade, dl,
1235  \$ dr, ipvtng, iwork, sparse )
1236  IF( i.LT.1 )
1237  \$ a( j-i+1+kuu, i+n ) = czero
1238  IF( i.GE.1 .AND. i.NE.j ) THEN
1239  IF( isym.EQ.0 ) THEN
1240  a( j-i+1+kuu, i ) = conjg( a( i-j+kuu+1,
1241  \$ j ) )
1242  ELSE
1243  a( j-i+1+kuu, i ) = a( i-j+kuu+1, j )
1244  END IF
1245  END IF
1246  520 CONTINUE
1247  530 CONTINUE
1248  ELSE IF( isym.EQ.1 ) THEN
1249  DO 550 j = 1, n
1250  DO 540 i = j - kuu, j + kll
1251  a( i-j+kuu+1, j ) = clatm2( m, n, i, j, kl, ku,
1252  \$ idist, iseed, d, igrade, dl,
1253  \$ dr, ipvtng, iwork, sparse )
1254  540 CONTINUE
1255  550 CONTINUE
1256  END IF
1257 *
1258  END IF
1259 *
1260  END IF
1261 *
1262 * 5) Scaling the norm
1263 *
1264  IF( ipack.EQ.0 ) THEN
1265  onorm = clange( 'M', m, n, a, lda, tempa )
1266  ELSE IF( ipack.EQ.1 ) THEN
1267  onorm = clansy( 'M', 'U', n, a, lda, tempa )
1268  ELSE IF( ipack.EQ.2 ) THEN
1269  onorm = clansy( 'M', 'L', n, a, lda, tempa )
1270  ELSE IF( ipack.EQ.3 ) THEN
1271  onorm = clansp( 'M', 'U', n, a, tempa )
1272  ELSE IF( ipack.EQ.4 ) THEN
1273  onorm = clansp( 'M', 'L', n, a, tempa )
1274  ELSE IF( ipack.EQ.5 ) THEN
1275  onorm = clansb( 'M', 'L', n, kll, a, lda, tempa )
1276  ELSE IF( ipack.EQ.6 ) THEN
1277  onorm = clansb( 'M', 'U', n, kuu, a, lda, tempa )
1278  ELSE IF( ipack.EQ.7 ) THEN
1279  onorm = clangb( 'M', n, kll, kuu, a, lda, tempa )
1280  END IF
1281 *
1282  IF( anorm.GE.zero ) THEN
1283 *
1284  IF( anorm.GT.zero .AND. onorm.EQ.zero ) THEN
1285 *
1286 * Desired scaling impossible
1287 *
1288  info = 5
1289  RETURN
1290 *
1291  ELSE IF( ( anorm.GT.one .AND. onorm.LT.one ) .OR.
1292  \$ ( anorm.LT.one .AND. onorm.GT.one ) ) THEN
1293 *
1294 * Scale carefully to avoid over / underflow
1295 *
1296  IF( ipack.LE.2 ) THEN
1297  DO 560 j = 1, n
1298  CALL csscal( m, one / onorm, a( 1, j ), 1 )
1299  CALL csscal( m, anorm, a( 1, j ), 1 )
1300  560 CONTINUE
1301 *
1302  ELSE IF( ipack.EQ.3 .OR. ipack.EQ.4 ) THEN
1303 *
1304  CALL csscal( n*( n+1 ) / 2, one / onorm, a, 1 )
1305  CALL csscal( n*( n+1 ) / 2, anorm, a, 1 )
1306 *
1307  ELSE IF( ipack.GE.5 ) THEN
1308 *
1309  DO 570 j = 1, n
1310  CALL csscal( kll+kuu+1, one / onorm, a( 1, j ), 1 )
1311  CALL csscal( kll+kuu+1, anorm, a( 1, j ), 1 )
1312  570 CONTINUE
1313 *
1314  END IF
1315 *
1316  ELSE
1317 *
1318 * Scale straightforwardly
1319 *
1320  IF( ipack.LE.2 ) THEN
1321  DO 580 j = 1, n
1322  CALL csscal( m, anorm / onorm, a( 1, j ), 1 )
1323  580 CONTINUE
1324 *
1325  ELSE IF( ipack.EQ.3 .OR. ipack.EQ.4 ) THEN
1326 *
1327  CALL csscal( n*( n+1 ) / 2, anorm / onorm, a, 1 )
1328 *
1329  ELSE IF( ipack.GE.5 ) THEN
1330 *
1331  DO 590 j = 1, n
1332  CALL csscal( kll+kuu+1, anorm / onorm, a( 1, j ), 1 )
1333  590 CONTINUE
1334  END IF
1335 *
1336  END IF
1337 *
1338  END IF
1339 *
1340 * End of CLATMR
1341 *
real function clansp(NORM, UPLO, N, AP, WORK)
CLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric matrix supplied in packed form.
Definition: clansp.f:117
real function clansb(NORM, UPLO, N, K, AB, LDAB, WORK)
CLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric band matrix.
Definition: clansb.f:132
complex function clatm3(M, N, I, J, ISUB, JSUB, KL, KU, IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE)
CLATM3
Definition: clatm3.f:231
real function clange(NORM, M, N, A, LDA, WORK)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: clange.f:117
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
real function clangb(NORM, N, KL, KU, AB, LDAB, WORK)
CLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition: clangb.f:127
real function clansy(NORM, UPLO, N, A, LDA, WORK)
CLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex symmetric matrix.
Definition: clansy.f:125
subroutine clatm1(MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO)
CLATM1
Definition: clatm1.f:139
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
subroutine csscal(N, SA, CX, INCX)
CSSCAL
Definition: csscal.f:54
complex function clatm2(M, N, I, J, KL, KU, IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE)
CLATM2
Definition: clatm2.f:214

Here is the call graph for this function:

Here is the caller graph for this function: