示例#1
0
void calcstep(int m, int n, double *A, double *B, double *s, double *y,
              double *r1, double *r2, double r3, double *r4, double *dx,
              double *ds, double *dt, double *dy) {
  char Transpose = 'T';
  char Normal = 'N';
  int n1 = n + 1;
  int oneI = 1;
  double none = -1.0;
  double one = 1.0;
  int info;
  int i;

  int *myworkI;
  double *dxdt;
  double *tmp;
  double *tmpB;

  tmp = pswarm_malloc(m * sizeof(double));
  dxdt = pswarm_malloc(n1 * sizeof(double));

  memset(dxdt, 0, n1 * sizeof(double));

  dxdt[n] = 0.0;
  for (i = 0; i < m; i++) {
    tmp[i] = (r1[i] * y[i] - r4[i]) / s[i];
    dxdt[n] += tmp[i];
  }

  memcpy(dxdt, r2, n * sizeof(double));
  dgemv_(&Transpose, &m, &n, &one, A, &m, tmp, &oneI, &one, dxdt, &oneI);

  /*  dpotrs_(&Upper, &n1, &oneI, B, &n1, dxdt, &n1, &info); */

  free(tmp);

  tmpB = pswarm_malloc(n1 * n1 * sizeof(double));
  myworkI = pswarm_malloc(n1 * sizeof(int));

  memcpy(tmpB, B, n1 * n1 * sizeof(double));

  dgesv_(&n1, &oneI, tmpB, &n1, myworkI, dxdt, &n1, &info);

  memcpy(dx, dxdt, n * sizeof(double));
  *dt = dxdt[n];

  memcpy(ds, r1, m * sizeof(double));
  dgemv_(&Normal, &m, &n, &none, A, &m, dx, &oneI, &one, ds, &oneI);

  for (i = 0; i < m; i++) {
    ds[i] -= (*dt);
    dy[i] = (r4[i] - y[i] * ds[i]) / s[i];
  }

  free(myworkI);
  free(dxdt);
  free(tmpB);
}
示例#2
0
void ProtoMol::Lapack::dgemv(char *transA, int *m, int *n, double *alpha,
                             double *A, int *lda, double *x, int *incx,
                             double *beta, double *Y, int *incY) {
  FAHCheckIn();
#if defined(HAVE_LAPACK)
  dgemv_(transA, m, n, alpha, A, lda, x, incx, beta, Y, incY);
#elif defined(HAVE_SIMTK_LAPACK)
  dgemv_(*transA, *m, *n, *alpha, A, *lda, x, *incx, *beta, Y, *incY, 1);
#elif defined(HAVE_MKL_LAPACK)
  DGEMV(transA, m, n, alpha, A, lda, x, incx, beta, Y, incY);
#else
  THROW(std::string(__func__) + " not supported");
#endif
}
示例#3
0
/* Subroutine */ int bicgkernel_(integer *lda, integer *n, doublereal *a, 
	doublereal *p, doublereal *r__, real *s, real *q)
{
    /* System generated locals */
    integer a_dim1, a_offset;

    /* Local variables */
    static doublereal one;
    static integer incx, incy;
    static doublereal zero;
    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
	    doublereal *, real *, integer *, ftnlen);


/*   BICG */
/*   in */
/*     A : column matrix, p : vector, r : vector */
/*   out */
/*     q : vector, s : vector */
/*   { */
/*     q = A * p */
/*     s = A' * r */
/*   } */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    --p;
    --r__;

    /* Function Body */
    incx = 1;
    incy = 1;
    one = 1.;
    zero = 0.;

/*    Put A*p in q */

    dgemv_("n", n, n, &one, &a[a_offset], lda, &p[1], &incx, &zero, q, &incy, 
	    (ftnlen)1);

/*    Put A'*r in s */

    dgemv_("t", n, n, &one, &a[a_offset], lda, &r__[1], &incx, &zero, s, &
	    incy, (ftnlen)1);

    return 0;
} /* bicgkernel_ */
示例#4
0
文件: fci_rdm.c 项目: eronca/pyscf
void FCItdm12kern_b(double *tdm1, double *tdm2, double *bra, double *ket,
                    int bcount, int stra_id, int strb_id,
                    int norb, int na, int nb, int nlinka, int nlinkb,
                    _LinkT *clink_indexa, _LinkT *clink_indexb, int symm)
{
        const int INC1 = 1;
        const char TRANS_N = 'N';
        const char TRANS_T = 'T';
        const double D1 = 1;
        const int nnorb = norb * norb;
        double csum;
        double *buf0 = calloc(nnorb*bcount, sizeof(double));
        double *buf1 = calloc(nnorb*bcount, sizeof(double));

        csum = FCIrdm2_b_t1ci(bra, buf1, bcount, stra_id, strb_id,
                              norb, nb, nlinkb, clink_indexb);
        if (csum < CSUMTHR) { goto _normal_end; }
        csum = FCIrdm2_b_t1ci(ket, buf0, bcount, stra_id, strb_id,
                              norb, nb, nlinkb, clink_indexb);
        if (csum < CSUMTHR) { goto _normal_end; }
        dgemv_(&TRANS_N, &nnorb, &bcount, &D1, buf0, &nnorb,
               bra+stra_id*nb+strb_id, &INC1, &D1, tdm1, &INC1);
        switch (symm) {
        case PARTICLESYM:
                tril_particle_symm(tdm2, buf1, buf0, bcount, norb, D1, D1);
                break;
        default:
                dgemm_(&TRANS_N, &TRANS_T, &nnorb, &nnorb, &bcount,
                       &D1, buf0, &nnorb, buf1, &nnorb, &D1, tdm2, &nnorb);
        }
_normal_end:
        free(buf0);
        free(buf1);
}
示例#5
0
文件: fci_4pdm.c 项目: eronca/pyscf
static void make_rdm12_sf(double *rdm1, double *rdm2,
                          double *bra, double *ket, double *t1bra, double *t1ket,
                          int bcount, int stra_id, int strb_id,
                          int norb, int na, int nb)
{
        const char TRANS_N = 'N';
        const char TRANS_T = 'T';
        const int INC1 = 1;
        const double D1 = 1;
        const int nnorb = norb * norb;
        int k, l;
        size_t n;
        double *tbra = malloc(sizeof(double) * nnorb * bcount);
        double *pbra, *pt1;

        for (n = 0; n < bcount; n++) {
                pbra = tbra + n * nnorb;
                pt1 = t1bra + n * nnorb;
                for (k = 0; k < norb; k++) {
                        for (l = 0; l < norb; l++) {
                                pbra[k*norb+l] = pt1[l*norb+k];
                        }
                }
        }
        dgemm_(&TRANS_N, &TRANS_T, &nnorb, &nnorb, &bcount,
               &D1, t1ket, &nnorb, tbra, &nnorb,
               &D1, rdm2, &nnorb);

        dgemv_(&TRANS_N, &nnorb, &bcount, &D1, t1ket, &nnorb,
               bra+stra_id*nb+strb_id, &INC1, &D1, rdm1, &INC1);

        free(tbra);
}
/*! dgematrix*_dcovector operator */
inline _dcovector operator*(const dgematrix& mat, const _dcovector& vec)
{
#ifdef  CPPL_VERBOSE
  std::cerr << "# [MARK] operator*(const dgematrix&, const _dcovector&)"
            << std::endl;
#endif//CPPL_VERBOSE

#ifdef  CPPL_DEBUG
  if(mat.N!=vec.L){
    std::cerr << "[ERROR] operator*(const dgematrix&, const _dcovector&)"
              << std::endl
              << "These matrix and vector can not make a product." << std::endl
              << "Your input was (" << mat.M << "x" << mat.N << ") * ("
              << vec.L << ")." << std::endl;
    exit(1);
  }
#endif//CPPL_DEBUG
  
  dcovector newvec(mat.M);
  dgemv_( 'N', mat.M, mat.N, 1.0, mat.Array, mat.M,
          vec.Array, 1, 0.0, newvec.array, 1 );
  
  vec.destroy();
  return _(newvec);
}
示例#7
0
文件: fci_rdm.c 项目: eronca/pyscf
/*
 * 2pdm kernel for  beta^i beta_j | ci0 >
 */
void FCIrdm12kern_b(double *rdm1, double *rdm2, double *bra, double *ket,
                    int bcount, int stra_id, int strb_id,
                    int norb, int na, int nb, int nlinka, int nlinkb,
                    _LinkT *clink_indexa, _LinkT *clink_indexb, int symm)
{
        const int INC1 = 1;
        const char UP = 'U';
        const char TRANS_N = 'N';
        const char TRANS_T = 'T';
        const double D1 = 1;
        const int nnorb = norb * norb;
        double csum;
        double *buf = calloc(nnorb*bcount, sizeof(double));

        csum = FCIrdm2_b_t1ci(ket, buf, bcount, stra_id, strb_id,
                              norb, nb, nlinkb, clink_indexb);
        if (csum > CSUMTHR) {
                dgemv_(&TRANS_N, &nnorb, &bcount, &D1, buf, &nnorb,
                       ket+stra_id*nb+strb_id, &INC1, &D1, rdm1, &INC1);
                switch (symm) {
                case BRAKETSYM:
                        dsyrk_(&UP, &TRANS_N, &nnorb, &bcount,
                               &D1, buf, &nnorb, &D1, rdm2, &nnorb);
                        break;
                case PARTICLESYM:
                        tril_particle_symm(rdm2, buf, buf, bcount, norb, 1, 1);
                        break;
                default:
                        dgemm_(&TRANS_N, &TRANS_T, &nnorb, &nnorb, &bcount,
                               &D1, buf, &nnorb, buf, &nnorb,
                               &D1, rdm2, &nnorb);
                }
        }
        free(buf);
}
示例#8
0
文件: calcs.c 项目: sakov/enkf-c
/** Calculates w = G * s.
 */
void calc_w(int m, int p, double** G, double* s, double* w)
{
    double a = 1.0;
    int inc = 1;
    double b = 0.0;

    dgemv_(&noT, &m, &p, &a, G[0], &m, s, &inc, &b, w, &inc);
}
示例#9
0
void THBlas_(gemv)(char trans, int64_t m, int64_t n, real alpha, real *a, int64_t lda, real *x, int64_t incx, real beta, real *y, int64_t incy)
{
  if(n == 1)
    lda = m;

#if defined(USE_BLAS) && (defined(TH_REAL_IS_DOUBLE) || defined(TH_REAL_IS_FLOAT))
  if( (m <= INT_MAX) && (n <= INT_MAX) && (lda <= INT_MAX) &&
      (incx > 0) && (incx <= INT_MAX) &&
      (incy > 0) && (incy <= INT_MAX) )
  {
    THArgCheck(lda >= THMax(1, m), 6,
      "lda should be at least max(1, m=%d), but have %d", m, lda);
    int i_m = (int)m;
    int i_n = (int)n;
    int i_lda = (int)lda;
    int i_incx = (int)incx;
    int i_incy = (int)incy;

#if defined(TH_REAL_IS_DOUBLE)
    dgemv_(&trans, &i_m, &i_n, &alpha, a, &i_lda, x, &i_incx, &beta, y, &i_incy);
#else
    sgemv_(&trans, &i_m, &i_n, &alpha, a, &i_lda, x, &i_incx, &beta, y, &i_incy);
#endif
    return;
  }
#endif
  {
    int64_t i, j;

    if( (trans == 'T') || (trans == 't') )
    {
      for(i = 0; i < n; i++)
      {
        real sum = 0;
        real *row_ = a+lda*i;
        for(j = 0; j < m; j++)
          sum += x[j*incx]*row_[j];
	if (beta == 0)
	  y[i*incy] = alpha*sum;
	else
	  y[i*incy] = beta*y[i*incy] + alpha*sum;
      }
    }
    else
    {
      if(beta != 1)
        THBlas_(scal)(m, beta, y, incy);

      for(j = 0; j < n; j++)
      {
        real *column_ = a+lda*j;
        real z = alpha*x[j*incx];
        for(i = 0; i < m; i++)
          y[i*incy] += z*column_[i];
      }
    }
  }
}
示例#10
0
 /* ---- PBC functions ---- */
void DoCorrectionTable(double *ChebyshevWeightSource, double *ChebyshevWeightField, int n, int2 dof, double Len, double alpha, int lpbc, kernel_t kernel, double *Tkz) {

  kfun_t kfun = kernel.kfun;
  double homogen = kernel.homogen;
  
  char kpbcFilename[50];
  sprintf(kpbcFilename, "Kn%dpbc%da%.1f.out", n, lpbc, alpha);
  FILE *kfile = fopen(kpbcFilename, "r");

  // Create correction table
  if (kfile == NULL) {
    printf("kpbc file: %s does not exist. Creating now ...\n", kpbcFilename);
    CreateTableCorrection(kfun, n, dof, alpha, lpbc, Tkz, kpbcFilename);
    kfile = fopen(kpbcFilename, "r");
    assert(kfile != NULL);
  }
  else
    printf("kpbc file exits. Reading now ...\n");
  
  // Read and scale for elastic constants
  int i, j=0;
  double c3Read[3];
  for (i=0; i<3; i++)
    j += fscanf(kfile, "%lf", c3Read+i);
  assert (j == 3);

  int n3 = n*n*n;
  int n3f = n3 * dof.f, n3s = n3 * dof.s;
  int dof2n6 = n3f * n3s;
  double *KPBC = (double *) malloc( dof2n6 * sizeof(double) );
  for (i=0; i<dof2n6; i++) 
    j += fscanf(kfile, "%lf", KPBC+i);
  fclose(kfile);
  assert( j-3 == dof2n6 );
  
  // Compute stress from PBC
  int incr = 1;
  double beta = 0;
  char trans = 'n';
  double scale = pow(1/Len, homogen); // Scale for the box size

  // check if parameters are exactly scaled
  if ( fabs(AnisoParameters->c3[0]/c3Read[0] -
	    AnisoParameters->c3[1]/c3Read[1]) <1e-6 &&   
       fabs(AnisoParameters->c3[2]/c3Read[2] -
	    AnisoParameters->c3[1]/c3Read[1]) <1e-6 )
      
    scale *= AnisoParameters->c3[0]/c3Read[0];
  else
    printf("Error: elastic constants do not match (scale).\n");

  dgemv_(&trans, &n3f, &n3s, &scale, KPBC,
	 &n3f, ChebyshevWeightSource, &incr, &beta,
	 ChebyshevWeightField, &incr);
    
  free(KPBC), KPBC=NULL;

}
示例#11
0
void DenseGenMatrix::mult ( double beta,  double y[], int incy,
				double alpha, double x[], int incx )
{
  char fortranTrans = 'T';
  int n = mStorage->n, m = mStorage->m;
  
  dgemv_( &fortranTrans, &n, &m, &alpha, &mStorage->M[0][0], &n,
	  x, &incx, &beta, y, &incy );
}
示例#12
0
/* y := alpha*A*x + beta*y.
 * INPUT
 *  m : the number of rows   of the matrix A, that is, y[m]
 *  n : the number of colums of the matrix A, that is, x[n]
 *      A is 'm by n' matrix.
 *  dgemv_() is implemented in FORTRAN, so that,
 *  for 'N' case,
 *     y[i] = sum_j A[i,j] x[j]
 *          = sum_J a[I+m*J] * x[J], where I:=i-1, etc.
 *          = sum_J a[J*m+I] * x[J]
 *          = A_C[J,I] * x[J]
 *  for 'T' case,
 *     y[i] = sum_j A[j,i] x[j]
 *          = sum_J a[J+n*I] * x[J], where I:=i-1, etc.
 *          = sum_J a[I*n+J] * x[J]
 *          = A_C[I,J] * x[J]
 *  NOTE, in this case, m and n also should be exchanged...
 */
void dgemv_wrap (int m, int n, double alpha, double *a,
		 double *x, double beta,
		 double *y)
{
  char trans = 'T'; /* fortran's memory allocation is transposed */
  int one = 1;

  dgemv_ (&trans, &n, &m, &alpha, a, &n, x, &one, &beta, y, &one);
}
示例#13
0
文件: fci_rdm.c 项目: eronca/pyscf
/*
 * _spin0 assumes the strict symmetry on alpha and beta electrons
 */
void FCIrdm12kern_spin0(double *rdm1, double *rdm2, double *bra, double *ket,
                        int bcount, int stra_id, int strb_id,
                        int norb, int na, int nb, int nlinka, int nlinkb,
                        _LinkT *clink_indexa, _LinkT *clink_indexb, int symm)
{
        if (stra_id < strb_id) {
                return;
        }
        const int INC1 = 1;
        const char UP = 'U';
        const char TRANS_N = 'N';
        const char TRANS_T = 'T';
        const double D1 = 1;
        const double D2 = 2;
        const int nnorb = norb * norb;
        int fill0, fill1, i;
        double csum = 0;
        double *buf = calloc(nnorb * na, sizeof(double));

        if (strb_id+bcount <= stra_id) {
                fill0 = bcount;
                fill1 = bcount;
                csum = FCIrdm2_b_t1ci(ket, buf, fill0, stra_id, strb_id,
                                      norb, na, nlinka, clink_indexa)
                     + FCIrdm2_a_t1ci(ket, buf, fill1, stra_id, strb_id,
                                      norb, na, nlinka, clink_indexa);
        } else if (stra_id >= strb_id) {
                fill0 = stra_id - strb_id;
                fill1 = stra_id - strb_id + 1;
                csum = FCIrdm2_b_t1ci(ket, buf, fill0, stra_id, strb_id,
                                      norb, na, nlinka, clink_indexa)
                     + FCIrdm2_a_t1ci(ket, buf, fill1, stra_id, strb_id,
                                      norb, na, nlinka, clink_indexa);
        }
        if (csum > CSUMTHR) {
                dgemv_(&TRANS_N, &nnorb, &fill1, &D2, buf, &nnorb,
                       ket+stra_id*na+strb_id, &INC1, &D1, rdm1, &INC1);

                for (i = fill0*nnorb; i < fill1*nnorb; i++) {
                        buf[i] *= SQRT2;
                }
                switch (symm) {
                case BRAKETSYM:
                        dsyrk_(&UP, &TRANS_N, &nnorb, &fill1,
                               &D2, buf, &nnorb, &D1, rdm2, &nnorb);
                        break;
                case PARTICLESYM:
                        tril_particle_symm(rdm2, buf, buf, fill1, norb, D2, D1);
                        break;
                default:
                        dgemm_(&TRANS_N, &TRANS_T, &nnorb, &nnorb, &fill1,
                               &D2, buf, &nnorb, buf, &nnorb,
                               &D1, rdm2, &nnorb);
                }
        }
        free(buf);
}
示例#14
0
文件: bb.c 项目: elijah/cachebench
INLINE void do_dgemv(double *a, double *x, double *y, int iterations, int *limit, int *lda)
{
  REGISTER int i = 0;
  extern int dgemv_();

  for (;i<iterations;i++)
    {
      dgemv_(foo,limit,limit,&dalpha,a,lda,x,&stride,&dbeta,y,&stride);
    }
}
void EucQuadratic::HessianEta(Variable *x, Vector *etax, Vector *xix) const
{
	const double *v = etax->ObtainReadData();
	double *xixTV = xix->ObtainWriteEntireData();

	char *transn = const_cast<char *> ("n");
	integer N = Dim, inc = 1;
	double two = 2, zero = 0;
	dgemv_(transn, &N, &N, &two, A, &N, const_cast<double *> (v), &inc, &zero, xixTV, &inc);
};
示例#16
0
文件: blas.c 项目: robwarm/gpaw-symm
PyObject* gemv(PyObject *self, PyObject *args)
{
  Py_complex alpha;
  PyArrayObject* a;
  PyArrayObject* x;
  Py_complex beta;
  PyArrayObject* y;
  char trans = 't';
  if (!PyArg_ParseTuple(args, "DOODO|c", &alpha, &a, &x, &beta, &y, &trans))
    return NULL;

  int m, n, lda, itemsize, incx, incy;

  if (trans == 'n')
    {
      m = PyArray_DIMS(a)[1];
      for (int i = 2; i < PyArray_NDIM(a); i++)
        m *= PyArray_DIMS(a)[i];
      n = PyArray_DIMS(a)[0];
      lda = MAX(1, m);
    }
  else
    {
      n = PyArray_DIMS(a)[0];
      for (int i = 1; i < PyArray_NDIM(a)-1; i++)
        n *= PyArray_DIMS(a)[i];
      m = PyArray_DIMS(a)[PyArray_NDIM(a)-1];
      lda = MAX(1, m);
    }

  if (PyArray_DESCR(a)->type_num == NPY_DOUBLE)
    itemsize = sizeof(double);
  else
    itemsize = sizeof(double_complex);

  incx = PyArray_STRIDES(x)[0]/itemsize;
  incy = 1;

  if (PyArray_DESCR(a)->type_num == NPY_DOUBLE)
    dgemv_(&trans, &m, &n,
           &(alpha.real),
           DOUBLEP(a), &lda,
           DOUBLEP(x), &incx,
           &(beta.real),
           DOUBLEP(y), &incy);
  else
    zgemv_(&trans, &m, &n,
           &alpha,
           (void*)COMPLEXP(a), &lda,
           (void*)COMPLEXP(x), &incx,
           &beta,
           (void*)COMPLEXP(y), &incy);
  Py_RETURN_NONE;
}
示例#17
0
	void EucQuadratic::HessianEta(Variable *x, Vector *etax, Vector *xix) const
	{
		const double *v = etax->ObtainReadData();
		double *xixTV = xix->ObtainWriteEntireData();

		char *transn = const_cast<char *> ("n");
		integer N = Dim, inc = 1;
		double two = 2, zero = 0;
		// xixTV <- 2 * A * v, details: http://www.netlib.org/lapack/explore-html/dc/da8/dgemv_8f.html
		dgemv_(transn, &N, &N, &two, A, &N, const_cast<double *> (v), &inc, &zero, xixTV, &inc);
	};
示例#18
0
GURLS_EXPORT void gemv(const CBLAS_TRANSPOSE TransA,
          const int M, const int N, const double alpha, const double *A,
          const int lda, const double *X, const int incX,
          const double beta, double *Y, const int incY)
{
    char transA = BlasUtils::charValue(TransA);

    dgemv_(&transA, const_cast<int*>(&M), const_cast<int*>(&N),
          const_cast<double*>(&alpha), const_cast<double*>(A), const_cast<int*>(&lda),
          const_cast<double*>(X), const_cast<int*>(&incX), const_cast<double*>(&beta),
          const_cast<double*>(Y), const_cast<int*>(&incY));
}
示例#19
0
int
f2c_dgemv(char* trans, integer* M, integer* N,
          doublereal* alpha,
          doublereal* A, integer* lda,
          doublereal* X, integer* incX,
          doublereal* beta,
          doublereal* Y, integer* incY)
{
    dgemv_(trans, M, N,
           alpha, A, lda, X, incX, beta, Y, incY);
    return 0;
}
示例#20
0
/*
 * INPUT
 *  *user_data = (double *) mat
 */
static void
atimes_by_matrix (int n, const double *x, double *b, void *user_data)
{
  char trans = 'T'; /* fortran's memory allocation is transposed */
  int i_1 = 1;
  double d_1 = 1.0;
  double d_0 = 0.0;

  double *mat = (double *)user_data;
  dgemv_ (&trans, &n, &n, &d_1, mat, &n,
	  x, &i_1,
	  &d_0, b, &i_1);
}
示例#21
0
文件: blas.cpp 项目: comenerv/Boom
 void dgemv(const TRANSPOSE TransA,
            const int M,
            const int N,
            const double alpha,
            const double *A,
            const int lda,
            const double *X,
            const int incX,
            const double beta,
            double *Y,
            const int incY) {
   dgemv_(TransposeChar[TransA], &M, &N, &alpha, A, &lda,
          X, &incX, &beta, Y, &incY);
 }
示例#22
0
void matrix_dgemv(const matrix_type * A , const double *x , double * y, bool transA , double alpha , double beta) {
  int m    = matrix_get_rows( A );
  int n    = matrix_get_columns( A );
  int lda  = matrix_get_column_stride( A );
  int incx = 1;
  int incy = 1;

  char transA_c;
  if (transA)
    transA_c = 'T';
  else
    transA_c = 'N';

  dgemv_(&transA_c , &m , &n , &alpha , matrix_get_data( A ) , &lda , x , &incx , &beta , y , &incy);
}
示例#23
0
/* z = alpha * d * y(:,k) + beta * z, where d is dense matrix and y is dense general */
static void
mm_real_d_dot_yk (const bool trans, const double alpha, const mm_dense *d, const mm_dense *y, const int k, const double beta, mm_dense *z)
{
	double	*yk = y->data + k * y->m;
	double	*zk = z->data + k * z->m;
	if (!mm_real_is_symmetric (d)) {
		// z = alpha * d * y + beta * z
		dgemv_ ((trans) ? "T" : "N", &d->m, &d->n, &alpha, d->data, &d->m, yk, &ione, &beta, zk, &ione);
	} else {
		char	uplo = (mm_real_is_upper (d)) ? 'U' : 'L';
		// z = alpha * d * y + beta * z
		dsymv_ (&uplo, &d->m, &alpha, d->data, &d->m, yk, &ione, &beta, zk, &ione);
	}
	return;
}
double EucQuadratic::f(Variable *x) const
{
	const double *v = x->ObtainReadData();
	SharedSpace *Temp = new SharedSpace(1, Dim);
	double *temp = Temp->ObtainWriteEntireData();

	char *transn = const_cast<char *> ("n");
	double one = 1, zero = 0;
	integer inc = 1, N = Dim;
	dgemv_(transn, &N, &N, &one, A, &N, const_cast<double *> (v), &inc, &zero, temp, &inc);

	x->AddToTempData("Ax", Temp);

	return ddot_(&N, const_cast<double *> (v), &inc, temp, &inc);
};
示例#25
0
/* ---------------------------------------------------------------------- */
void
tpfa_htrans_compute(struct UnstructuredGrid *G, const double *perm, double *htrans)
/* ---------------------------------------------------------------------- */
{
    int    c, d, f, i, j;
    double s, dist, denom;

    double Kn[3];
    double *cc, *fc, *n;
    const double *K;

    MAT_SIZE_T nrows, ncols, ldA, incx, incy;
    double a1, a2;

    d = G->dimensions;

    nrows = ncols    = ldA = d;
    incx  = incy     = 1      ;
    a1    = 1.0;  a2 = 0.0    ;

    for (c = i = 0; c < G->number_of_cells; c++) {
        K  = perm + (c * d * d);
        cc = G->cell_centroids + (c * d);

        for (; i < G->cell_facepos[c + 1]; i++) {
            f = G->cell_faces[i];
            s = 2.0*(G->face_cells[2*f + 0] == c) - 1.0;

            n  = G->face_normals   + (f * d);
            fc = G->face_centroids + (f * d);

            dgemv_("No Transpose", &nrows, &ncols,
                   &a1, K, &ldA, n, &incx, &a2, &Kn[0], &incy);

            htrans[i] = denom = 0.0;
            for (j = 0; j < d; j++) {
                dist = fc[j] - cc[j];

                htrans[i] += s * dist * Kn[j];
                denom     +=     dist * dist;
            }

            assert (denom > 0);
            htrans[i] /= denom;
            htrans[i]  = fabs(htrans[i]);
        }
    }
}
示例#26
0
void draw_uncollapsed_xaya(std::vector<double> &xaya, std::vector<double> &xa, std::vector<double> &xag, std::vector<double> Bg,  double phi,  int na, int p, int p_gamma)
{
	double sd=sqrt(1/phi);
	std::vector<double> Z(na);
	for(std::vector<double>::iterator it=Z.begin(); it!=Z.end(); ++it) *it=Rf_rnorm(0,1);

	if(p_gamma!=0){
		dgemv_(&transN , &na, &p_gamma, &unity, &*xag.begin(), &na, &*Bg.begin(), &inc, &inputscale0, &*xaya.begin(), &inc);
		daxpy_(&p, &sd, &*Z.begin(), &inc, &*xaya.begin(), &inc);
		//dtrmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &na, &*xaya.begin(), &inc);
		dtpmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &*xaya.begin(), &inc);
	}else{
		for(size_t i=0; i!=xaya.size(); ++i) xaya[i]=sd*Z[i];
		//dtrmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &na, &*xaya.begin(), &inc);
		dtpmv_(&uplo, &transT, &unit_tri, &na, &*xa.begin(), &*xaya.begin(), &inc);
	}
}
示例#27
0
void
linalg_matvec_plus_vec (double alpha, double *A, double *v, double beta,
                        double *b, int m, int n)
{
  char                ytran = 'T';
  int                 dimM = m;
  int                 dimN = n;

  int                 incb = 1;
  int                 incv = 1;

  /* printf("\n\nmatvec plus vec\n\n"); */
  /* util_print_matrix(A, m, n, "A = ", 0); */
  /* util_print_matrix(v, n, 1, "v = ", 0); */

  dgemv_ (&ytran, &dimN, &dimM, &alpha, A, &dimN, v, &incv, &beta, b, &incb);
}
示例#28
0
/*! drovector*dgematrix operator */
inline _drovector operator*(const drovector& vec, const dgematrix& mat)
{VERBOSE_REPORT;
#ifdef  CPPL_DEBUG
  if(vec.l!=mat.m){
    ERROR_REPORT;
    std::cerr << "These vector and matrix can not make a product." << std::endl
              << "Your input was (" << vec.l << ") * (" << mat.m << "x" << mat.n << ")." << std::endl;
    exit(1);
  }
#endif//CPPL_DEBUG
  
  drovector newvec(mat.n);
  dgemv_( 'T', mat.m, mat.n, 1.0, mat.array, mat.m,
          vec.array, 1, 0.0, newvec.array, 1 );
  
  return _(newvec);
}
示例#29
0
	double EucQuadratic::f(Variable *x) const
	{
		const double *v = x->ObtainReadData();
		SharedSpace *Temp = new SharedSpace(1, Dim);
		double *temp = Temp->ObtainWriteEntireData();

		char *transn = const_cast<char *> ("n");
		double one = 1, zero = 0;
		integer inc = 1, N = Dim;
		// temp <- A * v, details: http://www.netlib.org/lapack/explore-html/dc/da8/dgemv_8f.html
		dgemv_(transn, &N, &N, &one, A, &N, const_cast<double *> (v), &inc, &zero, temp, &inc);

		x->AddToTempData("Ax", Temp);

		// output v^T temp, details: http://www.netlib.org/lapack/explore-html/d5/df6/ddot_8f.html
		return ddot_(&N, const_cast<double *> (v), &inc, temp, &inc);
	};
示例#30
0
/*! dgematrix*_dcovector operator */
inline _dcovector operator*(const dgematrix& mat, const _dcovector& vec)
{VERBOSE_REPORT;
#ifdef  CPPL_DEBUG
  if(mat.n!=vec.l){
    ERROR_REPORT;
    std::cerr << "These matrix and vector can not make a product." << std::endl
              << "Your input was (" << mat.m << "x" << mat.n << ") * (" << vec.l << ")." << std::endl;
    exit(1);
  }
#endif//CPPL_DEBUG
  
  dcovector newvec(mat.m);
  dgemv_( 'n', mat.m, mat.n, 1.0, mat.array, mat.m,
          vec.array, 1, 0.0, newvec.array, 1 );
  
  vec.destroy();
  return _(newvec);
}