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


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