clattb.c
Go to the documentation of this file.
00001 /* clattb.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 integer c__5 = 5;
00019 static integer c__2 = 2;
00020 static integer c__1 = 1;
00021 static integer c__4 = 4;
00022 static real c_b91 = 2.f;
00023 static integer c_n1 = -1;
00024 
00025 /* Subroutine */ int clattb_(integer *imat, char *uplo, char *trans, char *
00026         diag, integer *iseed, integer *n, integer *kd, complex *ab, integer *
00027         ldab, complex *b, complex *work, real *rwork, integer *info)
00028 {
00029     /* System generated locals */
00030     integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
00031     real r__1;
00032     doublereal d__1, d__2;
00033     complex q__1, q__2;
00034 
00035     /* Builtin functions */
00036     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00037     double sqrt(doublereal);
00038     void c_div(complex *, complex *, complex *);
00039     double pow_dd(doublereal *, doublereal *), c_abs(complex *);
00040 
00041     /* Local variables */
00042     integer i__, j, kl, ku, iy;
00043     real ulp, sfac;
00044     integer ioff, mode, lenj;
00045     char path[3], dist[1];
00046     real unfl, rexp;
00047     char type__[1];
00048     real texp;
00049     complex star1, plus1, plus2;
00050     real bscal;
00051     extern logical lsame_(char *, char *);
00052     real tscal, anorm, bnorm, tleft;
00053     extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, 
00054             complex *, integer *), cswap_(integer *, complex *, integer *, 
00055             complex *, integer *);
00056     logical upper;
00057     real tnorm;
00058     extern /* Subroutine */ int clatb4_(char *, integer *, integer *, integer 
00059             *, char *, integer *, integer *, real *, integer *, real *, char *
00060 ), slabad_(real *, real *);
00061     extern integer icamax_(integer *, complex *, integer *);
00062     extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
00063     extern doublereal slamch_(char *);
00064     extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer 
00065             *);
00066     char packit[1];
00067     real bignum;
00068     extern doublereal slarnd_(integer *, integer *);
00069     real cndnum;
00070     extern /* Subroutine */ int clarnv_(integer *, integer *, integer *, 
00071             complex *), clatms_(integer *, integer *, char *, integer *, char 
00072             *, real *, integer *, real *, real *, integer *, integer *, char *
00073 , complex *, integer *, complex *, integer *);
00074     integer jcount;
00075     extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real 
00076             *);
00077     real smlnum;
00078 
00079 
00080 /*  -- LAPACK test routine (version 3.1) -- */
00081 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00082 /*     November 2006 */
00083 
00084 /*     .. Scalar Arguments .. */
00085 /*     .. */
00086 /*     .. Array Arguments .. */
00087 /*     .. */
00088 
00089 /*  Purpose */
00090 /*  ======= */
00091 
00092 /*  CLATTB generates a triangular test matrix in 2-dimensional storage. */
00093 /*  IMAT and UPLO uniquely specify the properties of the test matrix, */
00094 /*  which is returned in the array A. */
00095 
00096 /*  Arguments */
00097 /*  ========= */
00098 
00099 /*  IMAT    (input) INTEGER */
00100 /*          An integer key describing which matrix to generate for this */
00101 /*          path. */
00102 
00103 /*  UPLO    (input) CHARACTER*1 */
00104 /*          Specifies whether the matrix A will be upper or lower */
00105 /*          triangular. */
00106 /*          = 'U':  Upper triangular */
00107 /*          = 'L':  Lower triangular */
00108 
00109 /*  TRANS   (input) CHARACTER*1 */
00110 /*          Specifies whether the matrix or its transpose will be used. */
00111 /*          = 'N':  No transpose */
00112 /*          = 'T':  Transpose */
00113 /*          = 'C':  Conjugate transpose (= transpose) */
00114 
00115 /*  DIAG    (output) CHARACTER*1 */
00116 /*          Specifies whether or not the matrix A is unit triangular. */
00117 /*          = 'N':  Non-unit triangular */
00118 /*          = 'U':  Unit triangular */
00119 
00120 /*  ISEED   (input/output) INTEGER array, dimension (4) */
00121 /*          The seed vector for the random number generator (used in */
00122 /*          CLATMS).  Modified on exit. */
00123 
00124 /*  N       (input) INTEGER */
00125 /*          The order of the matrix to be generated. */
00126 
00127 /*  KD      (input) INTEGER */
00128 /*          The number of superdiagonals or subdiagonals of the banded */
00129 /*          triangular matrix A.  KD >= 0. */
00130 
00131 /*  AB      (output) COMPLEX array, dimension (LDAB,N) */
00132 /*          The upper or lower triangular banded matrix A, stored in the */
00133 /*          first KD+1 rows of AB.  Let j be a column of A, 1<=j<=n. */
00134 /*          If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j. */
00135 /*          If UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd). */
00136 
00137 /*  LDAB    (input) INTEGER */
00138 /*          The leading dimension of the array AB.  LDAB >= KD+1. */
00139 
00140 /*  B       (workspace) COMPLEX array, dimension (N) */
00141 
00142 /*  WORK    (workspace) COMPLEX array, dimension (2*N) */
00143 
00144 /*  RWORK   (workspace) REAL array, dimension (N) */
00145 
00146 /*  INFO    (output) INTEGER */
00147 /*          = 0:  successful exit */
00148 /*          < 0:  if INFO = -i, the i-th argument had an illegal value */
00149 
00150 /*  ===================================================================== */
00151 
00152 /*     .. Parameters .. */
00153 /*     .. */
00154 /*     .. Local Scalars .. */
00155 /*     .. */
00156 /*     .. External Functions .. */
00157 /*     .. */
00158 /*     .. External Subroutines .. */
00159 /*     .. */
00160 /*     .. Intrinsic Functions .. */
00161 /*     .. */
00162 /*     .. Executable Statements .. */
00163 
00164     /* Parameter adjustments */
00165     --iseed;
00166     ab_dim1 = *ldab;
00167     ab_offset = 1 + ab_dim1;
00168     ab -= ab_offset;
00169     --b;
00170     --work;
00171     --rwork;
00172 
00173     /* Function Body */
00174     s_copy(path, "Complex precision", (ftnlen)1, (ftnlen)17);
00175     s_copy(path + 1, "TB", (ftnlen)2, (ftnlen)2);
00176     unfl = slamch_("Safe minimum");
00177     ulp = slamch_("Epsilon") * slamch_("Base");
00178     smlnum = unfl;
00179     bignum = (1.f - ulp) / smlnum;
00180     slabad_(&smlnum, &bignum);
00181     if (*imat >= 6 && *imat <= 9 || *imat == 17) {
00182         *(unsigned char *)diag = 'U';
00183     } else {
00184         *(unsigned char *)diag = 'N';
00185     }
00186     *info = 0;
00187 
00188 /*     Quick return if N.LE.0. */
00189 
00190     if (*n <= 0) {
00191         return 0;
00192     }
00193 
00194 /*     Call CLATB4 to set parameters for CLATMS. */
00195 
00196     upper = lsame_(uplo, "U");
00197     if (upper) {
00198         clatb4_(path, imat, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum, 
00199                 dist);
00200         ku = *kd;
00201 /* Computing MAX */
00202         i__1 = 0, i__2 = *kd - *n + 1;
00203         ioff = max(i__1,i__2) + 1;
00204         kl = 0;
00205         *(unsigned char *)packit = 'Q';
00206     } else {
00207         i__1 = -(*imat);
00208         clatb4_(path, &i__1, n, n, type__, &kl, &ku, &anorm, &mode, &cndnum, 
00209                 dist);
00210         kl = *kd;
00211         ioff = 1;
00212         ku = 0;
00213         *(unsigned char *)packit = 'B';
00214     }
00215 
00216 /*     IMAT <= 5:  Non-unit triangular matrix */
00217 
00218     if (*imat <= 5) {
00219         clatms_(n, n, dist, &iseed[1], type__, &rwork[1], &mode, &cndnum, &
00220                 anorm, &kl, &ku, packit, &ab[ioff + ab_dim1], ldab, &work[1], 
00221                 info);
00222 
00223 /*     IMAT > 5:  Unit triangular matrix */
00224 /*     The diagonal is deliberately set to something other than 1. */
00225 
00226 /*     IMAT = 6:  Matrix is the identity */
00227 
00228     } else if (*imat == 6) {
00229         if (upper) {
00230             i__1 = *n;
00231             for (j = 1; j <= i__1; ++j) {
00232 /* Computing MAX */
00233                 i__2 = 1, i__3 = *kd + 2 - j;
00234                 i__4 = *kd;
00235                 for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
00236                     i__2 = i__ + j * ab_dim1;
00237                     ab[i__2].r = 0.f, ab[i__2].i = 0.f;
00238 /* L10: */
00239                 }
00240                 i__4 = *kd + 1 + j * ab_dim1;
00241                 ab[i__4].r = (real) j, ab[i__4].i = 0.f;
00242 /* L20: */
00243             }
00244         } else {
00245             i__1 = *n;
00246             for (j = 1; j <= i__1; ++j) {
00247                 i__4 = j * ab_dim1 + 1;
00248                 ab[i__4].r = (real) j, ab[i__4].i = 0.f;
00249 /* Computing MIN */
00250                 i__2 = *kd + 1, i__3 = *n - j + 1;
00251                 i__4 = min(i__2,i__3);
00252                 for (i__ = 2; i__ <= i__4; ++i__) {
00253                     i__2 = i__ + j * ab_dim1;
00254                     ab[i__2].r = 0.f, ab[i__2].i = 0.f;
00255 /* L30: */
00256                 }
00257 /* L40: */
00258             }
00259         }
00260 
00261 /*     IMAT > 6:  Non-trivial unit triangular matrix */
00262 
00263 /*     A unit triangular matrix T with condition CNDNUM is formed. */
00264 /*     In this version, T only has bandwidth 2, the rest of it is zero. */
00265 
00266     } else if (*imat <= 9) {
00267         tnorm = sqrt(cndnum);
00268 
00269 /*        Initialize AB to zero. */
00270 
00271         if (upper) {
00272             i__1 = *n;
00273             for (j = 1; j <= i__1; ++j) {
00274 /* Computing MAX */
00275                 i__4 = 1, i__2 = *kd + 2 - j;
00276                 i__3 = *kd;
00277                 for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
00278                     i__4 = i__ + j * ab_dim1;
00279                     ab[i__4].r = 0.f, ab[i__4].i = 0.f;
00280 /* L50: */
00281                 }
00282                 i__3 = *kd + 1 + j * ab_dim1;
00283                 r__1 = (real) j;
00284                 ab[i__3].r = r__1, ab[i__3].i = 0.f;
00285 /* L60: */
00286             }
00287         } else {
00288             i__1 = *n;
00289             for (j = 1; j <= i__1; ++j) {
00290 /* Computing MIN */
00291                 i__4 = *kd + 1, i__2 = *n - j + 1;
00292                 i__3 = min(i__4,i__2);
00293                 for (i__ = 2; i__ <= i__3; ++i__) {
00294                     i__4 = i__ + j * ab_dim1;
00295                     ab[i__4].r = 0.f, ab[i__4].i = 0.f;
00296 /* L70: */
00297                 }
00298                 i__3 = j * ab_dim1 + 1;
00299                 r__1 = (real) j;
00300                 ab[i__3].r = r__1, ab[i__3].i = 0.f;
00301 /* L80: */
00302             }
00303         }
00304 
00305 /*        Special case:  T is tridiagonal.  Set every other offdiagonal */
00306 /*        so that the matrix has norm TNORM+1. */
00307 
00308         if (*kd == 1) {
00309             if (upper) {
00310                 i__1 = (ab_dim1 << 1) + 1;
00311                 clarnd_(&q__2, &c__5, &iseed[1]);
00312                 q__1.r = tnorm * q__2.r, q__1.i = tnorm * q__2.i;
00313                 ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
00314                 lenj = (*n - 3) / 2;
00315                 clarnv_(&c__2, &iseed[1], &lenj, &work[1]);
00316                 i__1 = lenj;
00317                 for (j = 1; j <= i__1; ++j) {
00318                     i__3 = (j + 1 << 1) * ab_dim1 + 1;
00319                     i__4 = j;
00320                     q__1.r = tnorm * work[i__4].r, q__1.i = tnorm * work[i__4]
00321                             .i;
00322                     ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
00323 /* L90: */
00324                 }
00325             } else {
00326                 i__1 = ab_dim1 + 2;
00327                 clarnd_(&q__2, &c__5, &iseed[1]);
00328                 q__1.r = tnorm * q__2.r, q__1.i = tnorm * q__2.i;
00329                 ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
00330                 lenj = (*n - 3) / 2;
00331                 clarnv_(&c__2, &iseed[1], &lenj, &work[1]);
00332                 i__1 = lenj;
00333                 for (j = 1; j <= i__1; ++j) {
00334                     i__3 = ((j << 1) + 1) * ab_dim1 + 2;
00335                     i__4 = j;
00336                     q__1.r = tnorm * work[i__4].r, q__1.i = tnorm * work[i__4]
00337                             .i;
00338                     ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
00339 /* L100: */
00340                 }
00341             }
00342         } else if (*kd > 1) {
00343 
00344 /*           Form a unit triangular matrix T with condition CNDNUM.  T is */
00345 /*           given by */
00346 /*                   | 1   +   *                      | */
00347 /*                   |     1   +                      | */
00348 /*               T = |         1   +   *              | */
00349 /*                   |             1   +              | */
00350 /*                   |                 1   +   *      | */
00351 /*                   |                     1   +      | */
00352 /*                   |                          . . . | */
00353 /*        Each element marked with a '*' is formed by taking the product */
00354 /*        of the adjacent elements marked with '+'.  The '*'s can be */
00355 /*        chosen freely, and the '+'s are chosen so that the inverse of */
00356 /*        T will have elements of the same magnitude as T. */
00357 
00358 /*        The two offdiagonals of T are stored in WORK. */
00359 
00360             clarnd_(&q__2, &c__5, &iseed[1]);
00361             q__1.r = tnorm * q__2.r, q__1.i = tnorm * q__2.i;
00362             star1.r = q__1.r, star1.i = q__1.i;
00363             sfac = sqrt(tnorm);
00364             clarnd_(&q__2, &c__5, &iseed[1]);
00365             q__1.r = sfac * q__2.r, q__1.i = sfac * q__2.i;
00366             plus1.r = q__1.r, plus1.i = q__1.i;
00367             i__1 = *n;
00368             for (j = 1; j <= i__1; j += 2) {
00369                 c_div(&q__1, &star1, &plus1);
00370                 plus2.r = q__1.r, plus2.i = q__1.i;
00371                 i__3 = j;
00372                 work[i__3].r = plus1.r, work[i__3].i = plus1.i;
00373                 i__3 = *n + j;
00374                 work[i__3].r = star1.r, work[i__3].i = star1.i;
00375                 if (j + 1 <= *n) {
00376                     i__3 = j + 1;
00377                     work[i__3].r = plus2.r, work[i__3].i = plus2.i;
00378                     i__3 = *n + j + 1;
00379                     work[i__3].r = 0.f, work[i__3].i = 0.f;
00380                     c_div(&q__1, &star1, &plus2);
00381                     plus1.r = q__1.r, plus1.i = q__1.i;
00382 
00383 /*                 Generate a new *-value with norm between sqrt(TNORM) */
00384 /*                 and TNORM. */
00385 
00386                     rexp = slarnd_(&c__2, &iseed[1]);
00387                     if (rexp < 0.f) {
00388                         d__1 = (doublereal) sfac;
00389                         d__2 = (doublereal) (1.f - rexp);
00390                         r__1 = -pow_dd(&d__1, &d__2);
00391                         clarnd_(&q__2, &c__5, &iseed[1]);
00392                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
00393                         star1.r = q__1.r, star1.i = q__1.i;
00394                     } else {
00395                         d__1 = (doublereal) sfac;
00396                         d__2 = (doublereal) (rexp + 1.f);
00397                         r__1 = pow_dd(&d__1, &d__2);
00398                         clarnd_(&q__2, &c__5, &iseed[1]);
00399                         q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
00400                         star1.r = q__1.r, star1.i = q__1.i;
00401                     }
00402                 }
00403 /* L110: */
00404             }
00405 
00406 /*           Copy the tridiagonal T to AB. */
00407 
00408             if (upper) {
00409                 i__1 = *n - 1;
00410                 ccopy_(&i__1, &work[1], &c__1, &ab[*kd + (ab_dim1 << 1)], 
00411                         ldab);
00412                 i__1 = *n - 2;
00413                 ccopy_(&i__1, &work[*n + 1], &c__1, &ab[*kd - 1 + ab_dim1 * 3]
00414 , ldab);
00415             } else {
00416                 i__1 = *n - 1;
00417                 ccopy_(&i__1, &work[1], &c__1, &ab[ab_dim1 + 2], ldab);
00418                 i__1 = *n - 2;
00419                 ccopy_(&i__1, &work[*n + 1], &c__1, &ab[ab_dim1 + 3], ldab);
00420             }
00421         }
00422 
00423 /*     IMAT > 9:  Pathological test cases.  These triangular matrices */
00424 /*     are badly scaled or badly conditioned, so when used in solving a */
00425 /*     triangular system they may cause overflow in the solution vector. */
00426 
00427     } else if (*imat == 10) {
00428 
00429 /*        Type 10:  Generate a triangular matrix with elements between */
00430 /*        -1 and 1. Give the diagonal norm 2 to make it well-conditioned. */
00431 /*        Make the right hand side large so that it requires scaling. */
00432 
00433         if (upper) {
00434             i__1 = *n;
00435             for (j = 1; j <= i__1; ++j) {
00436 /* Computing MIN */
00437                 i__3 = j - 1;
00438                 lenj = min(i__3,*kd);
00439                 clarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 1 - lenj + j * 
00440                         ab_dim1]);
00441                 i__3 = *kd + 1 + j * ab_dim1;
00442                 clarnd_(&q__2, &c__5, &iseed[1]);
00443                 q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
00444                 ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
00445 /* L120: */
00446             }
00447         } else {
00448             i__1 = *n;
00449             for (j = 1; j <= i__1; ++j) {
00450 /* Computing MIN */
00451                 i__3 = *n - j;
00452                 lenj = min(i__3,*kd);
00453                 if (lenj > 0) {
00454                     clarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
00455                 }
00456                 i__3 = j * ab_dim1 + 1;
00457                 clarnd_(&q__2, &c__5, &iseed[1]);
00458                 q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
00459                 ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
00460 /* L130: */
00461             }
00462         }
00463 
00464 /*        Set the right hand side so that the largest value is BIGNUM. */
00465 
00466         clarnv_(&c__2, &iseed[1], n, &b[1]);
00467         iy = icamax_(n, &b[1], &c__1);
00468         bnorm = c_abs(&b[iy]);
00469         bscal = bignum / dmax(1.f,bnorm);
00470         csscal_(n, &bscal, &b[1], &c__1);
00471 
00472     } else if (*imat == 11) {
00473 
00474 /*        Type 11:  Make the first diagonal element in the solve small to */
00475 /*        cause immediate overflow when dividing by T(j,j). */
00476 /*        In type 11, the offdiagonal elements are small (CNORM(j) < 1). */
00477 
00478         clarnv_(&c__2, &iseed[1], n, &b[1]);
00479         tscal = 1.f / (real) (*kd + 1);
00480         if (upper) {
00481             i__1 = *n;
00482             for (j = 1; j <= i__1; ++j) {
00483 /* Computing MIN */
00484                 i__3 = j - 1;
00485                 lenj = min(i__3,*kd);
00486                 if (lenj > 0) {
00487                     clarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j * 
00488                             ab_dim1]);
00489                     csscal_(&lenj, &tscal, &ab[*kd + 2 - lenj + j * ab_dim1], 
00490                             &c__1);
00491                 }
00492                 i__3 = *kd + 1 + j * ab_dim1;
00493                 clarnd_(&q__1, &c__5, &iseed[1]);
00494                 ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
00495 /* L140: */
00496             }
00497             i__1 = *kd + 1 + *n * ab_dim1;
00498             i__3 = *kd + 1 + *n * ab_dim1;
00499             q__1.r = smlnum * ab[i__3].r, q__1.i = smlnum * ab[i__3].i;
00500             ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
00501         } else {
00502             i__1 = *n;
00503             for (j = 1; j <= i__1; ++j) {
00504 /* Computing MIN */
00505                 i__3 = *n - j;
00506                 lenj = min(i__3,*kd);
00507                 if (lenj > 0) {
00508                     clarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
00509                     csscal_(&lenj, &tscal, &ab[j * ab_dim1 + 2], &c__1);
00510                 }
00511                 i__3 = j * ab_dim1 + 1;
00512                 clarnd_(&q__1, &c__5, &iseed[1]);
00513                 ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
00514 /* L150: */
00515             }
00516             i__1 = ab_dim1 + 1;
00517             i__3 = ab_dim1 + 1;
00518             q__1.r = smlnum * ab[i__3].r, q__1.i = smlnum * ab[i__3].i;
00519             ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
00520         }
00521 
00522     } else if (*imat == 12) {
00523 
00524 /*        Type 12:  Make the first diagonal element in the solve small to */
00525 /*        cause immediate overflow when dividing by T(j,j). */
00526 /*        In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1). */
00527 
00528         clarnv_(&c__2, &iseed[1], n, &b[1]);
00529         if (upper) {
00530             i__1 = *n;
00531             for (j = 1; j <= i__1; ++j) {
00532 /* Computing MIN */
00533                 i__3 = j - 1;
00534                 lenj = min(i__3,*kd);
00535                 if (lenj > 0) {
00536                     clarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j * 
00537                             ab_dim1]);
00538                 }
00539                 i__3 = *kd + 1 + j * ab_dim1;
00540                 clarnd_(&q__1, &c__5, &iseed[1]);
00541                 ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
00542 /* L160: */
00543             }
00544             i__1 = *kd + 1 + *n * ab_dim1;
00545             i__3 = *kd + 1 + *n * ab_dim1;
00546             q__1.r = smlnum * ab[i__3].r, q__1.i = smlnum * ab[i__3].i;
00547             ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
00548         } else {
00549             i__1 = *n;
00550             for (j = 1; j <= i__1; ++j) {
00551 /* Computing MIN */
00552                 i__3 = *n - j;
00553                 lenj = min(i__3,*kd);
00554                 if (lenj > 0) {
00555                     clarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
00556                 }
00557                 i__3 = j * ab_dim1 + 1;
00558                 clarnd_(&q__1, &c__5, &iseed[1]);
00559                 ab[i__3].r = q__1.r, ab[i__3].i = q__1.i;
00560 /* L170: */
00561             }
00562             i__1 = ab_dim1 + 1;
00563             i__3 = ab_dim1 + 1;
00564             q__1.r = smlnum * ab[i__3].r, q__1.i = smlnum * ab[i__3].i;
00565             ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
00566         }
00567 
00568     } else if (*imat == 13) {
00569 
00570 /*        Type 13:  T is diagonal with small numbers on the diagonal to */
00571 /*        make the growth factor underflow, but a small right hand side */
00572 /*        chosen so that the solution does not overflow. */
00573 
00574         if (upper) {
00575             jcount = 1;
00576             for (j = *n; j >= 1; --j) {
00577 /* Computing MAX */
00578                 i__1 = 1, i__3 = *kd + 1 - (j - 1);
00579                 i__4 = *kd;
00580                 for (i__ = max(i__1,i__3); i__ <= i__4; ++i__) {
00581                     i__1 = i__ + j * ab_dim1;
00582                     ab[i__1].r = 0.f, ab[i__1].i = 0.f;
00583 /* L180: */
00584                 }
00585                 if (jcount <= 2) {
00586                     i__4 = *kd + 1 + j * ab_dim1;
00587                     clarnd_(&q__2, &c__5, &iseed[1]);
00588                     q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
00589                     ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
00590                 } else {
00591                     i__4 = *kd + 1 + j * ab_dim1;
00592                     clarnd_(&q__1, &c__5, &iseed[1]);
00593                     ab[i__4].r = q__1.r, ab[i__4].i = q__1.i;
00594                 }
00595                 ++jcount;
00596                 if (jcount > 4) {
00597                     jcount = 1;
00598                 }
00599 /* L190: */
00600             }
00601         } else {
00602             jcount = 1;
00603             i__4 = *n;
00604             for (j = 1; j <= i__4; ++j) {
00605 /* Computing MIN */
00606                 i__3 = *n - j + 1, i__2 = *kd + 1;
00607                 i__1 = min(i__3,i__2);
00608                 for (i__ = 2; i__ <= i__1; ++i__) {
00609                     i__3 = i__ + j * ab_dim1;
00610                     ab[i__3].r = 0.f, ab[i__3].i = 0.f;
00611 /* L200: */
00612                 }
00613                 if (jcount <= 2) {
00614                     i__1 = j * ab_dim1 + 1;
00615                     clarnd_(&q__2, &c__5, &iseed[1]);
00616                     q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
00617                     ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
00618                 } else {
00619                     i__1 = j * ab_dim1 + 1;
00620                     clarnd_(&q__1, &c__5, &iseed[1]);
00621                     ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
00622                 }
00623                 ++jcount;
00624                 if (jcount > 4) {
00625                     jcount = 1;
00626                 }
00627 /* L210: */
00628             }
00629         }
00630 
00631 /*        Set the right hand side alternately zero and small. */
00632 
00633         if (upper) {
00634             b[1].r = 0.f, b[1].i = 0.f;
00635             for (i__ = *n; i__ >= 2; i__ += -2) {
00636                 i__4 = i__;
00637                 b[i__4].r = 0.f, b[i__4].i = 0.f;
00638                 i__4 = i__ - 1;
00639                 clarnd_(&q__2, &c__5, &iseed[1]);
00640                 q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
00641                 b[i__4].r = q__1.r, b[i__4].i = q__1.i;
00642 /* L220: */
00643             }
00644         } else {
00645             i__4 = *n;
00646             b[i__4].r = 0.f, b[i__4].i = 0.f;
00647             i__4 = *n - 1;
00648             for (i__ = 1; i__ <= i__4; i__ += 2) {
00649                 i__1 = i__;
00650                 b[i__1].r = 0.f, b[i__1].i = 0.f;
00651                 i__1 = i__ + 1;
00652                 clarnd_(&q__2, &c__5, &iseed[1]);
00653                 q__1.r = smlnum * q__2.r, q__1.i = smlnum * q__2.i;
00654                 b[i__1].r = q__1.r, b[i__1].i = q__1.i;
00655 /* L230: */
00656             }
00657         }
00658 
00659     } else if (*imat == 14) {
00660 
00661 /*        Type 14:  Make the diagonal elements small to cause gradual */
00662 /*        overflow when dividing by T(j,j).  To control the amount of */
00663 /*        scaling needed, the matrix is bidiagonal. */
00664 
00665         texp = 1.f / (real) (*kd + 1);
00666         d__1 = (doublereal) smlnum;
00667         d__2 = (doublereal) texp;
00668         tscal = pow_dd(&d__1, &d__2);
00669         clarnv_(&c__4, &iseed[1], n, &b[1]);
00670         if (upper) {
00671             i__4 = *n;
00672             for (j = 1; j <= i__4; ++j) {
00673 /* Computing MAX */
00674                 i__1 = 1, i__3 = *kd + 2 - j;
00675                 i__2 = *kd;
00676                 for (i__ = max(i__1,i__3); i__ <= i__2; ++i__) {
00677                     i__1 = i__ + j * ab_dim1;
00678                     ab[i__1].r = 0.f, ab[i__1].i = 0.f;
00679 /* L240: */
00680                 }
00681                 if (j > 1 && *kd > 0) {
00682                     i__2 = *kd + j * ab_dim1;
00683                     ab[i__2].r = -1.f, ab[i__2].i = -1.f;
00684                 }
00685                 i__2 = *kd + 1 + j * ab_dim1;
00686                 clarnd_(&q__2, &c__5, &iseed[1]);
00687                 q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
00688                 ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
00689 /* L250: */
00690             }
00691             i__4 = *n;
00692             b[i__4].r = 1.f, b[i__4].i = 1.f;
00693         } else {
00694             i__4 = *n;
00695             for (j = 1; j <= i__4; ++j) {
00696 /* Computing MIN */
00697                 i__1 = *n - j + 1, i__3 = *kd + 1;
00698                 i__2 = min(i__1,i__3);
00699                 for (i__ = 3; i__ <= i__2; ++i__) {
00700                     i__1 = i__ + j * ab_dim1;
00701                     ab[i__1].r = 0.f, ab[i__1].i = 0.f;
00702 /* L260: */
00703                 }
00704                 if (j < *n && *kd > 0) {
00705                     i__2 = j * ab_dim1 + 2;
00706                     ab[i__2].r = -1.f, ab[i__2].i = -1.f;
00707                 }
00708                 i__2 = j * ab_dim1 + 1;
00709                 clarnd_(&q__2, &c__5, &iseed[1]);
00710                 q__1.r = tscal * q__2.r, q__1.i = tscal * q__2.i;
00711                 ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
00712 /* L270: */
00713             }
00714             b[1].r = 1.f, b[1].i = 1.f;
00715         }
00716 
00717     } else if (*imat == 15) {
00718 
00719 /*        Type 15:  One zero diagonal element. */
00720 
00721         iy = *n / 2 + 1;
00722         if (upper) {
00723             i__4 = *n;
00724             for (j = 1; j <= i__4; ++j) {
00725 /* Computing MIN */
00726                 i__2 = j, i__1 = *kd + 1;
00727                 lenj = min(i__2,i__1);
00728                 clarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j * 
00729                         ab_dim1]);
00730                 if (j != iy) {
00731                     i__2 = *kd + 1 + j * ab_dim1;
00732                     clarnd_(&q__2, &c__5, &iseed[1]);
00733                     q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
00734                     ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
00735                 } else {
00736                     i__2 = *kd + 1 + j * ab_dim1;
00737                     ab[i__2].r = 0.f, ab[i__2].i = 0.f;
00738                 }
00739 /* L280: */
00740             }
00741         } else {
00742             i__4 = *n;
00743             for (j = 1; j <= i__4; ++j) {
00744 /* Computing MIN */
00745                 i__2 = *n - j + 1, i__1 = *kd + 1;
00746                 lenj = min(i__2,i__1);
00747                 clarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
00748                 if (j != iy) {
00749                     i__2 = j * ab_dim1 + 1;
00750                     clarnd_(&q__2, &c__5, &iseed[1]);
00751                     q__1.r = q__2.r * 2.f, q__1.i = q__2.i * 2.f;
00752                     ab[i__2].r = q__1.r, ab[i__2].i = q__1.i;
00753                 } else {
00754                     i__2 = j * ab_dim1 + 1;
00755                     ab[i__2].r = 0.f, ab[i__2].i = 0.f;
00756                 }
00757 /* L290: */
00758             }
00759         }
00760         clarnv_(&c__2, &iseed[1], n, &b[1]);
00761         csscal_(n, &c_b91, &b[1], &c__1);
00762 
00763     } else if (*imat == 16) {
00764 
00765 /*        Type 16:  Make the offdiagonal elements large to cause overflow */
00766 /*        when adding a column of T.  In the non-transposed case, the */
00767 /*        matrix is constructed to cause overflow when adding a column in */
00768 /*        every other step. */
00769 
00770         tscal = unfl / ulp;
00771         tscal = (1.f - ulp) / tscal;
00772         i__4 = *n;
00773         for (j = 1; j <= i__4; ++j) {
00774             i__2 = *kd + 1;
00775             for (i__ = 1; i__ <= i__2; ++i__) {
00776                 i__1 = i__ + j * ab_dim1;
00777                 ab[i__1].r = 0.f, ab[i__1].i = 0.f;
00778 /* L300: */
00779             }
00780 /* L310: */
00781         }
00782         texp = 1.f;
00783         if (*kd > 0) {
00784             if (upper) {
00785                 i__4 = -(*kd);
00786                 for (j = *n; i__4 < 0 ? j >= 1 : j <= 1; j += i__4) {
00787 /* Computing MAX */
00788                     i__1 = 1, i__3 = j - *kd + 1;
00789                     i__2 = max(i__1,i__3);
00790                     for (i__ = j; i__ >= i__2; i__ += -2) {
00791                         i__1 = j - i__ + 1 + i__ * ab_dim1;
00792                         r__1 = -tscal / (real) (*kd + 2);
00793                         ab[i__1].r = r__1, ab[i__1].i = 0.f;
00794                         i__1 = *kd + 1 + i__ * ab_dim1;
00795                         ab[i__1].r = 1.f, ab[i__1].i = 0.f;
00796                         i__1 = i__;
00797                         r__1 = texp * (1.f - ulp);
00798                         b[i__1].r = r__1, b[i__1].i = 0.f;
00799 /* Computing MAX */
00800                         i__1 = 1, i__3 = j - *kd + 1;
00801                         if (i__ > max(i__1,i__3)) {
00802                             i__1 = j - i__ + 2 + (i__ - 1) * ab_dim1;
00803                             r__1 = -(tscal / (real) (*kd + 2)) / (real) (*kd 
00804                                     + 3);
00805                             ab[i__1].r = r__1, ab[i__1].i = 0.f;
00806                             i__1 = *kd + 1 + (i__ - 1) * ab_dim1;
00807                             ab[i__1].r = 1.f, ab[i__1].i = 0.f;
00808                             i__1 = i__ - 1;
00809                             r__1 = texp * (real) ((*kd + 1) * (*kd + 1) + *kd)
00810                                     ;
00811                             b[i__1].r = r__1, b[i__1].i = 0.f;
00812                         }
00813                         texp *= 2.f;
00814 /* L320: */
00815                     }
00816 /* Computing MAX */
00817                     i__1 = 1, i__3 = j - *kd + 1;
00818                     i__2 = max(i__1,i__3);
00819                     r__1 = (real) (*kd + 2) / (real) (*kd + 3) * tscal;
00820                     b[i__2].r = r__1, b[i__2].i = 0.f;
00821 /* L330: */
00822                 }
00823             } else {
00824                 i__4 = *n;
00825                 i__2 = *kd;
00826                 for (j = 1; i__2 < 0 ? j >= i__4 : j <= i__4; j += i__2) {
00827                     texp = 1.f;
00828 /* Computing MIN */
00829                     i__1 = *kd + 1, i__3 = *n - j + 1;
00830                     lenj = min(i__1,i__3);
00831 /* Computing MIN */
00832                     i__3 = *n, i__5 = j + *kd - 1;
00833                     i__1 = min(i__3,i__5);
00834                     for (i__ = j; i__ <= i__1; i__ += 2) {
00835                         i__3 = lenj - (i__ - j) + j * ab_dim1;
00836                         r__1 = -tscal / (real) (*kd + 2);
00837                         ab[i__3].r = r__1, ab[i__3].i = 0.f;
00838                         i__3 = j * ab_dim1 + 1;
00839                         ab[i__3].r = 1.f, ab[i__3].i = 0.f;
00840                         i__3 = j;
00841                         r__1 = texp * (1.f - ulp);
00842                         b[i__3].r = r__1, b[i__3].i = 0.f;
00843 /* Computing MIN */
00844                         i__3 = *n, i__5 = j + *kd - 1;
00845                         if (i__ < min(i__3,i__5)) {
00846                             i__3 = lenj - (i__ - j + 1) + (i__ + 1) * ab_dim1;
00847                             r__1 = -(tscal / (real) (*kd + 2)) / (real) (*kd 
00848                                     + 3);
00849                             ab[i__3].r = r__1, ab[i__3].i = 0.f;
00850                             i__3 = (i__ + 1) * ab_dim1 + 1;
00851                             ab[i__3].r = 1.f, ab[i__3].i = 0.f;
00852                             i__3 = i__ + 1;
00853                             r__1 = texp * (real) ((*kd + 1) * (*kd + 1) + *kd)
00854                                     ;
00855                             b[i__3].r = r__1, b[i__3].i = 0.f;
00856                         }
00857                         texp *= 2.f;
00858 /* L340: */
00859                     }
00860 /* Computing MIN */
00861                     i__3 = *n, i__5 = j + *kd - 1;
00862                     i__1 = min(i__3,i__5);
00863                     r__1 = (real) (*kd + 2) / (real) (*kd + 3) * tscal;
00864                     b[i__1].r = r__1, b[i__1].i = 0.f;
00865 /* L350: */
00866                 }
00867             }
00868         }
00869 
00870     } else if (*imat == 17) {
00871 
00872 /*        Type 17:  Generate a unit triangular matrix with elements */
00873 /*        between -1 and 1, and make the right hand side large so that it */
00874 /*        requires scaling. */
00875 
00876         if (upper) {
00877             i__2 = *n;
00878             for (j = 1; j <= i__2; ++j) {
00879 /* Computing MIN */
00880                 i__4 = j - 1;
00881                 lenj = min(i__4,*kd);
00882                 clarnv_(&c__4, &iseed[1], &lenj, &ab[*kd + 1 - lenj + j * 
00883                         ab_dim1]);
00884                 i__4 = *kd + 1 + j * ab_dim1;
00885                 r__1 = (real) j;
00886                 ab[i__4].r = r__1, ab[i__4].i = 0.f;
00887 /* L360: */
00888             }
00889         } else {
00890             i__2 = *n;
00891             for (j = 1; j <= i__2; ++j) {
00892 /* Computing MIN */
00893                 i__4 = *n - j;
00894                 lenj = min(i__4,*kd);
00895                 if (lenj > 0) {
00896                     clarnv_(&c__4, &iseed[1], &lenj, &ab[j * ab_dim1 + 2]);
00897                 }
00898                 i__4 = j * ab_dim1 + 1;
00899                 r__1 = (real) j;
00900                 ab[i__4].r = r__1, ab[i__4].i = 0.f;
00901 /* L370: */
00902             }
00903         }
00904 
00905 /*        Set the right hand side so that the largest value is BIGNUM. */
00906 
00907         clarnv_(&c__2, &iseed[1], n, &b[1]);
00908         iy = icamax_(n, &b[1], &c__1);
00909         bnorm = c_abs(&b[iy]);
00910         bscal = bignum / dmax(1.f,bnorm);
00911         csscal_(n, &bscal, &b[1], &c__1);
00912 
00913     } else if (*imat == 18) {
00914 
00915 /*        Type 18:  Generate a triangular matrix with elements between */
00916 /*        BIGNUM/(KD+1) and BIGNUM so that at least one of the column */
00917 /*        norms will exceed BIGNUM. */
00918 /*        1/3/91:  CLATBS no longer can handle this case */
00919 
00920         tleft = bignum / (real) (*kd + 1);
00921         tscal = bignum * ((real) (*kd + 1) / (real) (*kd + 2));
00922         if (upper) {
00923             i__2 = *n;
00924             for (j = 1; j <= i__2; ++j) {
00925 /* Computing MIN */
00926                 i__4 = j, i__1 = *kd + 1;
00927                 lenj = min(i__4,i__1);
00928                 clarnv_(&c__5, &iseed[1], &lenj, &ab[*kd + 2 - lenj + j * 
00929                         ab_dim1]);
00930                 slarnv_(&c__1, &iseed[1], &lenj, &rwork[*kd + 2 - lenj]);
00931                 i__4 = *kd + 1;
00932                 for (i__ = *kd + 2 - lenj; i__ <= i__4; ++i__) {
00933                     i__1 = i__ + j * ab_dim1;
00934                     i__3 = i__ + j * ab_dim1;
00935                     r__1 = tleft + rwork[i__] * tscal;
00936                     q__1.r = r__1 * ab[i__3].r, q__1.i = r__1 * ab[i__3].i;
00937                     ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
00938 /* L380: */
00939                 }
00940 /* L390: */
00941             }
00942         } else {
00943             i__2 = *n;
00944             for (j = 1; j <= i__2; ++j) {
00945 /* Computing MIN */
00946                 i__4 = *n - j + 1, i__1 = *kd + 1;
00947                 lenj = min(i__4,i__1);
00948                 clarnv_(&c__5, &iseed[1], &lenj, &ab[j * ab_dim1 + 1]);
00949                 slarnv_(&c__1, &iseed[1], &lenj, &rwork[1]);
00950                 i__4 = lenj;
00951                 for (i__ = 1; i__ <= i__4; ++i__) {
00952                     i__1 = i__ + j * ab_dim1;
00953                     i__3 = i__ + j * ab_dim1;
00954                     r__1 = tleft + rwork[i__] * tscal;
00955                     q__1.r = r__1 * ab[i__3].r, q__1.i = r__1 * ab[i__3].i;
00956                     ab[i__1].r = q__1.r, ab[i__1].i = q__1.i;
00957 /* L400: */
00958                 }
00959 /* L410: */
00960             }
00961         }
00962         clarnv_(&c__2, &iseed[1], n, &b[1]);
00963         csscal_(n, &c_b91, &b[1], &c__1);
00964     }
00965 
00966 /*     Flip the matrix if the transpose will be used. */
00967 
00968     if (! lsame_(trans, "N")) {
00969         if (upper) {
00970             i__2 = *n / 2;
00971             for (j = 1; j <= i__2; ++j) {
00972 /* Computing MIN */
00973                 i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
00974                 lenj = min(i__4,i__1);
00975                 i__4 = *ldab - 1;
00976                 cswap_(&lenj, &ab[*kd + 1 + j * ab_dim1], &i__4, &ab[*kd + 2 
00977                         - lenj + (*n - j + 1) * ab_dim1], &c_n1);
00978 /* L420: */
00979             }
00980         } else {
00981             i__2 = *n / 2;
00982             for (j = 1; j <= i__2; ++j) {
00983 /* Computing MIN */
00984                 i__4 = *n - (j << 1) + 1, i__1 = *kd + 1;
00985                 lenj = min(i__4,i__1);
00986                 i__4 = -(*ldab) + 1;
00987                 cswap_(&lenj, &ab[j * ab_dim1 + 1], &c__1, &ab[lenj + (*n - j 
00988                         + 2 - lenj) * ab_dim1], &i__4);
00989 /* L430: */
00990             }
00991         }
00992     }
00993 
00994     return 0;
00995 
00996 /*     End of CLATTB */
00997 
00998 } /* clattb_ */


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