1 /* sspmv.f -- translated by f2c (version 20100827). 2 You must link the resulting object file with libf2c: 3 on Microsoft Windows system, link with libf2c.lib; 4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm 5 or, if you install libf2c.a in a standard place, with -lf2c -lm 6 -- in that order, at the end of the command line, as in 7 cc *.o -lf2c -lm 8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., 9 10 http://www.netlib.org/f2c/libf2c.zip 11 */ 12 13 #include "datatypes.h" 14 sspmv_(char * uplo,integer * n,real * alpha,real * ap,real * x,integer * incx,real * beta,real * y,integer * incy,ftnlen uplo_len)15 /* Subroutine */ int sspmv_(char *uplo, integer *n, real *alpha, real *ap, 16 real *x, integer *incx, real *beta, real *y, integer *incy, ftnlen 17 uplo_len) 18 { 19 /* System generated locals */ 20 integer i__1, i__2; 21 22 /* Local variables */ 23 integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info; 24 real temp1, temp2; 25 extern logical lsame_(char *, char *, ftnlen, ftnlen); 26 extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); 27 28 /* .. Scalar Arguments .. */ 29 /* .. */ 30 /* .. Array Arguments .. */ 31 /* .. */ 32 33 /* Purpose */ 34 /* ======= */ 35 36 /* SSPMV performs the matrix-vector operation */ 37 38 /* y := alpha*A*x + beta*y, */ 39 40 /* where alpha and beta are scalars, x and y are n element vectors and */ 41 /* A is an n by n symmetric matrix, supplied in packed form. */ 42 43 /* Arguments */ 44 /* ========== */ 45 46 /* UPLO - CHARACTER*1. */ 47 /* On entry, UPLO specifies whether the upper or lower */ 48 /* triangular part of the matrix A is supplied in the packed */ 49 /* array AP as follows: */ 50 51 /* UPLO = 'U' or 'u' The upper triangular part of A is */ 52 /* supplied in AP. */ 53 54 /* UPLO = 'L' or 'l' The lower triangular part of A is */ 55 /* supplied in AP. */ 56 57 /* Unchanged on exit. */ 58 59 /* N - INTEGER. */ 60 /* On entry, N specifies the order of the matrix A. */ 61 /* N must be at least zero. */ 62 /* Unchanged on exit. */ 63 64 /* ALPHA - REAL . */ 65 /* On entry, ALPHA specifies the scalar alpha. */ 66 /* Unchanged on exit. */ 67 68 /* AP - REAL array of DIMENSION at least */ 69 /* ( ( n*( n + 1 ) )/2 ). */ 70 /* Before entry with UPLO = 'U' or 'u', the array AP must */ 71 /* contain the upper triangular part of the symmetric matrix */ 72 /* packed sequentially, column by column, so that AP( 1 ) */ 73 /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */ 74 /* and a( 2, 2 ) respectively, and so on. */ 75 /* Before entry with UPLO = 'L' or 'l', the array AP must */ 76 /* contain the lower triangular part of the symmetric matrix */ 77 /* packed sequentially, column by column, so that AP( 1 ) */ 78 /* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */ 79 /* and a( 3, 1 ) respectively, and so on. */ 80 /* Unchanged on exit. */ 81 82 /* X - REAL array of dimension at least */ 83 /* ( 1 + ( n - 1 )*abs( INCX ) ). */ 84 /* Before entry, the incremented array X must contain the n */ 85 /* element vector x. */ 86 /* Unchanged on exit. */ 87 88 /* INCX - INTEGER. */ 89 /* On entry, INCX specifies the increment for the elements of */ 90 /* X. INCX must not be zero. */ 91 /* Unchanged on exit. */ 92 93 /* BETA - REAL . */ 94 /* On entry, BETA specifies the scalar beta. When BETA is */ 95 /* supplied as zero then Y need not be set on input. */ 96 /* Unchanged on exit. */ 97 98 /* Y - REAL array of dimension at least */ 99 /* ( 1 + ( n - 1 )*abs( INCY ) ). */ 100 /* Before entry, the incremented array Y must contain the n */ 101 /* element vector y. On exit, Y is overwritten by the updated */ 102 /* vector y. */ 103 104 /* INCY - INTEGER. */ 105 /* On entry, INCY specifies the increment for the elements of */ 106 /* Y. INCY must not be zero. */ 107 /* Unchanged on exit. */ 108 109 /* Further Details */ 110 /* =============== */ 111 112 /* Level 2 Blas routine. */ 113 114 /* -- Written on 22-October-1986. */ 115 /* Jack Dongarra, Argonne National Lab. */ 116 /* Jeremy Du Croz, Nag Central Office. */ 117 /* Sven Hammarling, Nag Central Office. */ 118 /* Richard Hanson, Sandia National Labs. */ 119 120 /* ===================================================================== */ 121 122 /* .. Parameters .. */ 123 /* .. */ 124 /* .. Local Scalars .. */ 125 /* .. */ 126 /* .. External Functions .. */ 127 /* .. */ 128 /* .. External Subroutines .. */ 129 /* .. */ 130 131 /* Test the input parameters. */ 132 133 /* Parameter adjustments */ 134 --y; 135 --x; 136 --ap; 137 138 /* Function Body */ 139 info = 0; 140 if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( 141 ftnlen)1, (ftnlen)1)) { 142 info = 1; 143 } else if (*n < 0) { 144 info = 2; 145 } else if (*incx == 0) { 146 info = 6; 147 } else if (*incy == 0) { 148 info = 9; 149 } 150 if (info != 0) { 151 xerbla_("SSPMV ", &info, (ftnlen)6); 152 return 0; 153 } 154 155 /* Quick return if possible. */ 156 157 if (*n == 0 || (*alpha == 0.f && *beta == 1.f)) { 158 return 0; 159 } 160 161 /* Set up the start points in X and Y. */ 162 163 if (*incx > 0) { 164 kx = 1; 165 } else { 166 kx = 1 - (*n - 1) * *incx; 167 } 168 if (*incy > 0) { 169 ky = 1; 170 } else { 171 ky = 1 - (*n - 1) * *incy; 172 } 173 174 /* Start the operations. In this version the elements of the array AP */ 175 /* are accessed sequentially with one pass through AP. */ 176 177 /* First form y := beta*y. */ 178 179 if (*beta != 1.f) { 180 if (*incy == 1) { 181 if (*beta == 0.f) { 182 i__1 = *n; 183 for (i__ = 1; i__ <= i__1; ++i__) { 184 y[i__] = 0.f; 185 /* L10: */ 186 } 187 } else { 188 i__1 = *n; 189 for (i__ = 1; i__ <= i__1; ++i__) { 190 y[i__] = *beta * y[i__]; 191 /* L20: */ 192 } 193 } 194 } else { 195 iy = ky; 196 if (*beta == 0.f) { 197 i__1 = *n; 198 for (i__ = 1; i__ <= i__1; ++i__) { 199 y[iy] = 0.f; 200 iy += *incy; 201 /* L30: */ 202 } 203 } else { 204 i__1 = *n; 205 for (i__ = 1; i__ <= i__1; ++i__) { 206 y[iy] = *beta * y[iy]; 207 iy += *incy; 208 /* L40: */ 209 } 210 } 211 } 212 } 213 if (*alpha == 0.f) { 214 return 0; 215 } 216 kk = 1; 217 if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { 218 219 /* Form y when AP contains the upper triangle. */ 220 221 if (*incx == 1 && *incy == 1) { 222 i__1 = *n; 223 for (j = 1; j <= i__1; ++j) { 224 temp1 = *alpha * x[j]; 225 temp2 = 0.f; 226 k = kk; 227 i__2 = j - 1; 228 for (i__ = 1; i__ <= i__2; ++i__) { 229 y[i__] += temp1 * ap[k]; 230 temp2 += ap[k] * x[i__]; 231 ++k; 232 /* L50: */ 233 } 234 y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; 235 kk += j; 236 /* L60: */ 237 } 238 } else { 239 jx = kx; 240 jy = ky; 241 i__1 = *n; 242 for (j = 1; j <= i__1; ++j) { 243 temp1 = *alpha * x[jx]; 244 temp2 = 0.f; 245 ix = kx; 246 iy = ky; 247 i__2 = kk + j - 2; 248 for (k = kk; k <= i__2; ++k) { 249 y[iy] += temp1 * ap[k]; 250 temp2 += ap[k] * x[ix]; 251 ix += *incx; 252 iy += *incy; 253 /* L70: */ 254 } 255 y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; 256 jx += *incx; 257 jy += *incy; 258 kk += j; 259 /* L80: */ 260 } 261 } 262 } else { 263 264 /* Form y when AP contains the lower triangle. */ 265 266 if (*incx == 1 && *incy == 1) { 267 i__1 = *n; 268 for (j = 1; j <= i__1; ++j) { 269 temp1 = *alpha * x[j]; 270 temp2 = 0.f; 271 y[j] += temp1 * ap[kk]; 272 k = kk + 1; 273 i__2 = *n; 274 for (i__ = j + 1; i__ <= i__2; ++i__) { 275 y[i__] += temp1 * ap[k]; 276 temp2 += ap[k] * x[i__]; 277 ++k; 278 /* L90: */ 279 } 280 y[j] += *alpha * temp2; 281 kk += *n - j + 1; 282 /* L100: */ 283 } 284 } else { 285 jx = kx; 286 jy = ky; 287 i__1 = *n; 288 for (j = 1; j <= i__1; ++j) { 289 temp1 = *alpha * x[jx]; 290 temp2 = 0.f; 291 y[jy] += temp1 * ap[kk]; 292 ix = jx; 293 iy = jy; 294 i__2 = kk + *n - j; 295 for (k = kk + 1; k <= i__2; ++k) { 296 ix += *incx; 297 iy += *incy; 298 y[iy] += temp1 * ap[k]; 299 temp2 += ap[k] * x[ix]; 300 /* L110: */ 301 } 302 y[jy] += *alpha * temp2; 303 jx += *incx; 304 jy += *incy; 305 kk += *n - j + 1; 306 /* L120: */ 307 } 308 } 309 } 310 311 return 0; 312 313 /* End of SSPMV . */ 314 315 } /* sspmv_ */ 316 317