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


swiftnav
Author(s):
autogenerated on Sat Jun 8 2019 18:56:42