clatms.c
Go to the documentation of this file.
00001 /* clatms.f -- translated by f2c (version 20061008).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015 
00016 /* Table of constant values */
00017 
00018 static complex c_b1 = {0.f,0.f};
00019 static integer c__1 = 1;
00020 static integer c__5 = 5;
00021 static logical c_true = TRUE_;
00022 static logical c_false = FALSE_;
00023 
00024 /* Subroutine */ int clatms_(integer *m, integer *n, char *dist, integer *
00025         iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__, 
00026         integer *kl, integer *ku, char *pack, complex *a, integer *lda, 
00027         complex *work, integer *info)
00028 {
00029     /* System generated locals */
00030     integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
00031     real r__1, r__2, r__3;
00032     complex q__1, q__2, q__3;
00033     logical L__1;
00034 
00035     /* Builtin functions */
00036     double cos(doublereal), sin(doublereal);
00037     void r_cnjg(complex *, complex *);
00038 
00039     /* Local variables */
00040     complex c__;
00041     integer i__, j, k;
00042     complex s;
00043     integer ic, jc, nc, il;
00044     complex ct;
00045     integer ir, jr, mr;
00046     complex st;
00047     integer ir1, ir2, jch, llb, jkl, jku, uub, ilda, icol;
00048     real temp;
00049     logical csym;
00050     integer irow, isym;
00051     real alpha, angle;
00052     integer ipack;
00053     real realc;
00054     integer ioffg;
00055     extern logical lsame_(char *, char *);
00056     integer iinfo;
00057     extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
00058     complex ctemp;
00059     integer idist, mnmin, iskew;
00060     complex extra, dummy;
00061     extern /* Subroutine */ int slatm1_(integer *, real *, integer *, integer 
00062             *, integer *, real *, integer *, integer *), clagge_(integer *, 
00063             integer *, integer *, integer *, real *, complex *, integer *, 
00064             integer *, complex *, integer *), claghe_(integer *, integer *, 
00065             real *, complex *, integer *, integer *, complex *, integer *);
00066     integer iendch, ipackg;
00067     extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
00068     integer minlda;
00069     extern /* Subroutine */ int claset_(char *, integer *, integer *, complex 
00070             *, complex *, complex *, integer *), clartg_(complex *, 
00071             complex *, real *, complex *, complex *), xerbla_(char *, integer 
00072             *), clagsy_(integer *, integer *, real *, complex *, 
00073             integer *, integer *, complex *, integer *);
00074     extern doublereal slarnd_(integer *, integer *);
00075     extern /* Subroutine */ int clarot_(logical *, logical *, logical *, 
00076             integer *, complex *, complex *, complex *, integer *, complex *, 
00077             complex *);
00078     logical iltemp, givens;
00079     integer ioffst, irsign;
00080     logical ilextr, topdwn;
00081     integer isympk;
00082 
00083 
00084 /*  -- LAPACK test routine (version 3.1) -- */
00085 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00086 /*     November 2006 */
00087 
00088 /*     .. Scalar Arguments .. */
00089 /*     .. */
00090 /*     .. Array Arguments .. */
00091 /*     .. */
00092 
00093 /*  Purpose */
00094 /*  ======= */
00095 
00096 /*     CLATMS generates random matrices with specified singular values */
00097 /*     (or hermitian with specified eigenvalues) */
00098 /*     for testing LAPACK programs. */
00099 
00100 /*     CLATMS operates by applying the following sequence of */
00101 /*     operations: */
00102 
00103 /*       Set the diagonal to D, where D may be input or */
00104 /*          computed according to MODE, COND, DMAX, and SYM */
00105 /*          as described below. */
00106 
00107 /*       Generate a matrix with the appropriate band structure, by one */
00108 /*          of two methods: */
00109 
00110 /*       Method A: */
00111 /*           Generate a dense M x N matrix by multiplying D on the left */
00112 /*               and the right by random unitary matrices, then: */
00113 
00114 /*           Reduce the bandwidth according to KL and KU, using */
00115 /*               Householder transformations. */
00116 
00117 /*       Method B: */
00118 /*           Convert the bandwidth-0 (i.e., diagonal) matrix to a */
00119 /*               bandwidth-1 matrix using Givens rotations, "chasing" */
00120 /*               out-of-band elements back, much as in QR; then convert */
00121 /*               the bandwidth-1 to a bandwidth-2 matrix, etc.  Note */
00122 /*               that for reasonably small bandwidths (relative to M and */
00123 /*               N) this requires less storage, as a dense matrix is not */
00124 /*               generated.  Also, for hermitian or symmetric matrices, */
00125 /*               only one triangle is generated. */
00126 
00127 /*       Method A is chosen if the bandwidth is a large fraction of the */
00128 /*           order of the matrix, and LDA is at least M (so a dense */
00129 /*           matrix can be stored.)  Method B is chosen if the bandwidth */
00130 /*           is small (< 1/2 N for hermitian or symmetric, < .3 N+M for */
00131 /*           non-symmetric), or LDA is less than M and not less than the */
00132 /*           bandwidth. */
00133 
00134 /*       Pack the matrix if desired. Options specified by PACK are: */
00135 /*          no packing */
00136 /*          zero out upper half (if hermitian) */
00137 /*          zero out lower half (if hermitian) */
00138 /*          store the upper half columnwise (if hermitian or upper */
00139 /*                triangular) */
00140 /*          store the lower half columnwise (if hermitian or lower */
00141 /*                triangular) */
00142 /*          store the lower triangle in banded format (if hermitian or */
00143 /*                lower triangular) */
00144 /*          store the upper triangle in banded format (if hermitian or */
00145 /*                upper triangular) */
00146 /*          store the entire matrix in banded format */
00147 /*       If Method B is chosen, and band format is specified, then the */
00148 /*          matrix will be generated in the band format, so no repacking */
00149 /*          will be necessary. */
00150 
00151 /*  Arguments */
00152 /*  ========= */
00153 
00154 /*  M      - INTEGER */
00155 /*           The number of rows of A. Not modified. */
00156 
00157 /*  N      - INTEGER */
00158 /*           The number of columns of A. N must equal M if the matrix */
00159 /*           is symmetric or hermitian (i.e., if SYM is not 'N') */
00160 /*           Not modified. */
00161 
00162 /*  DIST   - CHARACTER*1 */
00163 /*           On entry, DIST specifies the type of distribution to be used */
00164 /*           to generate the random eigen-/singular values. */
00165 /*           'U' => UNIFORM( 0, 1 )  ( 'U' for uniform ) */
00166 /*           'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
00167 /*           'N' => NORMAL( 0, 1 )   ( 'N' for normal ) */
00168 /*           Not modified. */
00169 
00170 /*  ISEED  - INTEGER array, dimension ( 4 ) */
00171 /*           On entry ISEED specifies the seed of the random number */
00172 /*           generator. They should lie between 0 and 4095 inclusive, */
00173 /*           and ISEED(4) should be odd. The random number generator */
00174 /*           uses a linear congruential sequence limited to small */
00175 /*           integers, and so should produce machine independent */
00176 /*           random numbers. The values of ISEED are changed on */
00177 /*           exit, and can be used in the next call to CLATMS */
00178 /*           to continue the same random number sequence. */
00179 /*           Changed on exit. */
00180 
00181 /*  SYM    - CHARACTER*1 */
00182 /*           If SYM='H', the generated matrix is hermitian, with */
00183 /*             eigenvalues specified by D, COND, MODE, and DMAX; they */
00184 /*             may be positive, negative, or zero. */
00185 /*           If SYM='P', the generated matrix is hermitian, with */
00186 /*             eigenvalues (= singular values) specified by D, COND, */
00187 /*             MODE, and DMAX; they will not be negative. */
00188 /*           If SYM='N', the generated matrix is nonsymmetric, with */
00189 /*             singular values specified by D, COND, MODE, and DMAX; */
00190 /*             they will not be negative. */
00191 /*           If SYM='S', the generated matrix is (complex) symmetric, */
00192 /*             with singular values specified by D, COND, MODE, and */
00193 /*             DMAX; they will not be negative. */
00194 /*           Not modified. */
00195 
00196 /*  D      - REAL array, dimension ( MIN( M, N ) ) */
00197 /*           This array is used to specify the singular values or */
00198 /*           eigenvalues of A (see SYM, above.)  If MODE=0, then D is */
00199 /*           assumed to contain the singular/eigenvalues, otherwise */
00200 /*           they will be computed according to MODE, COND, and DMAX, */
00201 /*           and placed in D. */
00202 /*           Modified if MODE is nonzero. */
00203 
00204 /*  MODE   - INTEGER */
00205 /*           On entry this describes how the singular/eigenvalues are to */
00206 /*           be specified: */
00207 /*           MODE = 0 means use D as input */
00208 /*           MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
00209 /*           MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
00210 /*           MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
00211 /*           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
00212 /*           MODE = 5 sets D to random numbers in the range */
00213 /*                    ( 1/COND , 1 ) such that their logarithms */
00214 /*                    are uniformly distributed. */
00215 /*           MODE = 6 set D to random numbers from same distribution */
00216 /*                    as the rest of the matrix. */
00217 /*           MODE < 0 has the same meaning as ABS(MODE), except that */
00218 /*              the order of the elements of D is reversed. */
00219 /*           Thus if MODE is positive, D has entries ranging from */
00220 /*              1 to 1/COND, if negative, from 1/COND to 1, */
00221 /*           If SYM='H', and MODE is neither 0, 6, nor -6, then */
00222 /*              the elements of D will also be multiplied by a random */
00223 /*              sign (i.e., +1 or -1.) */
00224 /*           Not modified. */
00225 
00226 /*  COND   - REAL */
00227 /*           On entry, this is used as described under MODE above. */
00228 /*           If used, it must be >= 1. Not modified. */
00229 
00230 /*  DMAX   - REAL */
00231 /*           If MODE is neither -6, 0 nor 6, the contents of D, as */
00232 /*           computed according to MODE and COND, will be scaled by */
00233 /*           DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or */
00234 /*           singular value (which is to say the norm) will be abs(DMAX). */
00235 /*           Note that DMAX need not be positive: if DMAX is negative */
00236 /*           (or zero), D will be scaled by a negative number (or zero). */
00237 /*           Not modified. */
00238 
00239 /*  KL     - INTEGER */
00240 /*           This specifies the lower bandwidth of the  matrix. For */
00241 /*           example, KL=0 implies upper triangular, KL=1 implies upper */
00242 /*           Hessenberg, and KL being at least M-1 means that the matrix */
00243 /*           has full lower bandwidth.  KL must equal KU if the matrix */
00244 /*           is symmetric or hermitian. */
00245 /*           Not modified. */
00246 
00247 /*  KU     - INTEGER */
00248 /*           This specifies the upper bandwidth of the  matrix. For */
00249 /*           example, KU=0 implies lower triangular, KU=1 implies lower */
00250 /*           Hessenberg, and KU being at least N-1 means that the matrix */
00251 /*           has full upper bandwidth.  KL must equal KU if the matrix */
00252 /*           is symmetric or hermitian. */
00253 /*           Not modified. */
00254 
00255 /*  PACK   - CHARACTER*1 */
00256 /*           This specifies packing of matrix as follows: */
00257 /*           'N' => no packing */
00258 /*           'U' => zero out all subdiagonal entries (if symmetric */
00259 /*                  or hermitian) */
00260 /*           'L' => zero out all superdiagonal entries (if symmetric */
00261 /*                  or hermitian) */
00262 /*           'C' => store the upper triangle columnwise (only if the */
00263 /*                  matrix is symmetric, hermitian, or upper triangular) */
00264 /*           'R' => store the lower triangle columnwise (only if the */
00265 /*                  matrix is symmetric, hermitian, or lower triangular) */
00266 /*           'B' => store the lower triangle in band storage scheme */
00267 /*                  (only if the matrix is symmetric, hermitian, or */
00268 /*                  lower triangular) */
00269 /*           'Q' => store the upper triangle in band storage scheme */
00270 /*                  (only if the matrix is symmetric, hermitian, or */
00271 /*                  upper triangular) */
00272 /*           'Z' => store the entire matrix in band storage scheme */
00273 /*                      (pivoting can be provided for by using this */
00274 /*                      option to store A in the trailing rows of */
00275 /*                      the allocated storage) */
00276 
00277 /*           Using these options, the various LAPACK packed and banded */
00278 /*           storage schemes can be obtained: */
00279 /*           GB                    - use 'Z' */
00280 /*           PB, SB, HB, or TB     - use 'B' or 'Q' */
00281 /*           PP, SP, HB, or TP     - use 'C' or 'R' */
00282 
00283 /*           If two calls to CLATMS differ only in the PACK parameter, */
00284 /*           they will generate mathematically equivalent matrices. */
00285 /*           Not modified. */
00286 
00287 /*  A      - COMPLEX array, dimension ( LDA, N ) */
00288 /*           On exit A is the desired test matrix.  A is first generated */
00289 /*           in full (unpacked) form, and then packed, if so specified */
00290 /*           by PACK.  Thus, the first M elements of the first N */
00291 /*           columns will always be modified.  If PACK specifies a */
00292 /*           packed or banded storage scheme, all LDA elements of the */
00293 /*           first N columns will be modified; the elements of the */
00294 /*           array which do not correspond to elements of the generated */
00295 /*           matrix are set to zero. */
00296 /*           Modified. */
00297 
00298 /*  LDA    - INTEGER */
00299 /*           LDA specifies the first dimension of A as declared in the */
00300 /*           calling program.  If PACK='N', 'U', 'L', 'C', or 'R', then */
00301 /*           LDA must be at least M.  If PACK='B' or 'Q', then LDA must */
00302 /*           be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */
00303 /*           If PACK='Z', LDA must be large enough to hold the packed */
00304 /*           array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */
00305 /*           Not modified. */
00306 
00307 /*  WORK   - COMPLEX array, dimension ( 3*MAX( N, M ) ) */
00308 /*           Workspace. */
00309 /*           Modified. */
00310 
00311 /*  INFO   - INTEGER */
00312 /*           Error code.  On exit, INFO will be set to one of the */
00313 /*           following values: */
00314 /*             0 => normal return */
00315 /*            -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */
00316 /*            -2 => N negative */
00317 /*            -3 => DIST illegal string */
00318 /*            -5 => SYM illegal string */
00319 /*            -7 => MODE not in range -6 to 6 */
00320 /*            -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
00321 /*           -10 => KL negative */
00322 /*           -11 => KU negative, or SYM is not 'N' and KU is not equal to */
00323 /*                  KL */
00324 /*           -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */
00325 /*                  or PACK='C' or 'Q' and SYM='N' and KL is not zero; */
00326 /*                  or PACK='R' or 'B' and SYM='N' and KU is not zero; */
00327 /*                  or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */
00328 /*                  N. */
00329 /*           -14 => LDA is less than M, or PACK='Z' and LDA is less than */
00330 /*                  MIN(KU,N-1) + MIN(KL,M-1) + 1. */
00331 /*            1  => Error return from SLATM1 */
00332 /*            2  => Cannot scale to DMAX (max. sing. value is 0) */
00333 /*            3  => Error return from CLAGGE, CLAGHE or CLAGSY */
00334 
00335 /*  ===================================================================== */
00336 
00337 /*     .. Parameters .. */
00338 /*     .. */
00339 /*     .. Local Scalars .. */
00340 /*     .. */
00341 /*     .. External Functions .. */
00342 /*     .. */
00343 /*     .. External Subroutines .. */
00344 /*     .. */
00345 /*     .. Intrinsic Functions .. */
00346 /*     .. */
00347 /*     .. Executable Statements .. */
00348 
00349 /*     1)      Decode and Test the input parameters. */
00350 /*             Initialize flags & seed. */
00351 
00352     /* Parameter adjustments */
00353     --iseed;
00354     --d__;
00355     a_dim1 = *lda;
00356     a_offset = 1 + a_dim1;
00357     a -= a_offset;
00358     --work;
00359 
00360     /* Function Body */
00361     *info = 0;
00362 
00363 /*     Quick return if possible */
00364 
00365     if (*m == 0 || *n == 0) {
00366         return 0;
00367     }
00368 
00369 /*     Decode DIST */
00370 
00371     if (lsame_(dist, "U")) {
00372         idist = 1;
00373     } else if (lsame_(dist, "S")) {
00374         idist = 2;
00375     } else if (lsame_(dist, "N")) {
00376         idist = 3;
00377     } else {
00378         idist = -1;
00379     }
00380 
00381 /*     Decode SYM */
00382 
00383     if (lsame_(sym, "N")) {
00384         isym = 1;
00385         irsign = 0;
00386         csym = FALSE_;
00387     } else if (lsame_(sym, "P")) {
00388         isym = 2;
00389         irsign = 0;
00390         csym = FALSE_;
00391     } else if (lsame_(sym, "S")) {
00392         isym = 2;
00393         irsign = 0;
00394         csym = TRUE_;
00395     } else if (lsame_(sym, "H")) {
00396         isym = 2;
00397         irsign = 1;
00398         csym = FALSE_;
00399     } else {
00400         isym = -1;
00401     }
00402 
00403 /*     Decode PACK */
00404 
00405     isympk = 0;
00406     if (lsame_(pack, "N")) {
00407         ipack = 0;
00408     } else if (lsame_(pack, "U")) {
00409         ipack = 1;
00410         isympk = 1;
00411     } else if (lsame_(pack, "L")) {
00412         ipack = 2;
00413         isympk = 1;
00414     } else if (lsame_(pack, "C")) {
00415         ipack = 3;
00416         isympk = 2;
00417     } else if (lsame_(pack, "R")) {
00418         ipack = 4;
00419         isympk = 3;
00420     } else if (lsame_(pack, "B")) {
00421         ipack = 5;
00422         isympk = 3;
00423     } else if (lsame_(pack, "Q")) {
00424         ipack = 6;
00425         isympk = 2;
00426     } else if (lsame_(pack, "Z")) {
00427         ipack = 7;
00428     } else {
00429         ipack = -1;
00430     }
00431 
00432 /*     Set certain internal parameters */
00433 
00434     mnmin = min(*m,*n);
00435 /* Computing MIN */
00436     i__1 = *kl, i__2 = *m - 1;
00437     llb = min(i__1,i__2);
00438 /* Computing MIN */
00439     i__1 = *ku, i__2 = *n - 1;
00440     uub = min(i__1,i__2);
00441 /* Computing MIN */
00442     i__1 = *m, i__2 = *n + llb;
00443     mr = min(i__1,i__2);
00444 /* Computing MIN */
00445     i__1 = *n, i__2 = *m + uub;
00446     nc = min(i__1,i__2);
00447 
00448     if (ipack == 5 || ipack == 6) {
00449         minlda = uub + 1;
00450     } else if (ipack == 7) {
00451         minlda = llb + uub + 1;
00452     } else {
00453         minlda = *m;
00454     }
00455 
00456 /*     Use Givens rotation method if bandwidth small enough, */
00457 /*     or if LDA is too small to store the matrix unpacked. */
00458 
00459     givens = FALSE_;
00460     if (isym == 1) {
00461 /* Computing MAX */
00462         i__1 = 1, i__2 = mr + nc;
00463         if ((real) (llb + uub) < (real) max(i__1,i__2) * .3f) {
00464             givens = TRUE_;
00465         }
00466     } else {
00467         if (llb << 1 < *m) {
00468             givens = TRUE_;
00469         }
00470     }
00471     if (*lda < *m && *lda >= minlda) {
00472         givens = TRUE_;
00473     }
00474 
00475 /*     Set INFO if an error */
00476 
00477     if (*m < 0) {
00478         *info = -1;
00479     } else if (*m != *n && isym != 1) {
00480         *info = -1;
00481     } else if (*n < 0) {
00482         *info = -2;
00483     } else if (idist == -1) {
00484         *info = -3;
00485     } else if (isym == -1) {
00486         *info = -5;
00487     } else if (abs(*mode) > 6) {
00488         *info = -7;
00489     } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) {
00490         *info = -8;
00491     } else if (*kl < 0) {
00492         *info = -10;
00493     } else if (*ku < 0 || isym != 1 && *kl != *ku) {
00494         *info = -11;
00495     } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym 
00496             == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk 
00497             != 0 && *m != *n) {
00498         *info = -12;
00499     } else if (*lda < max(1,minlda)) {
00500         *info = -14;
00501     }
00502 
00503     if (*info != 0) {
00504         i__1 = -(*info);
00505         xerbla_("CLATMS", &i__1);
00506         return 0;
00507     }
00508 
00509 /*     Initialize random number generator */
00510 
00511     for (i__ = 1; i__ <= 4; ++i__) {
00512         iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
00513 /* L10: */
00514     }
00515 
00516     if (iseed[4] % 2 != 1) {
00517         ++iseed[4];
00518     }
00519 
00520 /*     2)      Set up D  if indicated. */
00521 
00522 /*             Compute D according to COND and MODE */
00523 
00524     slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, &iinfo);
00525     if (iinfo != 0) {
00526         *info = 1;
00527         return 0;
00528     }
00529 
00530 /*     Choose Top-Down if D is (apparently) increasing, */
00531 /*     Bottom-Up if D is (apparently) decreasing. */
00532 
00533     if (dabs(d__[1]) <= (r__1 = d__[mnmin], dabs(r__1))) {
00534         topdwn = TRUE_;
00535     } else {
00536         topdwn = FALSE_;
00537     }
00538 
00539     if (*mode != 0 && abs(*mode) != 6) {
00540 
00541 /*        Scale by DMAX */
00542 
00543         temp = dabs(d__[1]);
00544         i__1 = mnmin;
00545         for (i__ = 2; i__ <= i__1; ++i__) {
00546 /* Computing MAX */
00547             r__2 = temp, r__3 = (r__1 = d__[i__], dabs(r__1));
00548             temp = dmax(r__2,r__3);
00549 /* L20: */
00550         }
00551 
00552         if (temp > 0.f) {
00553             alpha = *dmax__ / temp;
00554         } else {
00555             *info = 2;
00556             return 0;
00557         }
00558 
00559         sscal_(&mnmin, &alpha, &d__[1], &c__1);
00560 
00561     }
00562 
00563     claset_("Full", lda, n, &c_b1, &c_b1, &a[a_offset], lda);
00564 
00565 /*     3)      Generate Banded Matrix using Givens rotations. */
00566 /*             Also the special case of UUB=LLB=0 */
00567 
00568 /*               Compute Addressing constants to cover all */
00569 /*               storage formats.  Whether GE, HE, SY, GB, HB, or SB, */
00570 /*               upper or lower triangle or both, */
00571 /*               the (i,j)-th element is in */
00572 /*               A( i - ISKEW*j + IOFFST, j ) */
00573 
00574     if (ipack > 4) {
00575         ilda = *lda - 1;
00576         iskew = 1;
00577         if (ipack > 5) {
00578             ioffst = uub + 1;
00579         } else {
00580             ioffst = 1;
00581         }
00582     } else {
00583         ilda = *lda;
00584         iskew = 0;
00585         ioffst = 0;
00586     }
00587 
00588 /*     IPACKG is the format that the matrix is generated in. If this is */
00589 /*     different from IPACK, then the matrix must be repacked at the */
00590 /*     end.  It also signals how to compute the norm, for scaling. */
00591 
00592     ipackg = 0;
00593 
00594 /*     Diagonal Matrix -- We are done, unless it */
00595 /*     is to be stored HP/SP/PP/TP (PACK='R' or 'C') */
00596 
00597     if (llb == 0 && uub == 0) {
00598         i__1 = mnmin;
00599         for (j = 1; j <= i__1; ++j) {
00600             i__2 = (1 - iskew) * j + ioffst + j * a_dim1;
00601             i__3 = j;
00602             q__1.r = d__[i__3], q__1.i = 0.f;
00603             a[i__2].r = q__1.r, a[i__2].i = q__1.i;
00604 /* L30: */
00605         }
00606 
00607         if (ipack <= 2 || ipack >= 5) {
00608             ipackg = ipack;
00609         }
00610 
00611     } else if (givens) {
00612 
00613 /*        Check whether to use Givens rotations, */
00614 /*        Householder transformations, or nothing. */
00615 
00616         if (isym == 1) {
00617 
00618 /*           Non-symmetric -- A = U D V */
00619 
00620             if (ipack > 4) {
00621                 ipackg = ipack;
00622             } else {
00623                 ipackg = 0;
00624             }
00625 
00626             i__1 = mnmin;
00627             for (j = 1; j <= i__1; ++j) {
00628                 i__2 = (1 - iskew) * j + ioffst + j * a_dim1;
00629                 i__3 = j;
00630                 q__1.r = d__[i__3], q__1.i = 0.f;
00631                 a[i__2].r = q__1.r, a[i__2].i = q__1.i;
00632 /* L40: */
00633             }
00634 
00635             if (topdwn) {
00636                 jkl = 0;
00637                 i__1 = uub;
00638                 for (jku = 1; jku <= i__1; ++jku) {
00639 
00640 /*                 Transform from bandwidth JKL, JKU-1 to JKL, JKU */
00641 
00642 /*                 Last row actually rotated is M */
00643 /*                 Last column actually rotated is MIN( M+JKU, N ) */
00644 
00645 /* Computing MIN */
00646                     i__3 = *m + jku;
00647                     i__2 = min(i__3,*n) + jkl - 1;
00648                     for (jr = 1; jr <= i__2; ++jr) {
00649                         extra.r = 0.f, extra.i = 0.f;
00650                         angle = slarnd_(&c__1, &iseed[1]) * 
00651                                 6.2831853071795864769252867663f;
00652                         r__1 = cos(angle);
00653                         clarnd_(&q__2, &c__5, &iseed[1]);
00654                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
00655                         c__.r = q__1.r, c__.i = q__1.i;
00656                         r__1 = sin(angle);
00657                         clarnd_(&q__2, &c__5, &iseed[1]);
00658                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
00659                         s.r = q__1.r, s.i = q__1.i;
00660 /* Computing MAX */
00661                         i__3 = 1, i__4 = jr - jkl;
00662                         icol = max(i__3,i__4);
00663                         if (jr < *m) {
00664 /* Computing MIN */
00665                             i__3 = *n, i__4 = jr + jku;
00666                             il = min(i__3,i__4) + 1 - icol;
00667                             L__1 = jr > jkl;
00668                             clarot_(&c_true, &L__1, &c_false, &il, &c__, &s, &
00669                                     a[jr - iskew * icol + ioffst + icol * 
00670                                     a_dim1], &ilda, &extra, &dummy);
00671                         }
00672 
00673 /*                    Chase "EXTRA" back up */
00674 
00675                         ir = jr;
00676                         ic = icol;
00677                         i__3 = -jkl - jku;
00678                         for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1; 
00679                                 jch += i__3) {
00680                             if (ir < *m) {
00681                                 clartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst 
00682                                         + (ic + 1) * a_dim1], &extra, &realc, 
00683                                         &s, &dummy);
00684                                 clarnd_(&q__1, &c__5, &iseed[1]);
00685                                 dummy.r = q__1.r, dummy.i = q__1.i;
00686                                 q__2.r = realc * dummy.r, q__2.i = realc * 
00687                                         dummy.i;
00688                                 r_cnjg(&q__1, &q__2);
00689                                 c__.r = q__1.r, c__.i = q__1.i;
00690                                 q__3.r = -s.r, q__3.i = -s.i;
00691                                 q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, 
00692                                         q__2.i = q__3.r * dummy.i + q__3.i * 
00693                                         dummy.r;
00694                                 r_cnjg(&q__1, &q__2);
00695                                 s.r = q__1.r, s.i = q__1.i;
00696                             }
00697 /* Computing MAX */
00698                             i__4 = 1, i__5 = jch - jku;
00699                             irow = max(i__4,i__5);
00700                             il = ir + 2 - irow;
00701                             ctemp.r = 0.f, ctemp.i = 0.f;
00702                             iltemp = jch > jku;
00703                             clarot_(&c_false, &iltemp, &c_true, &il, &c__, &s, 
00704                                      &a[irow - iskew * ic + ioffst + ic * 
00705                                     a_dim1], &ilda, &ctemp, &extra);
00706                             if (iltemp) {
00707                                 clartg_(&a[irow + 1 - iskew * (ic + 1) + 
00708                                         ioffst + (ic + 1) * a_dim1], &ctemp, &
00709                                         realc, &s, &dummy);
00710                                 clarnd_(&q__1, &c__5, &iseed[1]);
00711                                 dummy.r = q__1.r, dummy.i = q__1.i;
00712                                 q__2.r = realc * dummy.r, q__2.i = realc * 
00713                                         dummy.i;
00714                                 r_cnjg(&q__1, &q__2);
00715                                 c__.r = q__1.r, c__.i = q__1.i;
00716                                 q__3.r = -s.r, q__3.i = -s.i;
00717                                 q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, 
00718                                         q__2.i = q__3.r * dummy.i + q__3.i * 
00719                                         dummy.r;
00720                                 r_cnjg(&q__1, &q__2);
00721                                 s.r = q__1.r, s.i = q__1.i;
00722 
00723 /* Computing MAX */
00724                                 i__4 = 1, i__5 = jch - jku - jkl;
00725                                 icol = max(i__4,i__5);
00726                                 il = ic + 2 - icol;
00727                                 extra.r = 0.f, extra.i = 0.f;
00728                                 L__1 = jch > jku + jkl;
00729                                 clarot_(&c_true, &L__1, &c_true, &il, &c__, &
00730                                         s, &a[irow - iskew * icol + ioffst + 
00731                                         icol * a_dim1], &ilda, &extra, &ctemp)
00732                                         ;
00733                                 ic = icol;
00734                                 ir = irow;
00735                             }
00736 /* L50: */
00737                         }
00738 /* L60: */
00739                     }
00740 /* L70: */
00741                 }
00742 
00743                 jku = uub;
00744                 i__1 = llb;
00745                 for (jkl = 1; jkl <= i__1; ++jkl) {
00746 
00747 /*                 Transform from bandwidth JKL-1, JKU to JKL, JKU */
00748 
00749 /* Computing MIN */
00750                     i__3 = *n + jkl;
00751                     i__2 = min(i__3,*m) + jku - 1;
00752                     for (jc = 1; jc <= i__2; ++jc) {
00753                         extra.r = 0.f, extra.i = 0.f;
00754                         angle = slarnd_(&c__1, &iseed[1]) * 
00755                                 6.2831853071795864769252867663f;
00756                         r__1 = cos(angle);
00757                         clarnd_(&q__2, &c__5, &iseed[1]);
00758                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
00759                         c__.r = q__1.r, c__.i = q__1.i;
00760                         r__1 = sin(angle);
00761                         clarnd_(&q__2, &c__5, &iseed[1]);
00762                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
00763                         s.r = q__1.r, s.i = q__1.i;
00764 /* Computing MAX */
00765                         i__3 = 1, i__4 = jc - jku;
00766                         irow = max(i__3,i__4);
00767                         if (jc < *n) {
00768 /* Computing MIN */
00769                             i__3 = *m, i__4 = jc + jkl;
00770                             il = min(i__3,i__4) + 1 - irow;
00771                             L__1 = jc > jku;
00772                             clarot_(&c_false, &L__1, &c_false, &il, &c__, &s, 
00773                                     &a[irow - iskew * jc + ioffst + jc * 
00774                                     a_dim1], &ilda, &extra, &dummy);
00775                         }
00776 
00777 /*                    Chase "EXTRA" back up */
00778 
00779                         ic = jc;
00780                         ir = irow;
00781                         i__3 = -jkl - jku;
00782                         for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1; 
00783                                 jch += i__3) {
00784                             if (ic < *n) {
00785                                 clartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst 
00786                                         + (ic + 1) * a_dim1], &extra, &realc, 
00787                                         &s, &dummy);
00788                                 clarnd_(&q__1, &c__5, &iseed[1]);
00789                                 dummy.r = q__1.r, dummy.i = q__1.i;
00790                                 q__2.r = realc * dummy.r, q__2.i = realc * 
00791                                         dummy.i;
00792                                 r_cnjg(&q__1, &q__2);
00793                                 c__.r = q__1.r, c__.i = q__1.i;
00794                                 q__3.r = -s.r, q__3.i = -s.i;
00795                                 q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, 
00796                                         q__2.i = q__3.r * dummy.i + q__3.i * 
00797                                         dummy.r;
00798                                 r_cnjg(&q__1, &q__2);
00799                                 s.r = q__1.r, s.i = q__1.i;
00800                             }
00801 /* Computing MAX */
00802                             i__4 = 1, i__5 = jch - jkl;
00803                             icol = max(i__4,i__5);
00804                             il = ic + 2 - icol;
00805                             ctemp.r = 0.f, ctemp.i = 0.f;
00806                             iltemp = jch > jkl;
00807                             clarot_(&c_true, &iltemp, &c_true, &il, &c__, &s, 
00808                                     &a[ir - iskew * icol + ioffst + icol * 
00809                                     a_dim1], &ilda, &ctemp, &extra);
00810                             if (iltemp) {
00811                                 clartg_(&a[ir + 1 - iskew * (icol + 1) + 
00812                                         ioffst + (icol + 1) * a_dim1], &ctemp, 
00813                                          &realc, &s, &dummy);
00814                                 clarnd_(&q__1, &c__5, &iseed[1]);
00815                                 dummy.r = q__1.r, dummy.i = q__1.i;
00816                                 q__2.r = realc * dummy.r, q__2.i = realc * 
00817                                         dummy.i;
00818                                 r_cnjg(&q__1, &q__2);
00819                                 c__.r = q__1.r, c__.i = q__1.i;
00820                                 q__3.r = -s.r, q__3.i = -s.i;
00821                                 q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, 
00822                                         q__2.i = q__3.r * dummy.i + q__3.i * 
00823                                         dummy.r;
00824                                 r_cnjg(&q__1, &q__2);
00825                                 s.r = q__1.r, s.i = q__1.i;
00826 /* Computing MAX */
00827                                 i__4 = 1, i__5 = jch - jkl - jku;
00828                                 irow = max(i__4,i__5);
00829                                 il = ir + 2 - irow;
00830                                 extra.r = 0.f, extra.i = 0.f;
00831                                 L__1 = jch > jkl + jku;
00832                                 clarot_(&c_false, &L__1, &c_true, &il, &c__, &
00833                                         s, &a[irow - iskew * icol + ioffst + 
00834                                         icol * a_dim1], &ilda, &extra, &ctemp)
00835                                         ;
00836                                 ic = icol;
00837                                 ir = irow;
00838                             }
00839 /* L80: */
00840                         }
00841 /* L90: */
00842                     }
00843 /* L100: */
00844                 }
00845 
00846             } else {
00847 
00848 /*              Bottom-Up -- Start at the bottom right. */
00849 
00850                 jkl = 0;
00851                 i__1 = uub;
00852                 for (jku = 1; jku <= i__1; ++jku) {
00853 
00854 /*                 Transform from bandwidth JKL, JKU-1 to JKL, JKU */
00855 
00856 /*                 First row actually rotated is M */
00857 /*                 First column actually rotated is MIN( M+JKU, N ) */
00858 
00859 /* Computing MIN */
00860                     i__2 = *m, i__3 = *n + jkl;
00861                     iendch = min(i__2,i__3) - 1;
00862 /* Computing MIN */
00863                     i__2 = *m + jku;
00864                     i__3 = 1 - jkl;
00865                     for (jc = min(i__2,*n) - 1; jc >= i__3; --jc) {
00866                         extra.r = 0.f, extra.i = 0.f;
00867                         angle = slarnd_(&c__1, &iseed[1]) * 
00868                                 6.2831853071795864769252867663f;
00869                         r__1 = cos(angle);
00870                         clarnd_(&q__2, &c__5, &iseed[1]);
00871                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
00872                         c__.r = q__1.r, c__.i = q__1.i;
00873                         r__1 = sin(angle);
00874                         clarnd_(&q__2, &c__5, &iseed[1]);
00875                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
00876                         s.r = q__1.r, s.i = q__1.i;
00877 /* Computing MAX */
00878                         i__2 = 1, i__4 = jc - jku + 1;
00879                         irow = max(i__2,i__4);
00880                         if (jc > 0) {
00881 /* Computing MIN */
00882                             i__2 = *m, i__4 = jc + jkl + 1;
00883                             il = min(i__2,i__4) + 1 - irow;
00884                             L__1 = jc + jkl < *m;
00885                             clarot_(&c_false, &c_false, &L__1, &il, &c__, &s, 
00886                                     &a[irow - iskew * jc + ioffst + jc * 
00887                                     a_dim1], &ilda, &dummy, &extra);
00888                         }
00889 
00890 /*                    Chase "EXTRA" back down */
00891 
00892                         ic = jc;
00893                         i__2 = iendch;
00894                         i__4 = jkl + jku;
00895                         for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <= 
00896                                 i__2; jch += i__4) {
00897                             ilextr = ic > 0;
00898                             if (ilextr) {
00899                                 clartg_(&a[jch - iskew * ic + ioffst + ic * 
00900                                         a_dim1], &extra, &realc, &s, &dummy);
00901                                 clarnd_(&q__1, &c__5, &iseed[1]);
00902                                 dummy.r = q__1.r, dummy.i = q__1.i;
00903                                 q__1.r = realc * dummy.r, q__1.i = realc * 
00904                                         dummy.i;
00905                                 c__.r = q__1.r, c__.i = q__1.i;
00906                                 q__1.r = s.r * dummy.r - s.i * dummy.i, 
00907                                         q__1.i = s.r * dummy.i + s.i * 
00908                                         dummy.r;
00909                                 s.r = q__1.r, s.i = q__1.i;
00910                             }
00911                             ic = max(1,ic);
00912 /* Computing MIN */
00913                             i__5 = *n - 1, i__6 = jch + jku;
00914                             icol = min(i__5,i__6);
00915                             iltemp = jch + jku < *n;
00916                             ctemp.r = 0.f, ctemp.i = 0.f;
00917                             i__5 = icol + 2 - ic;
00918                             clarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, &
00919                                     s, &a[jch - iskew * ic + ioffst + ic * 
00920                                     a_dim1], &ilda, &extra, &ctemp);
00921                             if (iltemp) {
00922                                 clartg_(&a[jch - iskew * icol + ioffst + icol 
00923                                         * a_dim1], &ctemp, &realc, &s, &dummy)
00924                                         ;
00925                                 clarnd_(&q__1, &c__5, &iseed[1]);
00926                                 dummy.r = q__1.r, dummy.i = q__1.i;
00927                                 q__1.r = realc * dummy.r, q__1.i = realc * 
00928                                         dummy.i;
00929                                 c__.r = q__1.r, c__.i = q__1.i;
00930                                 q__1.r = s.r * dummy.r - s.i * dummy.i, 
00931                                         q__1.i = s.r * dummy.i + s.i * 
00932                                         dummy.r;
00933                                 s.r = q__1.r, s.i = q__1.i;
00934 /* Computing MIN */
00935                                 i__5 = iendch, i__6 = jch + jkl + jku;
00936                                 il = min(i__5,i__6) + 2 - jch;
00937                                 extra.r = 0.f, extra.i = 0.f;
00938                                 L__1 = jch + jkl + jku <= iendch;
00939                                 clarot_(&c_false, &c_true, &L__1, &il, &c__, &
00940                                         s, &a[jch - iskew * icol + ioffst + 
00941                                         icol * a_dim1], &ilda, &ctemp, &extra)
00942                                         ;
00943                                 ic = icol;
00944                             }
00945 /* L110: */
00946                         }
00947 /* L120: */
00948                     }
00949 /* L130: */
00950                 }
00951 
00952                 jku = uub;
00953                 i__1 = llb;
00954                 for (jkl = 1; jkl <= i__1; ++jkl) {
00955 
00956 /*                 Transform from bandwidth JKL-1, JKU to JKL, JKU */
00957 
00958 /*                 First row actually rotated is MIN( N+JKL, M ) */
00959 /*                 First column actually rotated is N */
00960 
00961 /* Computing MIN */
00962                     i__3 = *n, i__4 = *m + jku;
00963                     iendch = min(i__3,i__4) - 1;
00964 /* Computing MIN */
00965                     i__3 = *n + jkl;
00966                     i__4 = 1 - jku;
00967                     for (jr = min(i__3,*m) - 1; jr >= i__4; --jr) {
00968                         extra.r = 0.f, extra.i = 0.f;
00969                         angle = slarnd_(&c__1, &iseed[1]) * 
00970                                 6.2831853071795864769252867663f;
00971                         r__1 = cos(angle);
00972                         clarnd_(&q__2, &c__5, &iseed[1]);
00973                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
00974                         c__.r = q__1.r, c__.i = q__1.i;
00975                         r__1 = sin(angle);
00976                         clarnd_(&q__2, &c__5, &iseed[1]);
00977                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
00978                         s.r = q__1.r, s.i = q__1.i;
00979 /* Computing MAX */
00980                         i__3 = 1, i__2 = jr - jkl + 1;
00981                         icol = max(i__3,i__2);
00982                         if (jr > 0) {
00983 /* Computing MIN */
00984                             i__3 = *n, i__2 = jr + jku + 1;
00985                             il = min(i__3,i__2) + 1 - icol;
00986                             L__1 = jr + jku < *n;
00987                             clarot_(&c_true, &c_false, &L__1, &il, &c__, &s, &
00988                                     a[jr - iskew * icol + ioffst + icol * 
00989                                     a_dim1], &ilda, &dummy, &extra);
00990                         }
00991 
00992 /*                    Chase "EXTRA" back down */
00993 
00994                         ir = jr;
00995                         i__3 = iendch;
00996                         i__2 = jkl + jku;
00997                         for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <= 
00998                                 i__3; jch += i__2) {
00999                             ilextr = ir > 0;
01000                             if (ilextr) {
01001                                 clartg_(&a[ir - iskew * jch + ioffst + jch * 
01002                                         a_dim1], &extra, &realc, &s, &dummy);
01003                                 clarnd_(&q__1, &c__5, &iseed[1]);
01004                                 dummy.r = q__1.r, dummy.i = q__1.i;
01005                                 q__1.r = realc * dummy.r, q__1.i = realc * 
01006                                         dummy.i;
01007                                 c__.r = q__1.r, c__.i = q__1.i;
01008                                 q__1.r = s.r * dummy.r - s.i * dummy.i, 
01009                                         q__1.i = s.r * dummy.i + s.i * 
01010                                         dummy.r;
01011                                 s.r = q__1.r, s.i = q__1.i;
01012                             }
01013                             ir = max(1,ir);
01014 /* Computing MIN */
01015                             i__5 = *m - 1, i__6 = jch + jkl;
01016                             irow = min(i__5,i__6);
01017                             iltemp = jch + jkl < *m;
01018                             ctemp.r = 0.f, ctemp.i = 0.f;
01019                             i__5 = irow + 2 - ir;
01020                             clarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, &
01021                                     s, &a[ir - iskew * jch + ioffst + jch * 
01022                                     a_dim1], &ilda, &extra, &ctemp);
01023                             if (iltemp) {
01024                                 clartg_(&a[irow - iskew * jch + ioffst + jch *
01025                                          a_dim1], &ctemp, &realc, &s, &dummy);
01026                                 clarnd_(&q__1, &c__5, &iseed[1]);
01027                                 dummy.r = q__1.r, dummy.i = q__1.i;
01028                                 q__1.r = realc * dummy.r, q__1.i = realc * 
01029                                         dummy.i;
01030                                 c__.r = q__1.r, c__.i = q__1.i;
01031                                 q__1.r = s.r * dummy.r - s.i * dummy.i, 
01032                                         q__1.i = s.r * dummy.i + s.i * 
01033                                         dummy.r;
01034                                 s.r = q__1.r, s.i = q__1.i;
01035 /* Computing MIN */
01036                                 i__5 = iendch, i__6 = jch + jkl + jku;
01037                                 il = min(i__5,i__6) + 2 - jch;
01038                                 extra.r = 0.f, extra.i = 0.f;
01039                                 L__1 = jch + jkl + jku <= iendch;
01040                                 clarot_(&c_true, &c_true, &L__1, &il, &c__, &
01041                                         s, &a[irow - iskew * jch + ioffst + 
01042                                         jch * a_dim1], &ilda, &ctemp, &extra);
01043                                 ir = irow;
01044                             }
01045 /* L140: */
01046                         }
01047 /* L150: */
01048                     }
01049 /* L160: */
01050                 }
01051 
01052             }
01053 
01054         } else {
01055 
01056 /*           Symmetric -- A = U D U' */
01057 /*           Hermitian -- A = U D U* */
01058 
01059             ipackg = ipack;
01060             ioffg = ioffst;
01061 
01062             if (topdwn) {
01063 
01064 /*              Top-Down -- Generate Upper triangle only */
01065 
01066                 if (ipack >= 5) {
01067                     ipackg = 6;
01068                     ioffg = uub + 1;
01069                 } else {
01070                     ipackg = 1;
01071                 }
01072 
01073                 i__1 = mnmin;
01074                 for (j = 1; j <= i__1; ++j) {
01075                     i__4 = (1 - iskew) * j + ioffg + j * a_dim1;
01076                     i__2 = j;
01077                     q__1.r = d__[i__2], q__1.i = 0.f;
01078                     a[i__4].r = q__1.r, a[i__4].i = q__1.i;
01079 /* L170: */
01080                 }
01081 
01082                 i__1 = uub;
01083                 for (k = 1; k <= i__1; ++k) {
01084                     i__4 = *n - 1;
01085                     for (jc = 1; jc <= i__4; ++jc) {
01086 /* Computing MAX */
01087                         i__2 = 1, i__3 = jc - k;
01088                         irow = max(i__2,i__3);
01089 /* Computing MIN */
01090                         i__2 = jc + 1, i__3 = k + 2;
01091                         il = min(i__2,i__3);
01092                         extra.r = 0.f, extra.i = 0.f;
01093                         i__2 = jc - iskew * (jc + 1) + ioffg + (jc + 1) * 
01094                                 a_dim1;
01095                         ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
01096                         angle = slarnd_(&c__1, &iseed[1]) * 
01097                                 6.2831853071795864769252867663f;
01098                         r__1 = cos(angle);
01099                         clarnd_(&q__2, &c__5, &iseed[1]);
01100                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
01101                         c__.r = q__1.r, c__.i = q__1.i;
01102                         r__1 = sin(angle);
01103                         clarnd_(&q__2, &c__5, &iseed[1]);
01104                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
01105                         s.r = q__1.r, s.i = q__1.i;
01106                         if (csym) {
01107                             ct.r = c__.r, ct.i = c__.i;
01108                             st.r = s.r, st.i = s.i;
01109                         } else {
01110                             r_cnjg(&q__1, &ctemp);
01111                             ctemp.r = q__1.r, ctemp.i = q__1.i;
01112                             r_cnjg(&q__1, &c__);
01113                             ct.r = q__1.r, ct.i = q__1.i;
01114                             r_cnjg(&q__1, &s);
01115                             st.r = q__1.r, st.i = q__1.i;
01116                         }
01117                         L__1 = jc > k;
01118                         clarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[
01119                                 irow - iskew * jc + ioffg + jc * a_dim1], &
01120                                 ilda, &extra, &ctemp);
01121 /* Computing MIN */
01122                         i__3 = k, i__5 = *n - jc;
01123                         i__2 = min(i__3,i__5) + 1;
01124                         clarot_(&c_true, &c_true, &c_false, &i__2, &ct, &st, &
01125                                 a[(1 - iskew) * jc + ioffg + jc * a_dim1], &
01126                                 ilda, &ctemp, &dummy);
01127 
01128 /*                    Chase EXTRA back up the matrix */
01129 
01130                         icol = jc;
01131                         i__2 = -k;
01132                         for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1; 
01133                                 jch += i__2) {
01134                             clartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg + 
01135                                     (icol + 1) * a_dim1], &extra, &realc, &s, 
01136                                     &dummy);
01137                             clarnd_(&q__1, &c__5, &iseed[1]);
01138                             dummy.r = q__1.r, dummy.i = q__1.i;
01139                             q__2.r = realc * dummy.r, q__2.i = realc * 
01140                                     dummy.i;
01141                             r_cnjg(&q__1, &q__2);
01142                             c__.r = q__1.r, c__.i = q__1.i;
01143                             q__3.r = -s.r, q__3.i = -s.i;
01144                             q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, 
01145                                     q__2.i = q__3.r * dummy.i + q__3.i * 
01146                                     dummy.r;
01147                             r_cnjg(&q__1, &q__2);
01148                             s.r = q__1.r, s.i = q__1.i;
01149                             i__3 = jch - iskew * (jch + 1) + ioffg + (jch + 1)
01150                                      * a_dim1;
01151                             ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
01152                             if (csym) {
01153                                 ct.r = c__.r, ct.i = c__.i;
01154                                 st.r = s.r, st.i = s.i;
01155                             } else {
01156                                 r_cnjg(&q__1, &ctemp);
01157                                 ctemp.r = q__1.r, ctemp.i = q__1.i;
01158                                 r_cnjg(&q__1, &c__);
01159                                 ct.r = q__1.r, ct.i = q__1.i;
01160                                 r_cnjg(&q__1, &s);
01161                                 st.r = q__1.r, st.i = q__1.i;
01162                             }
01163                             i__3 = k + 2;
01164                             clarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
01165                                     s, &a[(1 - iskew) * jch + ioffg + jch * 
01166                                     a_dim1], &ilda, &ctemp, &extra);
01167 /* Computing MAX */
01168                             i__3 = 1, i__5 = jch - k;
01169                             irow = max(i__3,i__5);
01170 /* Computing MIN */
01171                             i__3 = jch + 1, i__5 = k + 2;
01172                             il = min(i__3,i__5);
01173                             extra.r = 0.f, extra.i = 0.f;
01174                             L__1 = jch > k;
01175                             clarot_(&c_false, &L__1, &c_true, &il, &ct, &st, &
01176                                     a[irow - iskew * jch + ioffg + jch * 
01177                                     a_dim1], &ilda, &extra, &ctemp);
01178                             icol = jch;
01179 /* L180: */
01180                         }
01181 /* L190: */
01182                     }
01183 /* L200: */
01184                 }
01185 
01186 /*              If we need lower triangle, copy from upper. Note that */
01187 /*              the order of copying is chosen to work for 'q' -> 'b' */
01188 
01189                 if (ipack != ipackg && ipack != 3) {
01190                     i__1 = *n;
01191                     for (jc = 1; jc <= i__1; ++jc) {
01192                         irow = ioffst - iskew * jc;
01193                         if (csym) {
01194 /* Computing MIN */
01195                             i__2 = *n, i__3 = jc + uub;
01196                             i__4 = min(i__2,i__3);
01197                             for (jr = jc; jr <= i__4; ++jr) {
01198                                 i__2 = jr + irow + jc * a_dim1;
01199                                 i__3 = jc - iskew * jr + ioffg + jr * a_dim1;
01200                                 a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
01201 /* L210: */
01202                             }
01203                         } else {
01204 /* Computing MIN */
01205                             i__2 = *n, i__3 = jc + uub;
01206                             i__4 = min(i__2,i__3);
01207                             for (jr = jc; jr <= i__4; ++jr) {
01208                                 i__2 = jr + irow + jc * a_dim1;
01209                                 r_cnjg(&q__1, &a[jc - iskew * jr + ioffg + jr 
01210                                         * a_dim1]);
01211                                 a[i__2].r = q__1.r, a[i__2].i = q__1.i;
01212 /* L220: */
01213                             }
01214                         }
01215 /* L230: */
01216                     }
01217                     if (ipack == 5) {
01218                         i__1 = *n;
01219                         for (jc = *n - uub + 1; jc <= i__1; ++jc) {
01220                             i__4 = uub + 1;
01221                             for (jr = *n + 2 - jc; jr <= i__4; ++jr) {
01222                                 i__2 = jr + jc * a_dim1;
01223                                 a[i__2].r = 0.f, a[i__2].i = 0.f;
01224 /* L240: */
01225                             }
01226 /* L250: */
01227                         }
01228                     }
01229                     if (ipackg == 6) {
01230                         ipackg = ipack;
01231                     } else {
01232                         ipackg = 0;
01233                     }
01234                 }
01235             } else {
01236 
01237 /*              Bottom-Up -- Generate Lower triangle only */
01238 
01239                 if (ipack >= 5) {
01240                     ipackg = 5;
01241                     if (ipack == 6) {
01242                         ioffg = 1;
01243                     }
01244                 } else {
01245                     ipackg = 2;
01246                 }
01247 
01248                 i__1 = mnmin;
01249                 for (j = 1; j <= i__1; ++j) {
01250                     i__4 = (1 - iskew) * j + ioffg + j * a_dim1;
01251                     i__2 = j;
01252                     q__1.r = d__[i__2], q__1.i = 0.f;
01253                     a[i__4].r = q__1.r, a[i__4].i = q__1.i;
01254 /* L260: */
01255                 }
01256 
01257                 i__1 = uub;
01258                 for (k = 1; k <= i__1; ++k) {
01259                     for (jc = *n - 1; jc >= 1; --jc) {
01260 /* Computing MIN */
01261                         i__4 = *n + 1 - jc, i__2 = k + 2;
01262                         il = min(i__4,i__2);
01263                         extra.r = 0.f, extra.i = 0.f;
01264                         i__4 = (1 - iskew) * jc + 1 + ioffg + jc * a_dim1;
01265                         ctemp.r = a[i__4].r, ctemp.i = a[i__4].i;
01266                         angle = slarnd_(&c__1, &iseed[1]) * 
01267                                 6.2831853071795864769252867663f;
01268                         r__1 = cos(angle);
01269                         clarnd_(&q__2, &c__5, &iseed[1]);
01270                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
01271                         c__.r = q__1.r, c__.i = q__1.i;
01272                         r__1 = sin(angle);
01273                         clarnd_(&q__2, &c__5, &iseed[1]);
01274                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
01275                         s.r = q__1.r, s.i = q__1.i;
01276                         if (csym) {
01277                             ct.r = c__.r, ct.i = c__.i;
01278                             st.r = s.r, st.i = s.i;
01279                         } else {
01280                             r_cnjg(&q__1, &ctemp);
01281                             ctemp.r = q__1.r, ctemp.i = q__1.i;
01282                             r_cnjg(&q__1, &c__);
01283                             ct.r = q__1.r, ct.i = q__1.i;
01284                             r_cnjg(&q__1, &s);
01285                             st.r = q__1.r, st.i = q__1.i;
01286                         }
01287                         L__1 = *n - jc > k;
01288                         clarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[(
01289                                 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda, 
01290                                  &ctemp, &extra);
01291 /* Computing MAX */
01292                         i__4 = 1, i__2 = jc - k + 1;
01293                         icol = max(i__4,i__2);
01294                         i__4 = jc + 2 - icol;
01295                         clarot_(&c_true, &c_false, &c_true, &i__4, &ct, &st, &
01296                                 a[jc - iskew * icol + ioffg + icol * a_dim1], 
01297                                 &ilda, &dummy, &ctemp);
01298 
01299 /*                    Chase EXTRA back down the matrix */
01300 
01301                         icol = jc;
01302                         i__4 = *n - 1;
01303                         i__2 = k;
01304                         for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <= 
01305                                 i__4; jch += i__2) {
01306                             clartg_(&a[jch - iskew * icol + ioffg + icol * 
01307                                     a_dim1], &extra, &realc, &s, &dummy);
01308                             clarnd_(&q__1, &c__5, &iseed[1]);
01309                             dummy.r = q__1.r, dummy.i = q__1.i;
01310                             q__1.r = realc * dummy.r, q__1.i = realc * 
01311                                     dummy.i;
01312                             c__.r = q__1.r, c__.i = q__1.i;
01313                             q__1.r = s.r * dummy.r - s.i * dummy.i, q__1.i = 
01314                                     s.r * dummy.i + s.i * dummy.r;
01315                             s.r = q__1.r, s.i = q__1.i;
01316                             i__3 = (1 - iskew) * jch + 1 + ioffg + jch * 
01317                                     a_dim1;
01318                             ctemp.r = a[i__3].r, ctemp.i = a[i__3].i;
01319                             if (csym) {
01320                                 ct.r = c__.r, ct.i = c__.i;
01321                                 st.r = s.r, st.i = s.i;
01322                             } else {
01323                                 r_cnjg(&q__1, &ctemp);
01324                                 ctemp.r = q__1.r, ctemp.i = q__1.i;
01325                                 r_cnjg(&q__1, &c__);
01326                                 ct.r = q__1.r, ct.i = q__1.i;
01327                                 r_cnjg(&q__1, &s);
01328                                 st.r = q__1.r, st.i = q__1.i;
01329                             }
01330                             i__3 = k + 2;
01331                             clarot_(&c_true, &c_true, &c_true, &i__3, &c__, &
01332                                     s, &a[jch - iskew * icol + ioffg + icol * 
01333                                     a_dim1], &ilda, &extra, &ctemp);
01334 /* Computing MIN */
01335                             i__3 = *n + 1 - jch, i__5 = k + 2;
01336                             il = min(i__3,i__5);
01337                             extra.r = 0.f, extra.i = 0.f;
01338                             L__1 = *n - jch > k;
01339                             clarot_(&c_false, &c_true, &L__1, &il, &ct, &st, &
01340                                     a[(1 - iskew) * jch + ioffg + jch * 
01341                                     a_dim1], &ilda, &ctemp, &extra);
01342                             icol = jch;
01343 /* L270: */
01344                         }
01345 /* L280: */
01346                     }
01347 /* L290: */
01348                 }
01349 
01350 /*              If we need upper triangle, copy from lower. Note that */
01351 /*              the order of copying is chosen to work for 'b' -> 'q' */
01352 
01353                 if (ipack != ipackg && ipack != 4) {
01354                     for (jc = *n; jc >= 1; --jc) {
01355                         irow = ioffst - iskew * jc;
01356                         if (csym) {
01357 /* Computing MAX */
01358                             i__2 = 1, i__4 = jc - uub;
01359                             i__1 = max(i__2,i__4);
01360                             for (jr = jc; jr >= i__1; --jr) {
01361                                 i__2 = jr + irow + jc * a_dim1;
01362                                 i__4 = jc - iskew * jr + ioffg + jr * a_dim1;
01363                                 a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i;
01364 /* L300: */
01365                             }
01366                         } else {
01367 /* Computing MAX */
01368                             i__2 = 1, i__4 = jc - uub;
01369                             i__1 = max(i__2,i__4);
01370                             for (jr = jc; jr >= i__1; --jr) {
01371                                 i__2 = jr + irow + jc * a_dim1;
01372                                 r_cnjg(&q__1, &a[jc - iskew * jr + ioffg + jr 
01373                                         * a_dim1]);
01374                                 a[i__2].r = q__1.r, a[i__2].i = q__1.i;
01375 /* L310: */
01376                             }
01377                         }
01378 /* L320: */
01379                     }
01380                     if (ipack == 6) {
01381                         i__1 = uub;
01382                         for (jc = 1; jc <= i__1; ++jc) {
01383                             i__2 = uub + 1 - jc;
01384                             for (jr = 1; jr <= i__2; ++jr) {
01385                                 i__4 = jr + jc * a_dim1;
01386                                 a[i__4].r = 0.f, a[i__4].i = 0.f;
01387 /* L330: */
01388                             }
01389 /* L340: */
01390                         }
01391                     }
01392                     if (ipackg == 5) {
01393                         ipackg = ipack;
01394                     } else {
01395                         ipackg = 0;
01396                     }
01397                 }
01398             }
01399 
01400 /*           Ensure that the diagonal is real if Hermitian */
01401 
01402             if (! csym) {
01403                 i__1 = *n;
01404                 for (jc = 1; jc <= i__1; ++jc) {
01405                     irow = ioffst + (1 - iskew) * jc;
01406                     i__2 = irow + jc * a_dim1;
01407                     i__4 = irow + jc * a_dim1;
01408                     r__1 = a[i__4].r;
01409                     q__1.r = r__1, q__1.i = 0.f;
01410                     a[i__2].r = q__1.r, a[i__2].i = q__1.i;
01411 /* L350: */
01412                 }
01413             }
01414 
01415         }
01416 
01417     } else {
01418 
01419 /*        4)      Generate Banded Matrix by first */
01420 /*                Rotating by random Unitary matrices, */
01421 /*                then reducing the bandwidth using Householder */
01422 /*                transformations. */
01423 
01424 /*                Note: we should get here only if LDA .ge. N */
01425 
01426         if (isym == 1) {
01427 
01428 /*           Non-symmetric -- A = U D V */
01429 
01430             clagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[
01431                     1], &work[1], &iinfo);
01432         } else {
01433 
01434 /*           Symmetric -- A = U D U' or */
01435 /*           Hermitian -- A = U D U* */
01436 
01437             if (csym) {
01438                 clagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[
01439                         1], &iinfo);
01440             } else {
01441                 claghe_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[
01442                         1], &iinfo);
01443             }
01444         }
01445 
01446         if (iinfo != 0) {
01447             *info = 3;
01448             return 0;
01449         }
01450     }
01451 
01452 /*     5)      Pack the matrix */
01453 
01454     if (ipack != ipackg) {
01455         if (ipack == 1) {
01456 
01457 /*           'U' -- Upper triangular, not packed */
01458 
01459             i__1 = *m;
01460             for (j = 1; j <= i__1; ++j) {
01461                 i__2 = *m;
01462                 for (i__ = j + 1; i__ <= i__2; ++i__) {
01463                     i__4 = i__ + j * a_dim1;
01464                     a[i__4].r = 0.f, a[i__4].i = 0.f;
01465 /* L360: */
01466                 }
01467 /* L370: */
01468             }
01469 
01470         } else if (ipack == 2) {
01471 
01472 /*           'L' -- Lower triangular, not packed */
01473 
01474             i__1 = *m;
01475             for (j = 2; j <= i__1; ++j) {
01476                 i__2 = j - 1;
01477                 for (i__ = 1; i__ <= i__2; ++i__) {
01478                     i__4 = i__ + j * a_dim1;
01479                     a[i__4].r = 0.f, a[i__4].i = 0.f;
01480 /* L380: */
01481                 }
01482 /* L390: */
01483             }
01484 
01485         } else if (ipack == 3) {
01486 
01487 /*           'C' -- Upper triangle packed Columnwise. */
01488 
01489             icol = 1;
01490             irow = 0;
01491             i__1 = *m;
01492             for (j = 1; j <= i__1; ++j) {
01493                 i__2 = j;
01494                 for (i__ = 1; i__ <= i__2; ++i__) {
01495                     ++irow;
01496                     if (irow > *lda) {
01497                         irow = 1;
01498                         ++icol;
01499                     }
01500                     i__4 = irow + icol * a_dim1;
01501                     i__3 = i__ + j * a_dim1;
01502                     a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
01503 /* L400: */
01504                 }
01505 /* L410: */
01506             }
01507 
01508         } else if (ipack == 4) {
01509 
01510 /*           'R' -- Lower triangle packed Columnwise. */
01511 
01512             icol = 1;
01513             irow = 0;
01514             i__1 = *m;
01515             for (j = 1; j <= i__1; ++j) {
01516                 i__2 = *m;
01517                 for (i__ = j; i__ <= i__2; ++i__) {
01518                     ++irow;
01519                     if (irow > *lda) {
01520                         irow = 1;
01521                         ++icol;
01522                     }
01523                     i__4 = irow + icol * a_dim1;
01524                     i__3 = i__ + j * a_dim1;
01525                     a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
01526 /* L420: */
01527                 }
01528 /* L430: */
01529             }
01530 
01531         } else if (ipack >= 5) {
01532 
01533 /*           'B' -- The lower triangle is packed as a band matrix. */
01534 /*           'Q' -- The upper triangle is packed as a band matrix. */
01535 /*           'Z' -- The whole matrix is packed as a band matrix. */
01536 
01537             if (ipack == 5) {
01538                 uub = 0;
01539             }
01540             if (ipack == 6) {
01541                 llb = 0;
01542             }
01543 
01544             i__1 = uub;
01545             for (j = 1; j <= i__1; ++j) {
01546 /* Computing MIN */
01547                 i__2 = j + llb;
01548                 for (i__ = min(i__2,*m); i__ >= 1; --i__) {
01549                     i__2 = i__ - j + uub + 1 + j * a_dim1;
01550                     i__4 = i__ + j * a_dim1;
01551                     a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i;
01552 /* L440: */
01553                 }
01554 /* L450: */
01555             }
01556 
01557             i__1 = *n;
01558             for (j = uub + 2; j <= i__1; ++j) {
01559 /* Computing MIN */
01560                 i__4 = j + llb;
01561                 i__2 = min(i__4,*m);
01562                 for (i__ = j - uub; i__ <= i__2; ++i__) {
01563                     i__4 = i__ - j + uub + 1 + j * a_dim1;
01564                     i__3 = i__ + j * a_dim1;
01565                     a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i;
01566 /* L460: */
01567                 }
01568 /* L470: */
01569             }
01570         }
01571 
01572 /*        If packed, zero out extraneous elements. */
01573 
01574 /*        Symmetric/Triangular Packed -- */
01575 /*        zero out everything after A(IROW,ICOL) */
01576 
01577         if (ipack == 3 || ipack == 4) {
01578             i__1 = *m;
01579             for (jc = icol; jc <= i__1; ++jc) {
01580                 i__2 = *lda;
01581                 for (jr = irow + 1; jr <= i__2; ++jr) {
01582                     i__4 = jr + jc * a_dim1;
01583                     a[i__4].r = 0.f, a[i__4].i = 0.f;
01584 /* L480: */
01585                 }
01586                 irow = 0;
01587 /* L490: */
01588             }
01589 
01590         } else if (ipack >= 5) {
01591 
01592 /*           Packed Band -- */
01593 /*              1st row is now in A( UUB+2-j, j), zero above it */
01594 /*              m-th row is now in A( M+UUB-j,j), zero below it */
01595 /*              last non-zero diagonal is now in A( UUB+LLB+1,j ), */
01596 /*                 zero below it, too. */
01597 
01598             ir1 = uub + llb + 2;
01599             ir2 = uub + *m + 2;
01600             i__1 = *n;
01601             for (jc = 1; jc <= i__1; ++jc) {
01602                 i__2 = uub + 1 - jc;
01603                 for (jr = 1; jr <= i__2; ++jr) {
01604                     i__4 = jr + jc * a_dim1;
01605                     a[i__4].r = 0.f, a[i__4].i = 0.f;
01606 /* L500: */
01607                 }
01608 /* Computing MAX */
01609 /* Computing MIN */
01610                 i__3 = ir1, i__5 = ir2 - jc;
01611                 i__2 = 1, i__4 = min(i__3,i__5);
01612                 i__6 = *lda;
01613                 for (jr = max(i__2,i__4); jr <= i__6; ++jr) {
01614                     i__2 = jr + jc * a_dim1;
01615                     a[i__2].r = 0.f, a[i__2].i = 0.f;
01616 /* L510: */
01617                 }
01618 /* L520: */
01619             }
01620         }
01621     }
01622 
01623     return 0;
01624 
01625 /*     End of CLATMS */
01626 
01627 } /* clatms_ */


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:55:32