void Tri::PutFace(double *from, int fac){ if(from) switch(fac){ case 0: dcopy(qa, from, 1, h[0], 1); break; case 1: dcopy(qb, from, 1, h[0]+qa-1, qa); break; case 2: dcopy(qb, from, 1, h[0], qa); break; default: error_msg(GetFace -- unknown face); break; } else switch(fac){ case 0: dzero(qa, h[0], 1); break; case 1: dzero(qb, h[0]+qa-1, qa); break; case 2: dzero(qb, h[0], qa); break; default: error_msg(GetFace -- unknown face); break; } }
void PackMatrixV(double *a, int n, double *b, int bwidth, char trip){ register int i; if(n>2*bwidth){ /* banded symmetric lower triangular form */ double *s; if(trip == 'l'){ for(i = 0,s=b; i < n-bwidth; ++i,s+=bwidth) dcopy(bwidth,a+i*n+i,1,s,1); for(i = n-bwidth; i < n; ++i,s+=bwidth) dcopy(n-i,a+i*n+i,1,s,1); } else error_msg(banded upper form not set up in PackMatrixV); } else{ register int j; if(trip == 'l'){ /* symmetric lower triangular form */ for(i=0, j=0; i < n; j+=n-i++) dcopy(n-i, a+i*n+i, 1, b+j, 1); } else{ /* symmetric upper triangular form */ for(i=0, j=0; i < n; j+= ++i) dcopy(i+1, a+i*n, 1, b+j, 1); } } }
void set_order(int Je) { tmp_order = Je; dcopy(3, Alpha_SS[Je-1], 1, Alpha_Int, 1); dcopy(3, Beta_SS[Je-1], 1, Beta_Int, 1); Gamma_Int = Gamma_SS[Je-1]; }
void collectAfterPre(Vector u, const Vector v) { int source, dest; if (u->comm_rank == 0) { int len=u->len-1; dcopy(&len, v->data, &v->stride, u->data+1, &u->stride); } else if (u->comm_rank == u->comm_size-1) { int len=v->len-1; dcopy(&len, v->data+1, &v->stride, u->data+1, &u->stride); } else copyVector(u, v); // west double recv; MPI_Cart_shift(*u->comm, 0, -1, &source, &dest); MPI_Sendrecv(v->data, 1, MPI_DOUBLE, dest, 0, u->data, 1, MPI_DOUBLE, source, 0, *u->comm, MPI_STATUS_IGNORE); if (source > -1) u->data[u->len-2] += u->data[0]; // east MPI_Cart_shift(*u->comm, 0, 1, &source, &dest); MPI_Sendrecv(v->data+v->len-1, 1, MPI_DOUBLE, dest, 1, u->data, 1, MPI_DOUBLE, source, 1, *u->comm, MPI_STATUS_IGNORE); if (source > -1) u->data[1] += u->data[0]; u->data[0] = u->data[u->len-1] = 0.0; }
Grid::Grid(Grid *Orig){ int i; domainname = strdup(Orig->domainname); domainfile = Orig->domainfile; totverts = Orig->totverts; xcoords = dvector(0, totverts-1); ycoords = dvector(0, totverts-1); zcoords = dvector(0, totverts-1); dcopy(totverts, Orig->xcoords, 1, xcoords, 1); dcopy(totverts, Orig->ycoords, 1, ycoords, 1); dcopy(totverts, Orig->zcoords, 1, zcoords, 1); nel = Orig->nel; nverts = ivector(0, nel-1); icopy(nel, Orig->nverts, 1, nverts, 1); vertids = imatrix(0, nel-1, 0, Max_Nverts-1); icopy(nel*Max_Nverts, Orig->vertids[0], 1, vertids[0], 1); elmtids = ivector(0, nel-1); icopy(nel, Orig->elmtids, 1, elmtids, 1); vertexmap = imatrix(0, nel-1, 0, Max_Nverts-1); icopy(nel*Max_Nverts, Orig->vertexmap[0], 1, vertexmap[0], 1); }
// needs to be fixed void Prism::GetFace(double *from, int fac, double *to){ register int i; switch(fac){ case 0: dcopy(qa*qb,from ,1 ,to ,1); break; case 1: for(i = 0; i < qc; ++i) dcopy(qa, from + i*qa*qb, 1, to + i*qa, 1); break; case 2: for(i = 0; i < qc; ++i) dcopy(qb, from + qa-1 + i*qa*qb, qa, to + i*qb, 1); break; case 3: for(i = 0; i < qc; ++i) dcopy(qa, from + i*qa*qb+qa*(qb-1), 1, to + i*qa, 1); break; case 4: for(i = 0; i < qc; ++i) dcopy(qb, from + i*qa*qb, qa, to + i*qb, 1); break; default: error_msg(GetFace -- unknown face); break; } }
void mtx_copy( Tmtx_ptr from, Tmtx_ptr to ) { #ifdef DEBUG // check that the matrix we are copying from is initialised ASSERT_MSG( from->init, "mtx_copy() : attempt to copy from uninitialised matrix" ); #endif // initialise the target matrix if( to->init ) mtx_free( to ); mtx_init( to, from->nrows, from->ncols ); // copy the data dcopy( from->nrows*from->ncols, from->dat, 1, to->dat, 1 ); if( from->tau ) { if( to->nrows>to->ncols ) { to->tau = (double*)malloc( to->nrows*sizeof(double) ); dcopy( from->nrows, from->tau, 1, to->tau, 1 ); } else { to->tau = (double*)malloc( to->ncols*sizeof(double) ); dcopy( from->ncols, from->tau, 1, to->tau, 1 ); } } }
void Prism::PutFace(double *from, int fac ){ int i; if(from){ switch(fac){ case 0: dcopy(qa*qb, from ,1 ,**h_3d ,1); break; case 1: for(i = 0; i < qc; ++i) dcopy(qa, from + i*qa, 1, **h_3d + i*qa*qb, 1); break; case 2: for(i = 0; i < qc; ++i) dcopy(qb, from+i*qb, 1, **h_3d + qa-1 + i*qa*qb, qa); break; case 3: for(i = 0; i < qc; ++i) dcopy(qa, from+i*qa, 1, **h_3d + qa*(qb-1) + i*qa*qb, 1); break; case 4: for(i = 0; i < qc; ++i) dcopy(qb, from + i*qb, 1, **h_3d + i*qa*qb, qa); break; default: error_msg(GetFace -- unknown face); break; } } else{ switch(fac){ case 0: dzero(qa*qb, **h_3d ,1); break; case 1: for(i = 0; i < qc; ++i) dzero(qa, **h_3d + i*qa*qb, 1); break; case 2: for(i = 0; i < qc; ++i) dzero(qb, **h_3d + qa-1 + i*qa*qb, qa); break; case 3: for(i = 0; i < qc; ++i) dzero(qa, **h_3d + qa*(qb-1) + i*qa*qb, 1); break; case 4: for(i = 0; i < qc; ++i) dzero(qb, **h_3d + i*qa*qb, qa); break; default: error_msg(GetFace -- unknown face); break; } } }
void set_order_CNAB_adj(int Je) { dcopy(3, Alpha_CNAB[Je-1], 1, Alpha_Int, 1); dcopy(3, Beta_CNAB_adj[Je-1], 1, Beta_Int, 1); Gamma_Int = Gamma_CNAB[Je-1]; if(Je == 3) { fprintf(stderr,"Need to set up appropriate adjoint weight for Je=3\n"); exit(1); } }
void offload_dGetVector(int n, double *x, int incx, double *y, int incy){ /* * copy x at device to y at host * incx is the index increment of x, incy is the index increment of y * n elements are copied * algorithm works for negative values of incx and incy, but gives undefined behavior */ // assert(n >= 0); // copy x to DBUFFER, offload transfer out to DBUFFER, copy to y offload_Sync(); int incB = 1; int start = 0; int end = start + BUFFERSIZE - 1; end = MIN(end, n - 1); int length = MIN(end - start + 1, BUFFERSIZE); int tlength; double *ystart = y + start*incy; double *tystart; intptr_t xptr = (intptr_t)x; offload_Sync(); #pragma offload target(mic:MYDEVICE) out(DBUFFER:length(length) alloc_if(0) free_if(0)) \ in(xptr,incx,length,incx,incB) { double *xstart = ((double*)xptr) + start*incx; dcopy(&length, xstart, &incx, DBUFFER, &incB); } start = end + 1; for(; start < n; start = end + 1){ end = start + BUFFERSIZE - 1; end = MIN(end, n - 1); tlength = length; length = MIN(end - start + 1, BUFFERSIZE); tystart = ystart; ystart = y + start*incy; #pragma offload target(mic:MYDEVICE) nocopy(DBUFFER:alloc_if(0) free_if(0)) \ in(xptr,incx,length,incx,incB) signal(&WAIT) { double *xstart = ((double*)xptr) + start*incx; dcopy(&length, xstart, &incx, DBUFFER, &incB); } dcopy(&tlength, DBUFFER, &incB, tystart, &incy); #pragma offload_transfer target(mic:MYDEVICE) out(DBUFFER:length(length) alloc_if(0) free_if(0)) wait(&WAIT) } dcopy(&length, DBUFFER, &incB, ystart, &incy); SYNC = true; }
void Tri::GetFace(double *from, int fac, double *to){ switch(fac){ case 0: dcopy(qa, from, 1, to, 1); break; case 1: dcopy(qb, from + qa-1, qa, to, 1); break; case 2: dcopy(qb, from , qa, to, 1); break; default: error_msg(GetFace -- unknown face); break; } }
/* compute the slope vector dy for the transient equation * dy + cy = p. useful in the transient solver */ void slope_fn_block(block_model_t *model, double *y, double *p, double *dy) { /* shortcuts */ int n = model->n_nodes; double **c = model->c; /* for our equation, dy = p - cy */ #if (MATHACCEL == MA_INTEL || MATHACCEL == MA_APPLE) /* dy = p */ cblas_dcopy(n, p, 1, dy, 1); /* dy = dy - c*y = p - c*y */ cblas_dgemv(CblasRowMajor, CblasNoTrans, n, n, -1, c[0], n, y, 1, 1, dy, 1); #elif (MATHACCEL == MA_AMD || MATHACCEL == MA_SUN) /* dy = p */ dcopy(n, p, 1, dy, 1); /* dy = dy - c*y = p - c*y */ dgemv('T', n, n, -1, c[0], n, y, 1, 1, dy, 1); #else int i; double *t = dvector(n); matvectmult(t, c, y, n); for (i = 0; i < n; i++) dy[i] = p[i]-t[i]; free_dvector(t); #endif }
void donefds(void) { xclose(0); xclose(1); xclose(2); didfds = 0; #ifdef NISPLUS { int fd = xopen(_PATH_DEVNULL, O_RDONLY|O_LARGEFILE); (void)dcopy(fd, 1); (void)dcopy(fd, 2); (void)dmove(fd, 0); } #endif /*NISPLUS*/ }
void Quad::fillvec(Mode *v, double *f){ register int i; for(i = 0; i < qb; ++i) dcopy(qa,v->a,1,f+i*qa,1); for(i = 0; i < qa; ++i) dvmul(qb,v->b,1,f+i,qa,f+i,qa); }
void dtransp(long m, long n, double *in, double *out) { long i,j; j = 1; for (i=0; i<m; i++) { dcopy(&n, &in[i], &m, &out[i*n], &j); } }
void collectMatrix(Matrix u) { #ifdef HAVE_MPI int source, dest; // south MPI_Cart_shift(*u->as_vec->comm, 1, -1, &source, &dest); MPI_Sendrecv(u->data[1]+1, u->rows-2, MPI_DOUBLE, dest, 0, u->data[u->cols-1]+1, u->rows-2, MPI_DOUBLE, source, 0, *u->as_vec->comm, MPI_STATUS_IGNORE); // north MPI_Cart_shift(*u->as_vec->comm, 1, 1, &source, &dest); MPI_Sendrecv(u->data[u->cols-2]+1, u->rows-2, MPI_DOUBLE, dest, 1, u->data[0]+1, u->rows-2, MPI_DOUBLE, source, 1, *u->as_vec->comm, MPI_STATUS_IGNORE); Vector sendBuf = createVector(u->cols-2); Vector recvBuf = createVector(u->cols-2); // west MPI_Cart_shift(*u->as_vec->comm, 0, -1, &source, &dest); if (dest != MPI_PROC_NULL) copyVectorDispl(sendBuf, u->row[1], u->cols-2, 1); MPI_Sendrecv(sendBuf->data, sendBuf->len, MPI_DOUBLE, dest, 2, recvBuf->data, recvBuf->len, MPI_DOUBLE, source, 2, *u->as_vec->comm, MPI_STATUS_IGNORE); if (source != MPI_PROC_NULL) dcopy(&recvBuf->len, recvBuf->data, &recvBuf->stride, u->row[u->rows-1]->data+u->rows, &u->rows); // east MPI_Cart_shift(*u->as_vec->comm, 0, 1, &source, &dest); if (dest != MPI_PROC_NULL) copyVectorDispl(sendBuf, u->row[u->rows-2], u->cols-2, 1); MPI_Sendrecv(sendBuf->data, sendBuf->len, MPI_DOUBLE, dest, 2, recvBuf->data, recvBuf->len, MPI_DOUBLE, source, 2, *u->as_vec->comm, MPI_STATUS_IGNORE); if (source != MPI_PROC_NULL) dcopy(&recvBuf->len, recvBuf->data, &recvBuf->stride, u->row[0]->data+u->rows, &u->rows); freeVector(sendBuf); freeVector(recvBuf); #endif }
bool rDenseMatrix::copyFrom(rDenseMatrix& other) { if (this == &other) { return _SUCCESS; } int length; switch(other.De_Di) { case DENSE: De_Di = DENSE; if (de_ele && (other.nRow!=nRow || other.nCol!=nCol)) { delete[] de_ele; de_ele = NULL; } nRow = other.nRow; nCol = other.nCol; if (de_ele==NULL) { rNewCheck(); de_ele = new double[nRow*nCol]; if (de_ele==NULL) { rError("rDenseMatrix:: memory exhausted"); } } length = nRow*nCol; dcopy(&length,other.de_ele,&IONE,de_ele,&IONE); break; case DIAGONAL: De_Di = DIAGONAL; if (di_ele && (other.nRow!=nRow || other.nCol!=nCol)) { delete[] di_ele; di_ele = NULL; } nRow = other.nRow; nCol = other.nCol; if (di_ele==NULL) { rNewCheck(); di_ele = new double[nCol]; if (di_ele==NULL) { rError("rDenseMatrix:: memory exhausted"); } } dcopy(&nCol,other.di_ele,&IONE,di_ele,&IONE); break; } return _SUCCESS; }
/* Assumes column-major */ void Matrix_RemoveRow(PT_Matrix pA, ptrdiff_t row) { /* ASSERT(pA->rows > 0)*/ dcopy(&(Matrix_Cols(pA)), &(C_SEL(pA,Matrix_Rows(pA)-1,0)), &(pA->rows_alloc), &(C_SEL(pA,row,0)), &(pA->rows_alloc)); pA->rows = pA->rows - 1; }
void KNITRO_EXPORT KTR_dcopy (const int n, const double * const x, const int incx, double * const y, const int incy) { dcopy (n, x, incx, y, incy); return; }
//=============================================================================// matrix::matrix(const matrix &t) { rows=t.rows; cols=t.cols; int size=rows*cols; int one=1; array1d= new double[size]; dcopy(&size,t.array1d,&one,array1d,&one); }
static void interpolate (void) /* ------------------------------------------------------------------------- * * Interpolate from the GLL mesh to an evenly-spaced mesh. * ------------------------------------------------------------------------- */ { register int k, m, nplane_new; const int nplane_old = nr * ns * nel; const double *imr, *itmr, *ims, *itms; double *mesh_x, *mesh_y; double **newplane = (double**) malloc (nz * sizeof (double*)); switch (np) { case 0: /* interpolation turned off */ return; break; case 1: /* no size specified ... use (NR|NS) */ np = MAX (nr, ns); break; default: /* size specified on the command line */ break; } nplane_new = np * np * nel; /* -- Compute interpolation matrices. */ proj (&imr, &itmr, nr, GLJ, 0.0, 0.0, np, TRZ, 0.0, 0.0); proj (&ims, &itms, ns, GLJ, 0.0, 0.0, np, TRZ, 0.0, 0.0); /* -- Interpolate the mesh. */ mesh_x = do_interp (imr, itmr, ims, itms, x); mesh_y = do_interp (imr, itmr, ims, itms, y); free (x); x = mesh_x; free (y); y = mesh_y; /* -- Interpolate data plane-by-plane. */ for (k = 0; k < nfields; k++) { for (m = 0; m < nz; m++) newplane[m] = do_interp (imr, itmr, ims, itms, data[k] + m * nplane_old); free (data[k]); data[k] = (double*) malloc (nplane_new * nzp * sizeof (double)); for (m = 0; m < nz; m++) { dcopy (nplane_new, newplane[m], 1, data[k] + m * nplane_new, 1); free (newplane[m]); } } nr = ns = np; }
/* Replaces a row with the given vector */ void Matrix_ReplaceRow(PT_Matrix pA, ptrdiff_t krow, double *vec) { ptrdiff_t incx = 1; /* ASSERT(krow < pA->rows)*/ dcopy(&(Matrix_Cols(pA)), vec, &incx, &(C_SEL(pA,krow,0)), &(pA->rows_alloc)); }
/* Replaces a column with the given vector */ void Matrix_ReplaceCol(PT_Matrix pA, ptrdiff_t kcol, double *vec) { ptrdiff_t incx = 1; /* ASSERT(kcol < pA->cols)*/ dcopy(&(Matrix_Rows(pA)), vec, &incx, &(C_SEL(pA,0,kcol)), &incx); }
INT NS_DIM_PREFIX decopy (MULTIGRID *mg, INT fl, INT tl, INT mode, EVECDATA_DESC *x, const EVECDATA_DESC *y) { INT i,ret,level; ret=dcopy(mg,fl,tl,mode,x->vd,y->vd); if (ret!=NUM_OK) return ret; for (level=fl; level<=tl; level++) for (i=0; i<x->n; i++) EVDD_E(x,level,i)=EVDD_E(y,level,i); return NUM_OK; }
Vector collectBeforePre(Vector u) { collectVector(u); Vector result; if (u->comm_rank == 0) { result=createVector(u->len-1); int len=u->len-1; dcopy(&len, u->data+1, &u->stride, result->data, &result->stride); } else if (u->comm_rank == u->comm_size-1) { result=createVector(u->len-1); int len=u->len-1; dcopy(&len, u->data, &u->stride, result->data, &result->stride); } else { result=createVector(u->len); copyVector(result, u); } return result; }
/* Assumes column-major */ void Matrix_RemoveCol(PT_Matrix pA, ptrdiff_t col) { ptrdiff_t incx = 1; /* ASSERT(pA->cols > 0)*/ dcopy(&(Matrix_Rows(pA)), &(C_SEL(pA,0,Matrix_Cols(pA)-1)), &incx, &(C_SEL(pA,0,col)), &incx); pA->cols = pA->cols - 1; }
NLuint nlSolve_CG_precond() { NLdouble* b = nlCurrentContext->b ; NLdouble* x = nlCurrentContext->x ; NLdouble eps = nlCurrentContext->threshold ; NLuint max_iter = nlCurrentContext->max_iterations ; NLint N = nlCurrentContext->n ; NLdouble* r = NL_NEW_ARRAY(NLdouble, N) ; NLdouble* d = NL_NEW_ARRAY(NLdouble, N) ; NLdouble* h = NL_NEW_ARRAY(NLdouble, N) ; NLdouble *Ad = h; NLuint its=0; NLdouble rh, alpha, beta; NLdouble b_square = ddot(N,b,1,b,1); NLdouble err=eps*eps*b_square; NLint i; NLdouble * Ax=NL_NEW_ARRAY(NLdouble,nlCurrentContext->n); NLdouble accu =0.0; NLdouble curr_err; nlCurrentContext->matrix_vector_prod(x,r); daxpy(N,-1.,b,1,r,1); nlCurrentContext->precond_vector_prod(r,d); dcopy(N,d,1,h,1); rh=ddot(N,r,1,h,1); curr_err = ddot(N,r,1,r,1); while ( curr_err >err && its < max_iter) { if(!(its % 100)) { printf ( "%d : %.10e -- %.10e\n", its, curr_err, err ) ; } nlCurrentContext->matrix_vector_prod(d,Ad); alpha=rh/ddot(N,d,1,Ad,1); daxpy(N,-alpha,d,1,x,1); daxpy(N,-alpha,Ad,1,r,1); nlCurrentContext->precond_vector_prod(r,h); beta=1./rh; rh=ddot(N,r,1,h,1); beta*=rh; dscal(N,beta,d,1); daxpy(N,1.,h,1,d,1); ++its; // calcul de l'erreur courante curr_err = ddot(N,r,1,r,1); } nlCurrentContext->matrix_vector_prod(x,Ax); for(i = 0 ; i < N ; ++i) accu+=(Ax[i]-b[i])*(Ax[i]-b[i]); printf("in OpenNL : ||Ax-b||/||b|| = %e\n",sqrt(accu)/sqrt(b_square)); NL_DELETE_ARRAY(Ax); NL_DELETE_ARRAY(r) ; NL_DELETE_ARRAY(d) ; NL_DELETE_ARRAY(h) ; return its; }
void gdsum (double *x, int n, double *work) { register int i; MPI_Allreduce (x, work, n, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); /* *x = *work; */ dcopy(n,work,1,x,1); return; }
/* Assumes column-major format */ void Matrix_AddRow(PT_Matrix pA, double *row) { ptrdiff_t incy = 1; /* ASSERT(pA->rows < pA->rows_alloc)*/ dcopy(&(Matrix_Cols(pA)), row, &incy, &(C_SEL(pA,pA->rows,0)), &(pA->rows_alloc)); pA->rows = pA->rows + 1; }
/* Assumes column-major */ void Matrix_AddCol(PT_Matrix pA, double *col) { ptrdiff_t incx = 1; /* ASSERT(pA->cols < pA->cols_alloc)*/ dcopy(&(Matrix_Rows(pA)), col, &incx, &(C_SEL(pA,0,pA->cols)), &incx); pA->cols = pA->cols + 1; }