sla_geamv.c
Go to the documentation of this file.
00001 /* sla_geamv.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 sla_geamv__(integer *trans, integer *m, integer *n, real 
00017         *alpha, real *a, integer *lda, real *x, integer *incx, real *beta, 
00018         real *y, integer *incy)
00019 {
00020     /* System generated locals */
00021     integer a_dim1, a_offset, i__1, i__2;
00022     real r__1;
00023 
00024     /* Builtin functions */
00025     double r_sign(real *, real *);
00026 
00027     /* Local variables */
00028     extern integer ilatrans_(char *);
00029     integer i__, j;
00030     logical symb_zero__;
00031     integer iy, jx, kx, ky, info;
00032     real temp;
00033     integer lenx, leny;
00034     real safe1;
00035     extern doublereal slamch_(char *);
00036     extern /* Subroutine */ int xerbla_(char *, integer *);
00037 
00038 
00039 /*     -- LAPACK routine (version 3.2)                                 -- */
00040 /*     -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
00041 /*     -- Jason Riedy of Univ. of California Berkeley.                 -- */
00042 /*     -- November 2008                                                -- */
00043 
00044 /*     -- LAPACK is a software package provided by Univ. of Tennessee, -- */
00045 /*     -- Univ. of California Berkeley and NAG Ltd.                    -- */
00046 
00047 /*     .. */
00048 /*     .. Scalar Arguments .. */
00049 /*     .. */
00050 /*     .. Array Arguments .. */
00051 /*     .. */
00052 
00053 /*  Purpose */
00054 /*  ======= */
00055 
00056 /*  SLA_GEAMV  performs one of the matrix-vector operations */
00057 
00058 /*          y := alpha*abs(A)*abs(x) + beta*abs(y), */
00059 /*     or   y := alpha*abs(A)'*abs(x) + beta*abs(y), */
00060 
00061 /*  where alpha and beta are scalars, x and y are vectors and A is an */
00062 /*  m by n matrix. */
00063 
00064 /*  This function is primarily used in calculating error bounds. */
00065 /*  To protect against underflow during evaluation, components in */
00066 /*  the resulting vector are perturbed away from zero by (N+1) */
00067 /*  times the underflow threshold.  To prevent unnecessarily large */
00068 /*  errors for block-structure embedded in general matrices, */
00069 /*  "symbolically" zero components are not perturbed.  A zero */
00070 /*  entry is considered "symbolic" if all multiplications involved */
00071 /*  in computing that entry have at least one zero multiplicand. */
00072 
00073 /*  Parameters */
00074 /*  ========== */
00075 
00076 /*  TRANS  - INTEGER */
00077 /*           On entry, TRANS specifies the operation to be performed as */
00078 /*           follows: */
00079 
00080 /*             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y) */
00081 /*             BLAS_TRANS         y := alpha*abs(A')*abs(x) + beta*abs(y) */
00082 /*             BLAS_CONJ_TRANS    y := alpha*abs(A')*abs(x) + beta*abs(y) */
00083 
00084 /*           Unchanged on exit. */
00085 
00086 /*  M      - INTEGER */
00087 /*           On entry, M specifies the number of rows of the matrix A. */
00088 /*           M must be at least zero. */
00089 /*           Unchanged on exit. */
00090 
00091 /*  N      - INTEGER */
00092 /*           On entry, N specifies the number of columns of the matrix A. */
00093 /*           N must be at least zero. */
00094 /*           Unchanged on exit. */
00095 
00096 /*  ALPHA  - REAL */
00097 /*           On entry, ALPHA specifies the scalar alpha. */
00098 /*           Unchanged on exit. */
00099 
00100 /*  A      - REAL             array of DIMENSION ( LDA, n ) */
00101 /*           Before entry, the leading m by n part of the array A must */
00102 /*           contain the matrix of coefficients. */
00103 /*           Unchanged on exit. */
00104 
00105 /*  LDA    - INTEGER */
00106 /*           On entry, LDA specifies the first dimension of A as declared */
00107 /*           in the calling (sub) program. LDA must be at least */
00108 /*           max( 1, m ). */
00109 /*           Unchanged on exit. */
00110 
00111 /*  X      - REAL             array of DIMENSION at least */
00112 /*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
00113 /*           and at least */
00114 /*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
00115 /*           Before entry, the incremented array X must contain the */
00116 /*           vector x. */
00117 /*           Unchanged on exit. */
00118 
00119 /*  INCX   - INTEGER */
00120 /*           On entry, INCX specifies the increment for the elements of */
00121 /*           X. INCX must not be zero. */
00122 /*           Unchanged on exit. */
00123 
00124 /*  BETA   - REAL */
00125 /*           On entry, BETA specifies the scalar beta. When BETA is */
00126 /*           supplied as zero then Y need not be set on input. */
00127 /*           Unchanged on exit. */
00128 
00129 /*  Y      - REAL */
00130 /*           Array of DIMENSION at least */
00131 /*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
00132 /*           and at least */
00133 /*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
00134 /*           Before entry with BETA non-zero, the incremented array Y */
00135 /*           must contain the vector y. On exit, Y is overwritten by the */
00136 /*           updated vector y. */
00137 
00138 /*  INCY   - INTEGER */
00139 /*           On entry, INCY specifies the increment for the elements of */
00140 /*           Y. INCY must not be zero. */
00141 /*           Unchanged on exit. */
00142 
00143 /*  Level 2 Blas routine. */
00144 
00145 /*     .. */
00146 /*     .. Parameters .. */
00147 /*     .. */
00148 /*     .. Local Scalars .. */
00149 /*     .. */
00150 /*     .. External Subroutines .. */
00151 /*     .. */
00152 /*     .. External Functions .. */
00153 /*     .. */
00154 /*     .. Intrinsic Functions .. */
00155 /*     .. */
00156 /*     .. Executable Statements .. */
00157 
00158 /*     Test the input parameters. */
00159 
00160     /* Parameter adjustments */
00161     a_dim1 = *lda;
00162     a_offset = 1 + a_dim1;
00163     a -= a_offset;
00164     --x;
00165     --y;
00166 
00167     /* Function Body */
00168     info = 0;
00169     if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) {
00170         info = 1;
00171     } else if (*m < 0) {
00172         info = 2;
00173     } else if (*n < 0) {
00174         info = 3;
00175     } else if (*lda < max(1,*m)) {
00176         info = 6;
00177     } else if (*incx == 0) {
00178         info = 8;
00179     } else if (*incy == 0) {
00180         info = 11;
00181     }
00182     if (info != 0) {
00183         xerbla_("SLA_GEAMV ", &info);
00184         return 0;
00185     }
00186 
00187 /*     Quick return if possible. */
00188 
00189     if (*m == 0 || *n == 0 || *alpha == 0.f && *beta == 1.f) {
00190         return 0;
00191     }
00192 
00193 /*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set */
00194 /*     up the start points in  X  and  Y. */
00195 
00196     if (*trans == ilatrans_("N")) {
00197         lenx = *n;
00198         leny = *m;
00199     } else {
00200         lenx = *m;
00201         leny = *n;
00202     }
00203     if (*incx > 0) {
00204         kx = 1;
00205     } else {
00206         kx = 1 - (lenx - 1) * *incx;
00207     }
00208     if (*incy > 0) {
00209         ky = 1;
00210     } else {
00211         ky = 1 - (leny - 1) * *incy;
00212     }
00213 
00214 /*     Set SAFE1 essentially to be the underflow threshold times the */
00215 /*     number of additions in each row. */
00216 
00217     safe1 = slamch_("Safe minimum");
00218     safe1 = (*n + 1) * safe1;
00219 
00220 /*     Form  y := alpha*abs(A)*abs(x) + beta*abs(y). */
00221 
00222 /*     The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */
00223 /*     the inexact flag.  Still doesn't help change the iteration order */
00224 /*     to per-column. */
00225 
00226     iy = ky;
00227     if (*incx == 1) {
00228         i__1 = leny;
00229         for (i__ = 1; i__ <= i__1; ++i__) {
00230             if (*beta == 0.f) {
00231                 symb_zero__ = TRUE_;
00232                 y[iy] = 0.f;
00233             } else if (y[iy] == 0.f) {
00234                 symb_zero__ = TRUE_;
00235             } else {
00236                 symb_zero__ = FALSE_;
00237                 y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
00238             }
00239             if (*alpha != 0.f) {
00240                 i__2 = lenx;
00241                 for (j = 1; j <= i__2; ++j) {
00242                     if (*trans == ilatrans_("N")) {
00243                         temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
00244                     } else {
00245                         temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
00246                     }
00247                     symb_zero__ = symb_zero__ && (x[j] == 0.f || temp == 0.f);
00248                     y[iy] += *alpha * (r__1 = x[j], dabs(r__1)) * temp;
00249                 }
00250             }
00251             if (! symb_zero__) {
00252                 y[iy] += r_sign(&safe1, &y[iy]);
00253             }
00254             iy += *incy;
00255         }
00256     } else {
00257         i__1 = leny;
00258         for (i__ = 1; i__ <= i__1; ++i__) {
00259             if (*beta == 0.f) {
00260                 symb_zero__ = TRUE_;
00261                 y[iy] = 0.f;
00262             } else if (y[iy] == 0.f) {
00263                 symb_zero__ = TRUE_;
00264             } else {
00265                 symb_zero__ = FALSE_;
00266                 y[iy] = *beta * (r__1 = y[iy], dabs(r__1));
00267             }
00268             if (*alpha != 0.f) {
00269                 jx = kx;
00270                 i__2 = lenx;
00271                 for (j = 1; j <= i__2; ++j) {
00272                     if (*trans == ilatrans_("N")) {
00273                         temp = (r__1 = a[i__ + j * a_dim1], dabs(r__1));
00274                     } else {
00275                         temp = (r__1 = a[j + i__ * a_dim1], dabs(r__1));
00276                     }
00277                     symb_zero__ = symb_zero__ && (x[jx] == 0.f || temp == 0.f)
00278                             ;
00279                     y[iy] += *alpha * (r__1 = x[jx], dabs(r__1)) * temp;
00280                     jx += *incx;
00281                 }
00282             }
00283             if (! symb_zero__) {
00284                 y[iy] += r_sign(&safe1, &y[iy]);
00285             }
00286             iy += *incy;
00287         }
00288     }
00289 
00290     return 0;
00291 
00292 /*     End of SLA_GEAMV */
00293 
00294 } /* sla_geamv__ */


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