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;
}
