static void SetInitialProfiles(N_Vector u, realtype dx, realtype dy)
{
int jx, jy;
realtype x, y, cx, cy;
realtype *udata;
/* Set pointer to data array in vector u. */
udata = N_VGetArrayPointer_Serial(u);
/* Load initial profiles of c1 and c2 into u vector */
for (jy = 0; jy < MY; jy++) {
y = YMIN + jy*dy;
cy = SUNSQR(RCONST(0.1)*(y - YMID));
cy = ONE - cy + RCONST(0.5)*SUNSQR(cy);
for (jx = 0; jx < MX; jx++) {
x = XMIN + jx*dx;
cx = SUNSQR(RCONST(0.1)*(x - XMID));
cx = ONE - cx + RCONST(0.5)*SUNSQR(cx);
IJKth(udata,1,jx,jy) = C1_SCALE*cx*cy;
IJKth(udata,2,jx,jy) = C2_SCALE*cx*cy;
}
}
}
/* This routine computes and loads the vector of initial values. */
static void CInit(N_Vector c, WebData wdata)
{
int jx, jy, ns, mxns, ioff, iyoff, i, ici;
realtype argx, argy, x, y, dx, dy, x_factor, y_factor, *cdata;
cdata = N_VGetArrayPointer_Serial(c);
ns = wdata->ns;
mxns = wdata->mxns;
dx = wdata->dx;
dy = wdata->dy;
x_factor = RCONST(4.0)/SUNSQR(AX);
y_factor = RCONST(4.0)/SUNSQR(AY);
for (jy = 0; jy < MY; jy++) {
y = jy*dy;
argy = SUNSQR(y_factor*y*(AY-y));
iyoff = mxns*jy;
for (jx = 0; jx < MX; jx++) {
x = jx*dx;
argx = SUNSQR(x_factor*x*(AX-x));
ioff = iyoff + ns*jx;
for (i = 1; i <= ns; i++) {
ici = ioff + i-1;
cdata[ici] = RCONST(10.0) + i*argx*argy;
}
}
}
}
static void InitUserData(int my_pe, long int local_N, MPI_Comm comm,
UserData data)
{
int isubx, isuby;
/* Set problem constants */
data->om = PI/HALFDAY;
data->dx = (XMAX-XMIN)/((realtype)(MX-1));
data->dy = (YMAX-YMIN)/((realtype)(MY-1));
data->hdco = KH/SUNSQR(data->dx);
data->haco = VEL/(RCONST(2.0)*data->dx);
data->vdco = (RCONST(1.0)/SUNSQR(data->dy))*KV0;
/* Set machine-related constants */
data->comm = comm;
data->my_pe = my_pe;
data->Nlocal = local_N;
/* isubx and isuby are the PE grid indices corresponding to my_pe */
isuby = my_pe/NPEX;
isubx = my_pe - isuby*NPEX;
data->isubx = isubx;
data->isuby = isuby;
/* Set the sizes of a boundary x-line in u and uext */
data->nvmxsub = NVARS*MXSUB;
data->nvmxsub2 = NVARS*(MXSUB+2);
}
static void CInit(N_Vector c, WebData wdata)
{
int i, ici, ioff, iyoff, jx, jy, ns, mxns;
realtype argx, argy, x, y, dx, dy, x_factor, y_factor, *cdata;
cdata = N_VGetArrayPointer(c);
ns = wdata->ns;
mxns = wdata->mxns;
dx = wdata->dx;
dy = wdata->dy;
x_factor = RCONST(4.0)/SUNSQR(AX);
y_factor = RCONST(4.0)/SUNSQR(AY);
for (jy = 0; jy < MY; jy++) {
y = jy*dy;
argy = SUNSQR(y_factor*y*(AY-y));
iyoff = mxns*jy;
for (jx = 0; jx < MX; jx++) {
x = jx*dx;
argx = SUNSQR(x_factor*x*(AX-x));
ioff = iyoff + ns*jx;
for (i = 1; i <= ns; i++) {
ici = ioff + i-1;
cdata[ici] = RCONST(10.0) + i*argx*argy;
/*if(i==1) cdata[ici] += ONE;*/
}
}
}
/* Initialize quadrature variable to zero */
cdata[NEQ] = ZERO;
}
static void InitUserData(UserData data)
{
data->om = PI/HALFDAY;
data->dx = (XMAX-XMIN)/(MX-1);
data->dy = (YMAX-YMIN)/(MY-1);
data->hdco = KH/SUNSQR(data->dx);
data->haco = VEL/(TWO*data->dx);
data->vdco = (ONE/SUNSQR(data->dy))*KV0;
}
static void InitUserData(WebData wdata)
{
int i, j, ns;
realtype *bcoef, *diff, *cox, *coy, dx, dy;
realtype (*acoef)[NS];
acoef = wdata->acoef;
bcoef = wdata->bcoef;
diff = wdata->diff;
cox = wdata->cox;
coy = wdata->coy;
ns = wdata->ns = NS;
for (j = 0; j < NS; j++) {
for (i = 0; i < NS; i++) acoef[i][j] = 0.;
}
for (j = 0; j < NP; j++) {
for (i = 0; i < NP; i++) {
acoef[NP+i][j] = EE;
acoef[i][NP+j] = -GG;
}
acoef[j][j] = -AA;
acoef[NP+j][NP+j] = -AA;
bcoef[j] = BB;
bcoef[NP+j] = -BB;
diff[j] = DPREY;
diff[NP+j] = DPRED;
}
/* Set remaining problem parameters */
wdata->mxns = MXNS;
dx = wdata->dx = DX;
dy = wdata->dy = DY;
for (i = 0; i < ns; i++) {
cox[i] = diff[i]/SUNSQR(dx);
coy[i] = diff[i]/SUNSQR(dy);
}
/* Set remaining method parameters */
wdata->mp = MP;
wdata->mq = MQ;
wdata->mx = MX;
wdata->my = MY;
wdata->srur = SUNRsqrt(UNIT_ROUNDOFF);
wdata->mxmp = MXMP;
wdata->ngrp = NGRP;
wdata->ngx = NGX;
wdata->ngy = NGY;
SetGroups(MX, NGX, wdata->jgx, wdata->jigx, wdata->jxr);
SetGroups(MY, NGY, wdata->jgy, wdata->jigy, wdata->jyr);
}
int ModifiedGS(N_Vector *v, realtype **h, int k, int p,
realtype *new_vk_norm)
{
int i, k_minus_1, i0;
realtype new_norm_2, new_product, vk_norm, temp;
vk_norm = SUNRsqrt(N_VDotProd(v[k],v[k]));
k_minus_1 = k - 1;
i0 = SUNMAX(k-p, 0);
/* Perform modified Gram-Schmidt */
for (i=i0; i < k; i++) {
h[i][k_minus_1] = N_VDotProd(v[i], v[k]);
N_VLinearSum(ONE, v[k], -h[i][k_minus_1], v[i], v[k]);
}
/* Compute the norm of the new vector at v[k] */
*new_vk_norm = SUNRsqrt(N_VDotProd(v[k], v[k]));
/* If the norm of the new vector at v[k] is less than
FACTOR (== 1000) times unit roundoff times the norm of the
input vector v[k], then the vector will be reorthogonalized
in order to ensure that nonorthogonality is not being masked
by a very small vector length. */
temp = FACTOR * vk_norm;
if ((temp + (*new_vk_norm)) != temp) return(0);
new_norm_2 = ZERO;
for (i=i0; i < k; i++) {
new_product = N_VDotProd(v[i], v[k]);
temp = FACTOR * h[i][k_minus_1];
if ((temp + new_product) == temp) continue;
h[i][k_minus_1] += new_product;
N_VLinearSum(ONE, v[k],-new_product, v[i], v[k]);
new_norm_2 += SUNSQR(new_product);
}
if (new_norm_2 != ZERO) {
new_product = SUNSQR(*new_vk_norm) - new_norm_2;
*new_vk_norm = (new_product > ZERO) ? SUNRsqrt(new_product) : ZERO;
}
return(0);
}
realtype N_VWrmsNormMask_Parallel(N_Vector x, N_Vector w, N_Vector id)
{
long int i, N, N_global;
realtype sum, prodi, *xd, *wd, *idd, gsum;
MPI_Comm comm;
sum = ZERO;
xd = wd = idd = NULL;
N = NV_LOCLENGTH_P(x);
N_global = NV_GLOBLENGTH_P(x);
xd = NV_DATA_P(x);
wd = NV_DATA_P(w);
idd = NV_DATA_P(id);
comm = NV_COMM_P(x);
for (i = 0; i < N; i++) {
if (idd[i] > ZERO) {
prodi = xd[i]*wd[i];
sum += SUNSQR(prodi);
}
}
gsum = VAllReduce_Parallel(sum, 1, comm);
return(SUNRsqrt(gsum/N_global));
}
/* Set initial conditions in u */
static void SetInitialProfiles(HYPRE_IJVector Uij, UserData data, long int local_length,
long int my_base)
{
int isubx, isuby, lx, ly, jx, jy;
long int offset;
realtype dx, dy, x, y, cx, cy, xmid, ymid;
realtype *udata;
HYPRE_Int *iglobal;
/* Set pointer to data array in vector u */
udata = (realtype*) malloc(local_length*sizeof(realtype));
iglobal = (HYPRE_Int*) malloc(local_length*sizeof(HYPRE_Int));
/* Get mesh spacings, and subgrid indices for this PE */
dx = data->dx; dy = data->dy;
isubx = data->isubx; isuby = data->isuby;
/* Load initial profiles of c1 and c2 into local u vector.
Here lx and ly are local mesh point indices on the local subgrid,
and jx and jy are the global mesh point indices. */
offset = 0;
xmid = RCONST(0.5)*(XMIN + XMAX);
ymid = RCONST(0.5)*(YMIN + YMAX);
for (ly = 0; ly < MYSUB; ly++) {
jy = ly + isuby*MYSUB;
y = YMIN + jy*dy;
cy = SUNSQR(RCONST(0.1)*(y - ymid));
cy = RCONST(1.0) - cy + RCONST(0.5)*SUNSQR(cy);
for (lx = 0; lx < MXSUB; lx++) {
jx = lx + isubx*MXSUB;
x = XMIN + jx*dx;
cx = SUNSQR(RCONST(0.1)*(x - xmid));
cx = RCONST(1.0) - cx + RCONST(0.5)*SUNSQR(cx);
iglobal[offset] = my_base + offset;
udata[offset++] = C1_SCALE*cx*cy;
iglobal[offset] = my_base + offset;
udata[offset++] = C2_SCALE*cx*cy;
}
}
HYPRE_IJVectorSetValues(Uij, local_length, iglobal, udata);
free(iglobal);
free(udata);
}
static void SetInitialProfiles(N_Vector u, UserData data)
{
int isubx, isuby;
int lx, ly, jx, jy;
long int offset;
realtype dx, dy, x, y, cx, cy, xmid, ymid;
realtype *uarray;
/* Set pointer to data array in vector u */
uarray = N_VGetArrayPointer_Parallel(u);
/* Get mesh spacings, and subgrid indices for this PE */
dx = data->dx; dy = data->dy;
isubx = data->isubx; isuby = data->isuby;
/* Load initial profiles of c1 and c2 into local u vector.
Here lx and ly are local mesh point indices on the local subgrid,
and jx and jy are the global mesh point indices. */
offset = 0;
xmid = RCONST(0.5)*(XMIN + XMAX);
ymid = RCONST(0.5)*(YMIN + YMAX);
for (ly = 0; ly < MYSUB; ly++) {
jy = ly + isuby*MYSUB;
y = YMIN + jy*dy;
cy = SUNSQR(RCONST(0.1)*(y - ymid));
cy = RCONST(1.0) - cy + RCONST(0.5)*SUNSQR(cy);
for (lx = 0; lx < MXSUB; lx++) {
jx = lx + isubx*MXSUB;
x = XMIN + jx*dx;
cx = SUNSQR(RCONST(0.1)*(x - xmid));
cx = RCONST(1.0) - cx + RCONST(0.5)*SUNSQR(cx);
uarray[offset ] = C1_SCALE*cx*cy;
uarray[offset+1] = C2_SCALE*cx*cy;
offset = offset + 2;
}
}
}
/* Load constants in data */
static void InitUserData(int my_pe, MPI_Comm comm, UserData data)
{
int isubx, isuby;
int lx, ly;
/* Set problem constants */
data->om = PI/HALFDAY;
data->dx = (XMAX-XMIN)/((realtype)(MX-1));
data->dy = (YMAX-YMIN)/((realtype)(MY-1));
data->hdco = KH/SUNSQR(data->dx);
data->haco = VEL/(RCONST(2.0)*data->dx);
data->vdco = (RCONST(1.0)/SUNSQR(data->dy))*KV0;
/* Set machine-related constants */
data->comm = comm;
data->my_pe = my_pe;
/* isubx and isuby are the PE grid indices corresponding to my_pe */
isuby = my_pe/NPEX;
isubx = my_pe - isuby*NPEX;
data->isubx = isubx;
data->isuby = isuby;
/* Set the sizes of a boundary x-line in u and uext */
data->nvmxsub = NVARS*MXSUB;
data->nvmxsub2 = NVARS*(MXSUB+2);
/* Preconditioner-related fields */
for (lx = 0; lx < MXSUB; lx++) {
for (ly = 0; ly < MYSUB; ly++) {
(data->P)[lx][ly] = newDenseMat(NVARS, NVARS);
(data->Jbd)[lx][ly] = newDenseMat(NVARS, NVARS);
(data->pivot)[lx][ly] = newLintArray(NVARS);
}
}
}
realtype N_VWL2Norm_OpenMP(N_Vector x, N_Vector w)
{
long int i, N;
realtype sum, *xd, *wd;
sum = ZERO;
xd = wd = NULL;
N = NV_LENGTH_OMP(x);
xd = NV_DATA_OMP(x);
wd = NV_DATA_OMP(w);
#pragma omp parallel for default(none) private(i) shared(N,xd,wd) \
reduction(+:sum) schedule(static) num_threads(NV_NUM_THREADS_OMP(x))
for (i = 0; i < N; i++) {
sum += SUNSQR(xd[i]*wd[i]);
}
return(SUNRsqrt(sum));
}
realtype N_VWL2Norm_Parallel(N_Vector x, N_Vector w)
{
long int i, N;
realtype sum, prodi, *xd, *wd, gsum;
MPI_Comm comm;
sum = ZERO;
xd = wd = NULL;
N = NV_LOCLENGTH_P(x);
xd = NV_DATA_P(x);
wd = NV_DATA_P(w);
comm = NV_COMM_P(x);
for (i = 0; i < N; i++) {
prodi = xd[i]*wd[i];
sum += SUNSQR(prodi);
}
gsum = VAllReduce_Parallel(sum, 1, comm);
return(SUNRsqrt(gsum));
}
static int fB_local(long int NlocalB, realtype t,
N_Vector y, N_Vector yB, N_Vector dyB,
void *user_dataB)
{
realtype *YBdata, *dyBdata, *ydata;
realtype dx[DIM], c, v[DIM], cl[DIM], cr[DIM];
realtype adv[DIM], diff[DIM];
realtype xmin[DIM], xmax[DIM], x[DIM], x1;
int i[DIM], l_m[DIM], m_start[DIM], nbr_left[DIM], nbr_right[DIM], id;
ProblemData d;
int dim;
d = (ProblemData) user_dataB;
/* Extract stuff from data structure */
id = d->myId;
FOR_DIM {
xmin[dim] = d->xmin[dim];
xmax[dim] = d->xmax[dim];
l_m[dim] = d->l_m[dim];
m_start[dim] = d->m_start[dim];
dx[dim] = d->dx[dim];
nbr_left[dim] = d->nbr_left[dim];
nbr_right[dim] = d->nbr_right[dim];
}
dyBdata = NV_DATA_P(dyB);
ydata = NV_DATA_P(y);
/* Copy local segment of yB to y_ext */
Load_yext(NV_DATA_P(yB), d);
YBdata = d->y_ext;
/* Velocity components in x1 and x2 directions (Poiseuille profile) */
v[1] = ZERO;
#ifdef USE3D
v[2] = ZERO;
#endif
/* local domain is [xmin+(m_start)*dx, xmin+(m_start+l_m-1)*dx] */
#ifdef USE3D
for(i[2]=0; i[2]<l_m[2]; i[2]++) {
x[2] = xmin[2] + (m_start[2]+i[2])*dx[2];
#endif
for(i[1]=0; i[1]<l_m[1]; i[1]++) {
x[1] = xmin[1] + (m_start[1]+i[1])*dx[1];
/* Velocity component in x0 direction (Poiseuille profile) */
x1 = x[1] - xmin[1] - L;
v[0] = V_COEFF * (L + x1) * (L - x1);
for(i[0]=0; i[0]<l_m[0]; i[0]++) {
x[0] = xmin[0] + (m_start[0]+i[0])*dx[0];
c = IJth_ext(YBdata, i);
/* Source term for adjoint PDE */
IJth(dyBdata, i) = -IJth(ydata, i);
FOR_DIM {
i[dim]+=1;
cr[dim] = IJth_ext(YBdata, i);
i[dim]-=2;
cl[dim] = IJth_ext(YBdata, i);
i[dim]+=1;
/* Boundary conditions for the adjoint variables */
if( i[dim]==l_m[dim]-1 && nbr_right[dim]==id)
cr[dim] = cl[dim]-(TWO*dx[dim]*v[dim]/DIFF_COEF)*c;
else if( i[dim]==0 && nbr_left[dim]==id )
cl[dim] = cr[dim]+(TWO*dx[dim]*v[dim]/DIFF_COEF)*c;
adv[dim] = v[dim] * (cr[dim]-cl[dim]) / (TWO*dx[dim]);
diff[dim] = DIFF_COEF * (cr[dim]-TWO*c+cl[dim]) / SUNSQR(dx[dim]);
IJth(dyBdata, i) -= (diff[dim] + adv[dim]);
}
}
}
#ifdef USE3D
}
#endif
return(0);
}
static void SetSource(ProblemData d)
{
int *l_m, *m_start;
realtype *xmin, *xmax, *dx;
realtype x[DIM], g, *pdata;
int i[DIM];
l_m = d->l_m;
m_start = d->m_start;
xmin = d->xmin;
xmax = d->xmax;
dx = d->dx;
pdata = NV_DATA_P(d->p);
for(i[0]=0; i[0]<l_m[0]; i[0]++) {
x[0] = xmin[0] + (m_start[0]+i[0]) * dx[0];
for(i[1]=0; i[1]<l_m[1]; i[1]++) {
x[1] = xmin[1] + (m_start[1]+i[1]) * dx[1];
#ifdef USE3D
for(i[2]=0; i[2]<l_m[2]; i[2]++) {
x[2] = xmin[2] + (m_start[2]+i[2]) * dx[2];
g = G1_AMPL
* SUNRexp( -SUNSQR(G1_X-x[0])/SUNSQR(G1_SIGMA) )
* SUNRexp( -SUNSQR(G1_Y-x[1])/SUNSQR(G1_SIGMA) )
* SUNRexp( -SUNSQR(G1_Z-x[2])/SUNSQR(G1_SIGMA) );
g += G2_AMPL
* SUNRexp( -SUNSQR(G2_X-x[0])/SUNSQR(G2_SIGMA) )
* SUNRexp( -SUNSQR(G2_Y-x[1])/SUNSQR(G2_SIGMA) )
* SUNRexp( -SUNSQR(G2_Z-x[2])/SUNSQR(G2_SIGMA) );
if( g < G_MIN ) g = ZERO;
IJth(pdata, i) = g;
}
#else
g = G1_AMPL
* SUNRexp( -SUNSQR(G1_X-x[0])/SUNSQR(G1_SIGMA) )
* SUNRexp( -SUNSQR(G1_Y-x[1])/SUNSQR(G1_SIGMA) );
g += G2_AMPL
* SUNRexp( -SUNSQR(G2_X-x[0])/SUNSQR(G2_SIGMA) )
* SUNRexp( -SUNSQR(G2_Y-x[1])/SUNSQR(G2_SIGMA) );
if( g < G_MIN ) g = ZERO;
IJth(pdata, i) = g;
#endif
}
}
}
int QRfact(int n, realtype **h, realtype *q, int job)
{
realtype c, s, temp1, temp2, temp3;
int i, j, k, q_ptr, n_minus_1, code=0;
switch (job) {
case 0:
/* Compute a new factorization of H */
code = 0;
for (k=0; k < n; k++) {
/* Multiply column k by the previous k-1 Givens rotations */
for (j=0; j < k-1; j++) {
i = 2*j;
temp1 = h[j][k];
temp2 = h[j+1][k];
c = q[i];
s = q[i+1];
h[j][k] = c*temp1 - s*temp2;
h[j+1][k] = s*temp1 + c*temp2;
}
/* Compute the Givens rotation components c and s */
q_ptr = 2*k;
temp1 = h[k][k];
temp2 = h[k+1][k];
if( temp2 == ZERO) {
c = ONE;
s = ZERO;
} else if (SUNRabs(temp2) >= SUNRabs(temp1)) {
temp3 = temp1/temp2;
s = -ONE/SUNRsqrt(ONE+SUNSQR(temp3));
c = -s*temp3;
} else {
temp3 = temp2/temp1;
c = ONE/SUNRsqrt(ONE+SUNSQR(temp3));
s = -c*temp3;
}
q[q_ptr] = c;
q[q_ptr+1] = s;
if( (h[k][k] = c*temp1 - s*temp2) == ZERO) code = k+1;
}
break;
default:
/* Update the factored H to which a new column has been added */
n_minus_1 = n - 1;
code = 0;
/* Multiply the new column by the previous n-1 Givens rotations */
for (k=0; k < n_minus_1; k++) {
i = 2*k;
temp1 = h[k][n_minus_1];
temp2 = h[k+1][n_minus_1];
c = q[i];
s = q[i+1];
h[k][n_minus_1] = c*temp1 - s*temp2;
h[k+1][n_minus_1] = s*temp1 + c*temp2;
}
/* Compute new Givens rotation and multiply it times the last two
entries in the new column of H. Note that the second entry of
this product will be 0, so it is not necessary to compute it. */
temp1 = h[n_minus_1][n_minus_1];
temp2 = h[n][n_minus_1];
if (temp2 == ZERO) {
c = ONE;
s = ZERO;
} else if (SUNRabs(temp2) >= SUNRabs(temp1)) {
temp3 = temp1/temp2;
s = -ONE/SUNRsqrt(ONE+SUNSQR(temp3));
c = -s*temp3;
} else {
temp3 = temp2/temp1;
c = ONE/SUNRsqrt(ONE+SUNSQR(temp3));
s = -c*temp3;
}
q_ptr = 2*n_minus_1;
q[q_ptr] = c;
q[q_ptr+1] = s;
if ((h[n_minus_1][n_minus_1] = c*temp1 - s*temp2) == ZERO)
code = n;
}
return (code);
}
