dtpmv.c
Go to the documentation of this file.
00001 /* dtpmv.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 /* Subroutine */ int dtpmv_(char *uplo, char *trans, char *diag, integer *n, 
00017         doublereal *ap, doublereal *x, integer *incx)
00018 {
00019     /* System generated locals */
00020     integer i__1, i__2;
00021 
00022     /* Local variables */
00023     integer i__, j, k, kk, ix, jx, kx, info;
00024     doublereal temp;
00025     extern logical lsame_(char *, char *);
00026     extern /* Subroutine */ int xerbla_(char *, integer *);
00027     logical nounit;
00028 
00029 /*     .. Scalar Arguments .. */
00030 /*     .. */
00031 /*     .. Array Arguments .. */
00032 /*     .. */
00033 
00034 /*  Purpose */
00035 /*  ======= */
00036 
00037 /*  DTPMV  performs one of the matrix-vector operations */
00038 
00039 /*     x := A*x,   or   x := A'*x, */
00040 
00041 /*  where x is an n element vector and  A is an n by n unit, or non-unit, */
00042 /*  upper or lower triangular matrix, supplied in packed form. */
00043 
00044 /*  Arguments */
00045 /*  ========== */
00046 
00047 /*  UPLO   - CHARACTER*1. */
00048 /*           On entry, UPLO specifies whether the matrix is an upper or */
00049 /*           lower triangular matrix as follows: */
00050 
00051 /*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
00052 
00053 /*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
00054 
00055 /*           Unchanged on exit. */
00056 
00057 /*  TRANS  - CHARACTER*1. */
00058 /*           On entry, TRANS specifies the operation to be performed as */
00059 /*           follows: */
00060 
00061 /*              TRANS = 'N' or 'n'   x := A*x. */
00062 
00063 /*              TRANS = 'T' or 't'   x := A'*x. */
00064 
00065 /*              TRANS = 'C' or 'c'   x := A'*x. */
00066 
00067 /*           Unchanged on exit. */
00068 
00069 /*  DIAG   - CHARACTER*1. */
00070 /*           On entry, DIAG specifies whether or not A is unit */
00071 /*           triangular as follows: */
00072 
00073 /*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
00074 
00075 /*              DIAG = 'N' or 'n'   A is not assumed to be unit */
00076 /*                                  triangular. */
00077 
00078 /*           Unchanged on exit. */
00079 
00080 /*  N      - INTEGER. */
00081 /*           On entry, N specifies the order of the matrix A. */
00082 /*           N must be at least zero. */
00083 /*           Unchanged on exit. */
00084 
00085 /*  AP     - DOUBLE PRECISION array of DIMENSION at least */
00086 /*           ( ( n*( n + 1 ) )/2 ). */
00087 /*           Before entry with  UPLO = 'U' or 'u', the array AP must */
00088 /*           contain the upper triangular matrix packed sequentially, */
00089 /*           column by column, so that AP( 1 ) contains a( 1, 1 ), */
00090 /*           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
00091 /*           respectively, and so on. */
00092 /*           Before entry with UPLO = 'L' or 'l', the array AP must */
00093 /*           contain the lower triangular matrix packed sequentially, */
00094 /*           column by column, so that AP( 1 ) contains a( 1, 1 ), */
00095 /*           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
00096 /*           respectively, and so on. */
00097 /*           Note that when  DIAG = 'U' or 'u', the diagonal elements of */
00098 /*           A are not referenced, but are assumed to be unity. */
00099 /*           Unchanged on exit. */
00100 
00101 /*  X      - DOUBLE PRECISION array of dimension at least */
00102 /*           ( 1 + ( n - 1 )*abs( INCX ) ). */
00103 /*           Before entry, the incremented array X must contain the n */
00104 /*           element vector x. On exit, X is overwritten with the */
00105 /*           tranformed vector x. */
00106 
00107 /*  INCX   - INTEGER. */
00108 /*           On entry, INCX specifies the increment for the elements of */
00109 /*           X. INCX must not be zero. */
00110 /*           Unchanged on exit. */
00111 
00112 
00113 /*  Level 2 Blas routine. */
00114 
00115 /*  -- Written on 22-October-1986. */
00116 /*     Jack Dongarra, Argonne National Lab. */
00117 /*     Jeremy Du Croz, Nag Central Office. */
00118 /*     Sven Hammarling, Nag Central Office. */
00119 /*     Richard Hanson, Sandia National Labs. */
00120 
00121 
00122 /*     .. Parameters .. */
00123 /*     .. */
00124 /*     .. Local Scalars .. */
00125 /*     .. */
00126 /*     .. External Functions .. */
00127 /*     .. */
00128 /*     .. External Subroutines .. */
00129 /*     .. */
00130 
00131 /*     Test the input parameters. */
00132 
00133     /* Parameter adjustments */
00134     --x;
00135     --ap;
00136 
00137     /* Function Body */
00138     info = 0;
00139     if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
00140         info = 1;
00141     } else if (! lsame_(trans, "N") && ! lsame_(trans, 
00142             "T") && ! lsame_(trans, "C")) {
00143         info = 2;
00144     } else if (! lsame_(diag, "U") && ! lsame_(diag, 
00145             "N")) {
00146         info = 3;
00147     } else if (*n < 0) {
00148         info = 4;
00149     } else if (*incx == 0) {
00150         info = 7;
00151     }
00152     if (info != 0) {
00153         xerbla_("DTPMV ", &info);
00154         return 0;
00155     }
00156 
00157 /*     Quick return if possible. */
00158 
00159     if (*n == 0) {
00160         return 0;
00161     }
00162 
00163     nounit = lsame_(diag, "N");
00164 
00165 /*     Set up the start point in X if the increment is not unity. This */
00166 /*     will be  ( N - 1 )*INCX  too small for descending loops. */
00167 
00168     if (*incx <= 0) {
00169         kx = 1 - (*n - 1) * *incx;
00170     } else if (*incx != 1) {
00171         kx = 1;
00172     }
00173 
00174 /*     Start the operations. In this version the elements of AP are */
00175 /*     accessed sequentially with one pass through AP. */
00176 
00177     if (lsame_(trans, "N")) {
00178 
00179 /*        Form  x:= A*x. */
00180 
00181         if (lsame_(uplo, "U")) {
00182             kk = 1;
00183             if (*incx == 1) {
00184                 i__1 = *n;
00185                 for (j = 1; j <= i__1; ++j) {
00186                     if (x[j] != 0.) {
00187                         temp = x[j];
00188                         k = kk;
00189                         i__2 = j - 1;
00190                         for (i__ = 1; i__ <= i__2; ++i__) {
00191                             x[i__] += temp * ap[k];
00192                             ++k;
00193 /* L10: */
00194                         }
00195                         if (nounit) {
00196                             x[j] *= ap[kk + j - 1];
00197                         }
00198                     }
00199                     kk += j;
00200 /* L20: */
00201                 }
00202             } else {
00203                 jx = kx;
00204                 i__1 = *n;
00205                 for (j = 1; j <= i__1; ++j) {
00206                     if (x[jx] != 0.) {
00207                         temp = x[jx];
00208                         ix = kx;
00209                         i__2 = kk + j - 2;
00210                         for (k = kk; k <= i__2; ++k) {
00211                             x[ix] += temp * ap[k];
00212                             ix += *incx;
00213 /* L30: */
00214                         }
00215                         if (nounit) {
00216                             x[jx] *= ap[kk + j - 1];
00217                         }
00218                     }
00219                     jx += *incx;
00220                     kk += j;
00221 /* L40: */
00222                 }
00223             }
00224         } else {
00225             kk = *n * (*n + 1) / 2;
00226             if (*incx == 1) {
00227                 for (j = *n; j >= 1; --j) {
00228                     if (x[j] != 0.) {
00229                         temp = x[j];
00230                         k = kk;
00231                         i__1 = j + 1;
00232                         for (i__ = *n; i__ >= i__1; --i__) {
00233                             x[i__] += temp * ap[k];
00234                             --k;
00235 /* L50: */
00236                         }
00237                         if (nounit) {
00238                             x[j] *= ap[kk - *n + j];
00239                         }
00240                     }
00241                     kk -= *n - j + 1;
00242 /* L60: */
00243                 }
00244             } else {
00245                 kx += (*n - 1) * *incx;
00246                 jx = kx;
00247                 for (j = *n; j >= 1; --j) {
00248                     if (x[jx] != 0.) {
00249                         temp = x[jx];
00250                         ix = kx;
00251                         i__1 = kk - (*n - (j + 1));
00252                         for (k = kk; k >= i__1; --k) {
00253                             x[ix] += temp * ap[k];
00254                             ix -= *incx;
00255 /* L70: */
00256                         }
00257                         if (nounit) {
00258                             x[jx] *= ap[kk - *n + j];
00259                         }
00260                     }
00261                     jx -= *incx;
00262                     kk -= *n - j + 1;
00263 /* L80: */
00264                 }
00265             }
00266         }
00267     } else {
00268 
00269 /*        Form  x := A'*x. */
00270 
00271         if (lsame_(uplo, "U")) {
00272             kk = *n * (*n + 1) / 2;
00273             if (*incx == 1) {
00274                 for (j = *n; j >= 1; --j) {
00275                     temp = x[j];
00276                     if (nounit) {
00277                         temp *= ap[kk];
00278                     }
00279                     k = kk - 1;
00280                     for (i__ = j - 1; i__ >= 1; --i__) {
00281                         temp += ap[k] * x[i__];
00282                         --k;
00283 /* L90: */
00284                     }
00285                     x[j] = temp;
00286                     kk -= j;
00287 /* L100: */
00288                 }
00289             } else {
00290                 jx = kx + (*n - 1) * *incx;
00291                 for (j = *n; j >= 1; --j) {
00292                     temp = x[jx];
00293                     ix = jx;
00294                     if (nounit) {
00295                         temp *= ap[kk];
00296                     }
00297                     i__1 = kk - j + 1;
00298                     for (k = kk - 1; k >= i__1; --k) {
00299                         ix -= *incx;
00300                         temp += ap[k] * x[ix];
00301 /* L110: */
00302                     }
00303                     x[jx] = temp;
00304                     jx -= *incx;
00305                     kk -= j;
00306 /* L120: */
00307                 }
00308             }
00309         } else {
00310             kk = 1;
00311             if (*incx == 1) {
00312                 i__1 = *n;
00313                 for (j = 1; j <= i__1; ++j) {
00314                     temp = x[j];
00315                     if (nounit) {
00316                         temp *= ap[kk];
00317                     }
00318                     k = kk + 1;
00319                     i__2 = *n;
00320                     for (i__ = j + 1; i__ <= i__2; ++i__) {
00321                         temp += ap[k] * x[i__];
00322                         ++k;
00323 /* L130: */
00324                     }
00325                     x[j] = temp;
00326                     kk += *n - j + 1;
00327 /* L140: */
00328                 }
00329             } else {
00330                 jx = kx;
00331                 i__1 = *n;
00332                 for (j = 1; j <= i__1; ++j) {
00333                     temp = x[jx];
00334                     ix = jx;
00335                     if (nounit) {
00336                         temp *= ap[kk];
00337                     }
00338                     i__2 = kk + *n - j;
00339                     for (k = kk + 1; k <= i__2; ++k) {
00340                         ix += *incx;
00341                         temp += ap[k] * x[ix];
00342 /* L150: */
00343                     }
00344                     x[jx] = temp;
00345                     jx += *incx;
00346                     kk += *n - j + 1;
00347 /* L160: */
00348                 }
00349             }
00350         }
00351     }
00352 
00353     return 0;
00354 
00355 /*     End of DTPMV . */
00356 
00357 } /* dtpmv_ */


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