template_blas_tpmv.h
Go to the documentation of this file.00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035 #ifndef TEMPLATE_BLAS_TPMV_HEADER
00036 #define TEMPLATE_BLAS_TPMV_HEADER
00037
00038
00039 template<class Treal>
00040 int template_blas_tpmv(const char *uplo, const char *trans, const char *diag, const integer *n,
00041 const Treal *ap, Treal *x, const integer *incx)
00042 {
00043
00044 integer i__1, i__2;
00045
00046 integer info;
00047 Treal temp;
00048 integer i__, j, k;
00049 integer kk, ix, jx, kx;
00050 logical nounit;
00051
00052
00053
00054
00055
00056
00057
00058
00059
00060
00061
00062
00063
00064
00065
00066
00067
00068
00069
00070
00071
00072
00073
00074
00075
00076
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086
00087
00088
00089
00090
00091
00092
00093
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115 --x;
00116 --ap;
00117
00118 kx = 0;
00119
00120 info = 0;
00121 if (! template_blas_lsame(uplo, "U") && ! template_blas_lsame(uplo, "L")) {
00122 info = 1;
00123 } else if (! template_blas_lsame(trans, "N") && ! template_blas_lsame(trans,
00124 "T") && ! template_blas_lsame(trans, "C")) {
00125 info = 2;
00126 } else if (! template_blas_lsame(diag, "U") && ! template_blas_lsame(diag,
00127 "N")) {
00128 info = 3;
00129 } else if (*n < 0) {
00130 info = 4;
00131 } else if (*incx == 0) {
00132 info = 7;
00133 }
00134 if (info != 0) {
00135 template_blas_erbla("TPMV ", &info);
00136 return 0;
00137 }
00138
00139 if (*n == 0) {
00140 return 0;
00141 }
00142 nounit = template_blas_lsame(diag, "N");
00143
00144
00145 if (*incx <= 0) {
00146 kx = 1 - (*n - 1) * *incx;
00147 } else if (*incx != 1) {
00148 kx = 1;
00149 }
00150
00151
00152 if (template_blas_lsame(trans, "N")) {
00153
00154 if (template_blas_lsame(uplo, "U")) {
00155 kk = 1;
00156 if (*incx == 1) {
00157 i__1 = *n;
00158 for (j = 1; j <= i__1; ++j) {
00159 if (x[j] != 0.) {
00160 temp = x[j];
00161 k = kk;
00162 i__2 = j - 1;
00163 for (i__ = 1; i__ <= i__2; ++i__) {
00164 x[i__] += temp * ap[k];
00165 ++k;
00166
00167 }
00168 if (nounit) {
00169 x[j] *= ap[kk + j - 1];
00170 }
00171 }
00172 kk += j;
00173
00174 }
00175 } else {
00176 jx = kx;
00177 i__1 = *n;
00178 for (j = 1; j <= i__1; ++j) {
00179 if (x[jx] != 0.) {
00180 temp = x[jx];
00181 ix = kx;
00182 i__2 = kk + j - 2;
00183 for (k = kk; k <= i__2; ++k) {
00184 x[ix] += temp * ap[k];
00185 ix += *incx;
00186
00187 }
00188 if (nounit) {
00189 x[jx] *= ap[kk + j - 1];
00190 }
00191 }
00192 jx += *incx;
00193 kk += j;
00194
00195 }
00196 }
00197 } else {
00198 kk = *n * (*n + 1) / 2;
00199 if (*incx == 1) {
00200 for (j = *n; j >= 1; --j) {
00201 if (x[j] != 0.) {
00202 temp = x[j];
00203 k = kk;
00204 i__1 = j + 1;
00205 for (i__ = *n; i__ >= i__1; --i__) {
00206 x[i__] += temp * ap[k];
00207 --k;
00208
00209 }
00210 if (nounit) {
00211 x[j] *= ap[kk - *n + j];
00212 }
00213 }
00214 kk -= *n - j + 1;
00215
00216 }
00217 } else {
00218 kx += (*n - 1) * *incx;
00219 jx = kx;
00220 for (j = *n; j >= 1; --j) {
00221 if (x[jx] != 0.) {
00222 temp = x[jx];
00223 ix = kx;
00224 i__1 = kk - (*n - (j + 1));
00225 for (k = kk; k >= i__1; --k) {
00226 x[ix] += temp * ap[k];
00227 ix -= *incx;
00228
00229 }
00230 if (nounit) {
00231 x[jx] *= ap[kk - *n + j];
00232 }
00233 }
00234 jx -= *incx;
00235 kk -= *n - j + 1;
00236
00237 }
00238 }
00239 }
00240 } else {
00241
00242 if (template_blas_lsame(uplo, "U")) {
00243 kk = *n * (*n + 1) / 2;
00244 if (*incx == 1) {
00245 for (j = *n; j >= 1; --j) {
00246 temp = x[j];
00247 if (nounit) {
00248 temp *= ap[kk];
00249 }
00250 k = kk - 1;
00251 for (i__ = j - 1; i__ >= 1; --i__) {
00252 temp += ap[k] * x[i__];
00253 --k;
00254
00255 }
00256 x[j] = temp;
00257 kk -= j;
00258
00259 }
00260 } else {
00261 jx = kx + (*n - 1) * *incx;
00262 for (j = *n; j >= 1; --j) {
00263 temp = x[jx];
00264 ix = jx;
00265 if (nounit) {
00266 temp *= ap[kk];
00267 }
00268 i__1 = kk - j + 1;
00269 for (k = kk - 1; k >= i__1; --k) {
00270 ix -= *incx;
00271 temp += ap[k] * x[ix];
00272
00273 }
00274 x[jx] = temp;
00275 jx -= *incx;
00276 kk -= j;
00277
00278 }
00279 }
00280 } else {
00281 kk = 1;
00282 if (*incx == 1) {
00283 i__1 = *n;
00284 for (j = 1; j <= i__1; ++j) {
00285 temp = x[j];
00286 if (nounit) {
00287 temp *= ap[kk];
00288 }
00289 k = kk + 1;
00290 i__2 = *n;
00291 for (i__ = j + 1; i__ <= i__2; ++i__) {
00292 temp += ap[k] * x[i__];
00293 ++k;
00294
00295 }
00296 x[j] = temp;
00297 kk += *n - j + 1;
00298
00299 }
00300 } else {
00301 jx = kx;
00302 i__1 = *n;
00303 for (j = 1; j <= i__1; ++j) {
00304 temp = x[jx];
00305 ix = jx;
00306 if (nounit) {
00307 temp *= ap[kk];
00308 }
00309 i__2 = kk + *n - j;
00310 for (k = kk + 1; k <= i__2; ++k) {
00311 ix += *incx;
00312 temp += ap[k] * x[ix];
00313
00314 }
00315 x[jx] = temp;
00316 jx += *incx;
00317 kk += *n - j + 1;
00318
00319 }
00320 }
00321 }
00322 }
00323 return 0;
00324
00325 }
00326
00327 #endif