zlarhs.c
Go to the documentation of this file.
00001 /* zlarhs.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 = {1.,0.};
00019 static doublecomplex c_b2 = {0.,0.};
00020 static integer c__2 = 2;
00021 static integer c__1 = 1;
00022 
00023 /* Subroutine */ int zlarhs_(char *path, char *xtype, char *uplo, char *trans, 
00024          integer *m, integer *n, integer *kl, integer *ku, integer *nrhs, 
00025         doublecomplex *a, integer *lda, doublecomplex *x, integer *ldx, 
00026         doublecomplex *b, integer *ldb, integer *iseed, integer *info)
00027 {
00028     /* System generated locals */
00029     integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
00030 
00031     /* Builtin functions */
00032     /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
00033 
00034     /* Local variables */
00035     integer j;
00036     char c1[1], c2[2];
00037     integer mb, nx;
00038     logical gen, tri, qrs, sym, band;
00039     char diag[1];
00040     logical tran;
00041     extern logical lsame_(char *, char *);
00042     extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, 
00043             integer *, doublecomplex *, doublecomplex *, integer *, 
00044             doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
00045             integer *), zhemm_(char *, char *, integer *, 
00046             integer *, doublecomplex *, doublecomplex *, integer *, 
00047             doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
00048             integer *), zgbmv_(char *, integer *, integer *, 
00049             integer *, integer *, doublecomplex *, doublecomplex *, integer *, 
00050              doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
00051             integer *), zhbmv_(char *, integer *, integer *, 
00052             doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
00053             integer *, doublecomplex *, doublecomplex *, integer *), 
00054             zsbmv_(char *, integer *, integer *, doublecomplex *, 
00055             doublecomplex *, integer *, doublecomplex *, integer *, 
00056             doublecomplex *, doublecomplex *, integer *), ztbmv_(char 
00057             *, char *, char *, integer *, integer *, doublecomplex *, integer 
00058             *, doublecomplex *, integer *), zhpmv_(
00059             char *, integer *, doublecomplex *, doublecomplex *, 
00060             doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
00061             integer *), ztrmm_(char *, char *, char *, char *, 
00062             integer *, integer *, doublecomplex *, doublecomplex *, integer *, 
00063              doublecomplex *, integer *), 
00064             zspmv_(char *, integer *, doublecomplex *, doublecomplex *, 
00065             doublecomplex *, integer *, doublecomplex *, doublecomplex *, 
00066             integer *), zsymm_(char *, char *, integer *, integer *, 
00067             doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
00068             integer *, doublecomplex *, doublecomplex *, integer *), ztpmv_(char *, char *, char *, integer *, doublecomplex *
00069 , doublecomplex *, integer *), xerbla_(
00070             char *, integer *);
00071     extern logical lsamen_(integer *, char *, char *);
00072     logical notran;
00073     extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, 
00074             doublecomplex *, integer *, doublecomplex *, integer *), 
00075             zlarnv_(integer *, integer *, integer *, doublecomplex *);
00076 
00077 
00078 /*  -- LAPACK test routine (version 3.1) -- */
00079 /*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
00080 /*     November 2006 */
00081 
00082 /*     .. Scalar Arguments .. */
00083 /*     .. */
00084 /*     .. Array Arguments .. */
00085 /*     .. */
00086 
00087 /*  Purpose */
00088 /*  ======= */
00089 
00090 /*  ZLARHS chooses a set of NRHS random solution vectors and sets */
00091 /*  up the right hand sides for the linear system */
00092 /*     op( A ) * X = B, */
00093 /*  where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */
00094 /*  transpose of A). */
00095 
00096 /*  Arguments */
00097 /*  ========= */
00098 
00099 /*  PATH    (input) CHARACTER*3 */
00100 /*          The type of the complex matrix A.  PATH may be given in any */
00101 /*          combination of upper and lower case.  Valid paths include */
00102 /*             xGE:  General m x n matrix */
00103 /*             xGB:  General banded matrix */
00104 /*             xPO:  Hermitian positive definite, 2-D storage */
00105 /*             xPP:  Hermitian positive definite packed */
00106 /*             xPB:  Hermitian positive definite banded */
00107 /*             xHE:  Hermitian indefinite, 2-D storage */
00108 /*             xHP:  Hermitian indefinite packed */
00109 /*             xHB:  Hermitian indefinite banded */
00110 /*             xSY:  Symmetric indefinite, 2-D storage */
00111 /*             xSP:  Symmetric indefinite packed */
00112 /*             xSB:  Symmetric indefinite banded */
00113 /*             xTR:  Triangular */
00114 /*             xTP:  Triangular packed */
00115 /*             xTB:  Triangular banded */
00116 /*             xQR:  General m x n matrix */
00117 /*             xLQ:  General m x n matrix */
00118 /*             xQL:  General m x n matrix */
00119 /*             xRQ:  General m x n matrix */
00120 /*          where the leading character indicates the precision. */
00121 
00122 /*  XTYPE   (input) CHARACTER*1 */
00123 /*          Specifies how the exact solution X will be determined: */
00124 /*          = 'N':  New solution; generate a random X. */
00125 /*          = 'C':  Computed; use value of X on entry. */
00126 
00127 /*  UPLO    (input) CHARACTER*1 */
00128 /*          Used only if A is symmetric or triangular; specifies whether */
00129 /*          the upper or lower triangular part of the matrix A is stored. */
00130 /*          = 'U':  Upper triangular */
00131 /*          = 'L':  Lower triangular */
00132 
00133 /*  TRANS   (input) CHARACTER*1 */
00134 /*          Used only if A is nonsymmetric; specifies the operation */
00135 /*          applied to the matrix A. */
00136 /*          = 'N':  B := A    * X */
00137 /*          = 'T':  B := A**T * X */
00138 /*          = 'C':  B := A**H * X */
00139 
00140 /*  M       (input) INTEGER */
00141 /*          The number of rows of the matrix A.  M >= 0. */
00142 
00143 /*  N       (input) INTEGER */
00144 /*          The number of columns of the matrix A.  N >= 0. */
00145 
00146 /*  KL      (input) INTEGER */
00147 /*          Used only if A is a band matrix; specifies the number of */
00148 /*          subdiagonals of A if A is a general band matrix or if A is */
00149 /*          symmetric or triangular and UPLO = 'L'; specifies the number */
00150 /*          of superdiagonals of A if A is symmetric or triangular and */
00151 /*          UPLO = 'U'.  0 <= KL <= M-1. */
00152 
00153 /*  KU      (input) INTEGER */
00154 /*          Used only if A is a general band matrix or if A is */
00155 /*          triangular. */
00156 
00157 /*          If PATH = xGB, specifies the number of superdiagonals of A, */
00158 /*          and 0 <= KU <= N-1. */
00159 
00160 /*          If PATH = xTR, xTP, or xTB, specifies whether or not the */
00161 /*          matrix has unit diagonal: */
00162 /*          = 1:  matrix has non-unit diagonal (default) */
00163 /*          = 2:  matrix has unit diagonal */
00164 
00165 /*  NRHS    (input) INTEGER */
00166 /*          The number of right hand side vectors in the system A*X = B. */
00167 
00168 /*  A       (input) COMPLEX*16 array, dimension (LDA,N) */
00169 /*          The test matrix whose type is given by PATH. */
00170 
00171 /*  LDA     (input) INTEGER */
00172 /*          The leading dimension of the array A. */
00173 /*          If PATH = xGB, LDA >= KL+KU+1. */
00174 /*          If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
00175 /*          Otherwise, LDA >= max(1,M). */
00176 
00177 /*  X       (input or output) COMPLEX*16  array, dimension (LDX,NRHS) */
00178 /*          On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
00179 /*          the exact solution to the system of linear equations. */
00180 /*          On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
00181 /*          with random values. */
00182 
00183 /*  LDX     (input) INTEGER */
00184 /*          The leading dimension of the array X.  If TRANS = 'N', */
00185 /*          LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
00186 
00187 /*  B       (output) COMPLEX*16  array, dimension (LDB,NRHS) */
00188 /*          The right hand side vector(s) for the system of equations, */
00189 /*          computed from B = op(A) * X, where op(A) is determined by */
00190 /*          TRANS. */
00191 
00192 /*  LDB     (input) INTEGER */
00193 /*          The leading dimension of the array B.  If TRANS = 'N', */
00194 /*          LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
00195 
00196 /*  ISEED   (input/output) INTEGER array, dimension (4) */
00197 /*          The seed vector for the random number generator (used in */
00198 /*          ZLATMS).  Modified on exit. */
00199 
00200 /*  INFO    (output) INTEGER */
00201 /*          = 0:  successful exit */
00202 /*          < 0:  if INFO = -i, the i-th argument had an illegal value */
00203 
00204 /*  ===================================================================== */
00205 
00206 /*     .. Parameters .. */
00207 /*     .. */
00208 /*     .. Local Scalars .. */
00209 /*     .. */
00210 /*     .. External Functions .. */
00211 /*     .. */
00212 /*     .. External Subroutines .. */
00213 /*     .. */
00214 /*     .. Intrinsic Functions .. */
00215 /*     .. */
00216 /*     .. Executable Statements .. */
00217 
00218 /*     Test the input parameters. */
00219 
00220     /* Parameter adjustments */
00221     a_dim1 = *lda;
00222     a_offset = 1 + a_dim1;
00223     a -= a_offset;
00224     x_dim1 = *ldx;
00225     x_offset = 1 + x_dim1;
00226     x -= x_offset;
00227     b_dim1 = *ldb;
00228     b_offset = 1 + b_dim1;
00229     b -= b_offset;
00230     --iseed;
00231 
00232     /* Function Body */
00233     *info = 0;
00234     *(unsigned char *)c1 = *(unsigned char *)path;
00235     s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
00236     tran = lsame_(trans, "T") || lsame_(trans, "C");
00237     notran = ! tran;
00238     gen = lsame_(path + 1, "G");
00239     qrs = lsame_(path + 1, "Q") || lsame_(path + 2, 
00240             "Q");
00241     sym = lsame_(path + 1, "P") || lsame_(path + 1, 
00242             "S") || lsame_(path + 1, "H");
00243     tri = lsame_(path + 1, "T");
00244     band = lsame_(path + 2, "B");
00245     if (! lsame_(c1, "Zomplex precision")) {
00246         *info = -1;
00247     } else if (! (lsame_(xtype, "N") || lsame_(xtype, 
00248             "C"))) {
00249         *info = -2;
00250     } else if ((sym || tri) && ! (lsame_(uplo, "U") || 
00251             lsame_(uplo, "L"))) {
00252         *info = -3;
00253     } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
00254         *info = -4;
00255     } else if (*m < 0) {
00256         *info = -5;
00257     } else if (*n < 0) {
00258         *info = -6;
00259     } else if (band && *kl < 0) {
00260         *info = -7;
00261     } else if (band && *ku < 0) {
00262         *info = -8;
00263     } else if (*nrhs < 0) {
00264         *info = -9;
00265     } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
00266             kl + 1 || band && gen && *lda < *kl + *ku + 1) {
00267         *info = -11;
00268     } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
00269         *info = -13;
00270     } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
00271         *info = -15;
00272     }
00273     if (*info != 0) {
00274         i__1 = -(*info);
00275         xerbla_("ZLARHS", &i__1);
00276         return 0;
00277     }
00278 
00279 /*     Initialize X to NRHS random vectors unless XTYPE = 'C'. */
00280 
00281     if (tran) {
00282         nx = *m;
00283         mb = *n;
00284     } else {
00285         nx = *n;
00286         mb = *m;
00287     }
00288     if (! lsame_(xtype, "C")) {
00289         i__1 = *nrhs;
00290         for (j = 1; j <= i__1; ++j) {
00291             zlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
00292 /* L10: */
00293         }
00294     }
00295 
00296 /*     Multiply X by op( A ) using an appropriate */
00297 /*     matrix multiply routine. */
00298 
00299     if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2, 
00300             "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") || 
00301             lsamen_(&c__2, c2, "RQ")) {
00302 
00303 /*        General matrix */
00304 
00305         zgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[
00306                 x_offset], ldx, &c_b2, &b[b_offset], ldb);
00307 
00308     } else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
00309             c__2, c2, "HE")) {
00310 
00311 /*        Hermitian matrix, 2-D storage */
00312 
00313         zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], 
00314                 ldx, &c_b2, &b[b_offset], ldb);
00315 
00316     } else if (lsamen_(&c__2, c2, "SY")) {
00317 
00318 /*        Symmetric matrix, 2-D storage */
00319 
00320         zsymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], 
00321                 ldx, &c_b2, &b[b_offset], ldb);
00322 
00323     } else if (lsamen_(&c__2, c2, "GB")) {
00324 
00325 /*        General matrix, band storage */
00326 
00327         i__1 = *nrhs;
00328         for (j = 1; j <= i__1; ++j) {
00329             zgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j * 
00330                     x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
00331 /* L20: */
00332         }
00333 
00334     } else if (lsamen_(&c__2, c2, "PB") || lsamen_(&
00335             c__2, c2, "HB")) {
00336 
00337 /*        Hermitian matrix, band storage */
00338 
00339         i__1 = *nrhs;
00340         for (j = 1; j <= i__1; ++j) {
00341             zhbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], 
00342                     &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
00343 /* L30: */
00344         }
00345 
00346     } else if (lsamen_(&c__2, c2, "SB")) {
00347 
00348 /*        Symmetric matrix, band storage */
00349 
00350         i__1 = *nrhs;
00351         for (j = 1; j <= i__1; ++j) {
00352             zsbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], 
00353                     &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1);
00354 /* L40: */
00355         }
00356 
00357     } else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
00358             c__2, c2, "HP")) {
00359 
00360 /*        Hermitian matrix, packed storage */
00361 
00362         i__1 = *nrhs;
00363         for (j = 1; j <= i__1; ++j) {
00364             zhpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
00365                     c_b2, &b[j * b_dim1 + 1], &c__1);
00366 /* L50: */
00367         }
00368 
00369     } else if (lsamen_(&c__2, c2, "SP")) {
00370 
00371 /*        Symmetric matrix, packed storage */
00372 
00373         i__1 = *nrhs;
00374         for (j = 1; j <= i__1; ++j) {
00375             zspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
00376                     c_b2, &b[j * b_dim1 + 1], &c__1);
00377 /* L60: */
00378         }
00379 
00380     } else if (lsamen_(&c__2, c2, "TR")) {
00381 
00382 /*        Triangular matrix.  Note that for triangular matrices, */
00383 /*           KU = 1 => non-unit triangular */
00384 /*           KU = 2 => unit triangular */
00385 
00386         zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
00387         if (*ku == 2) {
00388             *(unsigned char *)diag = 'U';
00389         } else {
00390             *(unsigned char *)diag = 'N';
00391         }
00392         ztrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, &
00393                 b[b_offset], ldb);
00394 
00395     } else if (lsamen_(&c__2, c2, "TP")) {
00396 
00397 /*        Triangular matrix, packed storage */
00398 
00399         zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
00400         if (*ku == 2) {
00401             *(unsigned char *)diag = 'U';
00402         } else {
00403             *(unsigned char *)diag = 'N';
00404         }
00405         i__1 = *nrhs;
00406         for (j = 1; j <= i__1; ++j) {
00407             ztpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
00408                     c__1);
00409 /* L70: */
00410         }
00411 
00412     } else if (lsamen_(&c__2, c2, "TB")) {
00413 
00414 /*        Triangular matrix, banded storage */
00415 
00416         zlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
00417         if (*ku == 2) {
00418             *(unsigned char *)diag = 'U';
00419         } else {
00420             *(unsigned char *)diag = 'N';
00421         }
00422         i__1 = *nrhs;
00423         for (j = 1; j <= i__1; ++j) {
00424             ztbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1 
00425                     + 1], &c__1);
00426 /* L80: */
00427         }
00428 
00429     } else {
00430 
00431 /*        If none of the above, set INFO = -1 and return */
00432 
00433         *info = -1;
00434         i__1 = -(*info);
00435         xerbla_("ZLARHS", &i__1);
00436     }
00437 
00438     return 0;
00439 
00440 /*     End of ZLARHS */
00441 
00442 } /* zlarhs_ */


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