int Rossler::Jacobian (long int N, DenseMat J, realtype t, N_Vector x, N_Vector fy,
void *jac_data, N_Vector tmp1, N_Vector tmp2, N_Vector tmp3) {
#endif
#ifdef CVODE26
int Rossler::Jacobian (int N, realtype t, N_Vector x, N_Vector fy, DlsMat J,
void *jac_data, N_Vector tmp1, N_Vector tmp2, N_Vector tmp3) {
#endif
realtype a, b, c;
realtype x1, x2, x3;
Parameters * parameters;
x1 = Ith (x, 0);
x2 = Ith (x, 1);
x3 = Ith (x, 2);
parameters = (Parameters *) jac_data;
a = parameters->At(0);
b = parameters->At(1);
c = parameters->At(2);
IJth (J, 0, 0) = 0.0;
IJth (J, 0, 1) = -1.0;
IJth (J, 0, 2) = -1.0;
IJth (J, 1, 0) = 1.0;
IJth (J, 1, 1) = a;
IJth (J, 1, 2) = 0.0;
IJth (J, 2, 0) = x3;
IJth (J, 2, 1) = 0.0;
IJth (J, 2, 2) = x1-c;
return CV_SUCCESS;
}
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
}
}
}
static void SetIC(N_Vector u, UserData data)
{
int i, j;
realtype x, y, dx, dy;
realtype *udata;
/* Extract needed constants from data */
dx = data->dx;
dy = data->dy;
/* Set pointer to data array in vector u. */
udata = N_VGetArrayPointer_Serial(u);
/* Load initial profile into u vector */
for (j=1; j <= MY; j++) {
y = j*dy;
for (i=1; i <= MX; i++) {
x = i*dx;
IJth(udata,i,j) = x*(XMAX - x)*y*(YMAX - y)*SUNRexp(FIVE*x*y);
}
}
}
static void PrintOutput(N_Vector u)
{
int i, j;
realtype dx, dy, x, y;
realtype *udata;
dx = ONE/(NX+1);
dy = ONE/(NY+1);
udata = NV_DATA_S(u);
printf(" ");
for (i=1; i<=NX; i+= SKIP) {
x = i*dx;
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf("%-8.5Lf ", x);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf("%-8.5f ", x);
#else
printf("%-8.5f ", x);
#endif
}
printf("\n\n");
for (j=1; j<=NY; j+= SKIP) {
y = j*dy;
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf("%-8.5Lf ", y);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf("%-8.5f ", y);
#else
printf("%-8.5f ", y);
#endif
for (i=1; i<=NX; i+= SKIP) {
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf("%-8.5Lf ", IJth(udata,i,j));
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf("%-8.5f ", IJth(udata,i,j));
#else
printf("%-8.5f ", IJth(udata,i,j));
#endif
}
printf("\n");
}
}
static int JacB(int NB, realtype t,
N_Vector y, N_Vector yB, N_Vector fyB,
DlsMat JB, void *user_dataB,
N_Vector tmp1B, N_Vector tmp2B, N_Vector tmp3B)
{
UserData data;
realtype y1, y2, y3;
realtype p1, p2, p3;
data = (UserData) user_dataB;
/* The p vector */
p1 = data->p[0]; p2 = data->p[1]; p3 = data->p[2];
/* The y vector */
y1 = Ith(y,1); y2 = Ith(y,2); y3 = Ith(y,3);
/* Load JB */
IJth(JB,1,1) = p1; IJth(JB,1,2) = -p1;
IJth(JB,2,1) = -p2*y3; IJth(JB,2,2) = p2*y3+2.0*p3*y2;
IJth(JB,2,3) = RCONST(-2.0)*p3*y2;
IJth(JB,3,1) = -p2*y2; IJth(JB,3,2) = p2*y2;
return(0);
}
static int Jac(realtype t, N_Vector y, N_Vector fy, SUNMatrix J,
void *user_data, N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype y2, y3;
UserData data;
realtype p1, p2, p3;
y2 = Ith(y,2); y3 = Ith(y,3);
data = (UserData) user_data;
p1 = data->p[0]; p2 = data->p[1]; p3 = data->p[2];
IJth(J,1,1) = -p1; IJth(J,1,2) = p2*y3; IJth(J,1,3) = p2*y2;
IJth(J,2,1) = p1; IJth(J,2,2) = -p2*y3-2*p3*y2; IJth(J,2,3) = -p2*y2;
IJth(J,3,1) = ZERO; IJth(J,3,2) = 2*p3*y2; IJth(J,3,3) = ZERO;
return(0);
}
static void Load_yext(realtype *src, ProblemData d)
{
int i[DIM], l_m[DIM], dim;
FOR_DIM l_m[dim] = d->l_m[dim];
/* copy local segment */
#ifdef USE3D
for (i[2]=0; i[2]<l_m[2]; i[2]++)
#endif
for(i[1]=0; i[1]<l_m[1]; i[1]++)
for(i[0]=0; i[0]<l_m[0]; i[0]++)
IJth_ext(d->y_ext, i) = IJth(src, i);
}
int jacrob(long int Neq, realtype tt, realtype cj,
N_Vector yy, N_Vector yp, N_Vector resvec,
DlsMat JJ, void *user_data,
N_Vector tempv1, N_Vector tempv2, N_Vector tempv3)
{
realtype *yval;
yval = NV_DATA_S(yy);
IJth(JJ,1,1) = RCONST(-0.04) - cj;
IJth(JJ,2,1) = RCONST(0.04);
IJth(JJ,3,1) = ONE;
IJth(JJ,1,2) = RCONST(1.0e4)*yval[2];
IJth(JJ,2,2) = RCONST(-1.0e4)*yval[2] - RCONST(6.0e7)*yval[1] - cj;
IJth(JJ,3,2) = ONE;
IJth(JJ,1,3) = RCONST(1.0e4)*yval[1];
IJth(JJ,2,3) = RCONST(-1.0e4)*yval[1];
IJth(JJ,3,3) = ONE;
return(0);
}
static int jacE(int N, realtype t,
N_Vector y, N_Vector fy,
DlsMat J, void *jac_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype y1, y2, y3;
y1 = Ith(y,1); y2 = Ith(y,2); y3 = Ith(y,3);
IJth(J,1,1) = RCONST(-0.04);
IJth(J,1,2) = RCONST(1.0e4)*y3;
IJth(J,1,3) = RCONST(1.0e4)*y2;
IJth(J,2,1) = RCONST(0.04);
IJth(J,2,2) = RCONST(-1.0e4)*y3-RCONST(6.0e7)*y2;
IJth(J,2,3) = RCONST(-1.0e4)*y2;
IJth(J,3,1) = ZERO;
IJth(J,3,2) = RCONST(6.0e7)*y2;
IJth(J,3,3) = ZERO;
return(0);
}
static void Jac(long int N, DenseMat J, realtype t,
N_Vector y, N_Vector fy, void *jac_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype y1, y2, y3;
y1 = Ith(y,1); y2 = Ith(y,2); y3 = Ith(y,3);
IJth(J,1,1) = RCONST(-0.04);
IJth(J,1,2) = RCONST(1.0e4)*y3;
IJth(J,1,3) = RCONST(1.0e4)*y2;
IJth(J,2,1) = RCONST(0.04);
IJth(J,2,2) = RCONST(-1.0e4)*y3-RCONST(6.0e7)*y2;
IJth(J,2,3) = RCONST(-1.0e4)*y2;
IJth(J,3,2) = RCONST(6.0e7)*y2;
}
static void Jac(long int N, DenseMat J, realtype t,
N_Vector y, N_Vector fy, void *jac_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype y1, y2, y3;
UserData data;
realtype p1, p2, p3;
y1 = Ith(y,1); y2 = Ith(y,2); y3 = Ith(y,3);
data = (UserData) jac_data;
p1 = data->p[0]; p2 = data->p[1]; p3 = data->p[2];
IJth(J,1,1) = -p1; IJth(J,1,2) = p2*y3; IJth(J,1,3) = p2*y2;
IJth(J,2,1) = p1; IJth(J,2,2) = -p2*y3-2*p3*y2; IJth(J,2,3) = -p2*y2;
IJth(J,3,2) = 2*p3*y2;
}
int Jac(long int N, realtype t,
N_Vector y, N_Vector fy, DlsMat J, void *user_data,
N_Vector tmp1, N_Vector tmp2, N_Vector tmp3)
{
realtype y1, y2, y3;
y1 = Ith(y,1); y2 = Ith(y,2); y3 = Ith(y,3);
IJth(J,1,1) = RCONST(-0.04);
IJth(J,1,2) = RCONST(1.0e4)*y3;
IJth(J,1,3) = RCONST(1.0e4)*y2;
IJth(J,2,1) = RCONST(0.04);
IJth(J,2,2) = RCONST(-1.0e4)*y3-RCONST(6.0e7)*y2;
IJth(J,2,3) = RCONST(-1.0e4)*y2;
IJth(J,3,2) = RCONST(6.0e7)*y2;
return(0);
}
static void PrintOutput(N_Vector uB, UserData data)
{
realtype *uBdata, uBij, uBmax, x, y, dx, dy;
int i, j;
x = y = ZERO;
dx = data->dx;
dy = data->dy;
uBdata = N_VGetArrayPointer(uB);
uBmax = ZERO;
for(j=1; j<= MY; j++) {
for(i=1; i<=MX; i++) {
uBij = IJth(uBdata, i, j);
if (SUNRabs(uBij) > uBmax) {
uBmax = uBij;
x = i*dx;
y = j*dy;
}
}
}
printf("\nMaximum sensitivity\n");
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf(" lambda max = %Le\n", uBmax);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf(" lambda max = %e\n", uBmax);
#else
printf(" lambda max = %e\n", uBmax);
#endif
printf("at\n");
#if defined(SUNDIALS_EXTENDED_PRECISION)
printf(" x = %Le\n y = %Le\n", x, y);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
printf(" x = %e\n y = %e\n", x, y);
#else
printf(" x = %e\n y = %e\n", x, y);
#endif
}
static int func(N_Vector u, N_Vector f, void *user_data)
{
realtype dx, dy, hdiff, vdiff;
realtype hdc, vdc;
realtype uij, udn, uup, ult, urt;
realtype *udata, *fdata;
realtype x,y;
int i, j;
dx = ONE/(NX+1);
dy = ONE/(NY+1);
hdc = ONE/(dx*dx);
vdc = ONE/(dy*dy);
udata = NV_DATA_S(u);
fdata = NV_DATA_S(f);
for (j=1; j <= NY; j++) {
y = j*dy;
for (i=1; i <= NX; i++) {
x = i*dx;
/* Extract u at x_i, y_j and four neighboring points */
uij = IJth(udata, i, j);
udn = (j == 1) ? ZERO : IJth(udata, i, j-1);
uup = (j == NY) ? ZERO : IJth(udata, i, j+1);
ult = (i == 1) ? ZERO : IJth(udata, i-1, j);
urt = (i == NX) ? ZERO : IJth(udata, i+1, j);
/* Evaluate diffusion components */
hdiff = hdc*(ult - TWO*uij + urt);
vdiff = vdc*(uup - TWO*uij + udn);
/* Set residual at x_i, y_j */
IJth(fdata, i, j) = hdiff + vdiff + uij - uij*uij*uij + 2.0;
}
}
return(0);
}
static int fB(realtype tB, N_Vector u, N_Vector uB, N_Vector uBdot,
void *user_dataB)
{
UserData data;
realtype *uBdata, *duBdata;
realtype hordc, horac, verdc;
realtype uBij, uBdn, uBup, uBlt, uBrt;
realtype hdiffB, hadvB, vdiffB;
int i, j;
uBdata = N_VGetArrayPointer(uB);
duBdata = N_VGetArrayPointer(uBdot);
/* Extract needed constants from data */
data = (UserData) user_dataB;
hordc = data->hdcoef;
horac = data->hacoef;
verdc = data->vdcoef;
/* Loop over all grid points. */
for (j=1; j <= MY; j++) {
for (i=1; i <= MX; i++) {
/* Extract u at x_i, y_j and four neighboring points */
uBij = IJth(uBdata, i, j);
uBdn = (j == 1) ? ZERO : IJth(uBdata, i, j-1);
uBup = (j == MY) ? ZERO : IJth(uBdata, i, j+1);
uBlt = (i == 1) ? ZERO : IJth(uBdata, i-1, j);
uBrt = (i == MX) ? ZERO : IJth(uBdata, i+1, j);
/* Set diffusion and advection terms and load into udot */
hdiffB = hordc*(- uBlt + TWO*uBij - uBrt);
hadvB = horac*(uBrt - uBlt);
vdiffB = verdc*(- uBup + TWO*uBij - uBdn);
IJth(duBdata, i, j) = hdiffB + hadvB + vdiffB - ONE;
}
}
return(0);
}
static int f(realtype t, N_Vector u,N_Vector udot, void *user_data)
{
realtype uij, udn, uup, ult, urt, hordc, horac, verdc, hdiff, hadv, vdiff;
realtype *udata, *dudata;
int i, j;
UserData data;
udata = N_VGetArrayPointer_Serial(u);
dudata = N_VGetArrayPointer_Serial(udot);
/* Extract needed constants from data */
data = (UserData) user_data;
hordc = data->hdcoef;
horac = data->hacoef;
verdc = data->vdcoef;
/* Loop over all grid points. */
for (j=1; j <= MY; j++) {
for (i=1; i <= MX; i++) {
/* Extract u at x_i, y_j and four neighboring points */
uij = IJth(udata, i, j);
udn = (j == 1) ? ZERO : IJth(udata, i, j-1);
uup = (j == MY) ? ZERO : IJth(udata, i, j+1);
ult = (i == 1) ? ZERO : IJth(udata, i-1, j);
urt = (i == MX) ? ZERO : IJth(udata, i+1, j);
/* Set diffusion and advection terms and load into udot */
hdiff = hordc*(ult - TWO*uij + urt);
hadv = horac*(urt - ult);
vdiff = verdc*(uup - TWO*uij + udn);
IJth(dudata, i, j) = hdiff + hadv + vdiff;
}
}
return(0);
}
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 f_comm(long int N_local, realtype t, N_Vector y, void *user_data)
{
int id, n[DIM], proc_cond[DIM], nbr[DIM][2];
ProblemData d;
realtype *yextdata, *ydata;
int l_m[DIM], dim;
int c, i[DIM], l[DIM-1];
realtype *buf_send, *buf_recv;
MPI_Status stat;
MPI_Comm comm;
int dir, size = 1, small = INT_MAX;
d = (ProblemData) user_data;
comm = d->comm;
id = d->myId;
/* extract data from domain*/
FOR_DIM {
n[dim] = d->num_procs[dim];
l_m[dim] = d->l_m[dim];
}
yextdata = d->y_ext;
ydata = NV_DATA_P(y);
/* Calculate required buffer size */
FOR_DIM {
size *= l_m[dim];
if( l_m[dim] < small) small = l_m[dim];
}
size /= small;
/* Adjust buffer size if necessary */
if( d->buf_size < size ) {
d->buf_send = (realtype*) realloc( d->buf_send, size * sizeof(realtype));
d->buf_recv = (realtype*) realloc( d->buf_recv, size * sizeof(realtype));
d->buf_size = size;
}
buf_send = d->buf_send;
buf_recv = d->buf_recv;
/* Compute the communication pattern; who sends first? */
/* if proc_cond==1 , process sends first in this dimension */
proc_cond[0] = (id%n[0])%2;
proc_cond[1] = ((id/n[0])%n[1])%2;
#ifdef USE3D
proc_cond[2] = (id/n[0]/n[1])%2;
#endif
/* Compute the actual communication pattern */
/* nbr[dim][0] is first proc to communicate with in dimension dim */
/* nbr[dim][1] the second one */
FOR_DIM {
nbr[dim][proc_cond[dim]] = d->nbr_left[dim];
nbr[dim][!proc_cond[dim]] = d->nbr_right[dim];
}
/* Communication: loop over dimension and direction (left/right) */
FOR_DIM {
for (dir=0; dir<=1; dir++) {
/* If subdomain at boundary, no communication in this direction */
if (id != nbr[dim][dir]) {
c=0;
/* Compute the index of the boundary (right or left) */
i[dim] = (dir ^ proc_cond[dim]) ? (l_m[dim]-1) : 0;
/* Loop over all other dimensions and copy data into buf_send */
l[0]=(dim+1)%DIM;
#ifdef USE3D
l[1]=(dim+2)%DIM;
for(i[l[1]]=0; i[l[1]]<l_m[l[1]]; i[l[1]]++)
#endif
for(i[l[0]]=0; i[l[0]]<l_m[l[0]]; i[l[0]]++)
buf_send[c++] = IJth(ydata, i);
if ( proc_cond[dim] ) {
/* Send buf_send and receive into buf_recv */
MPI_Send(buf_send, c, PVEC_REAL_MPI_TYPE, nbr[dim][dir], 0, comm);
MPI_Recv(buf_recv, c, PVEC_REAL_MPI_TYPE, nbr[dim][dir], 0, comm, &stat);
} else {
/* Receive into buf_recv and send buf_send*/
MPI_Recv(buf_recv, c, PVEC_REAL_MPI_TYPE, nbr[dim][dir], 0, comm, &stat);
MPI_Send(buf_send, c, PVEC_REAL_MPI_TYPE, nbr[dim][dir], 0, comm);
}
c=0;
/* Compute the index of the boundary (right or left) in yextdata */
i[dim] = (dir ^ proc_cond[dim]) ? l_m[dim] : -1;
/* Loop over all other dimensions and copy data into yextdata */
#ifdef USE3D
for(i[l[1]]=0; i[l[1]]<l_m[l[1]]; i[l[1]]++)
#endif
for(i[l[0]]=0; i[l[0]]<l_m[l[0]]; i[l[0]]++)
IJth_ext(yextdata, i) = buf_recv[c++];
}
} /* end loop over direction */
} /* end loop over dimension */
}
int main()
{
realtype fnormtol, fnorm;
N_Vector y, scale;
int flag;
void *kmem;
y = scale = NULL;
kmem = NULL;
/* -------------------------
* Print problem description
* ------------------------- */
printf("\n2D elliptic PDE on unit square\n");
printf(" d^2 u / dx^2 + d^2 u / dy^2 = u^3 - u + 2.0\n");
printf(" + homogeneous Dirichlet boundary conditions\n\n");
printf("Solution method: Anderson accelerated Picard iteration with band linear solver.\n");
printf("Problem size: %2ld x %2ld = %4ld\n",
(long int) NX, (long int) NY, (long int) NEQ);
/* --------------------------------------
* Create vectors for solution and scales
* -------------------------------------- */
y = N_VNew_Serial(NEQ);
if (check_flag((void *)y, "N_VNew_Serial", 0)) return(1);
scale = N_VNew_Serial(NEQ);
if (check_flag((void *)scale, "N_VNew_Serial", 0)) return(1);
/* ----------------------------------------------------------------------------------
* Initialize and allocate memory for KINSOL, set parametrs for Anderson acceleration
* ---------------------------------------------------------------------------------- */
kmem = KINCreate();
if (check_flag((void *)kmem, "KINCreate", 0)) return(1);
/* y is used as a template */
/* Use acceleration with up to 3 prior residuals */
flag = KINSetMAA(kmem, 3);
if (check_flag(&flag, "KINSetMAA", 1)) return(1);
flag = KINInit(kmem, func, y);
if (check_flag(&flag, "KINInit", 1)) return(1);
/* -------------------
* Set optional inputs
* ------------------- */
/* Specify stopping tolerance based on residual */
fnormtol = FTOL;
flag = KINSetFuncNormTol(kmem, fnormtol);
if (check_flag(&flag, "KINSetFuncNormTol", 1)) return(1);
/* -------------------------
* Attach band linear solver
* ------------------------- */
flag = KINBand(kmem, NEQ, NX, NX);
if (check_flag(&flag, "KINBand", 1)) return(1);
flag = KINDlsSetBandJacFn(kmem, jac);
if (check_flag(&flag, "KINDlsBandJacFn", 1)) return(1);
/* -------------
* Initial guess
* ------------- */
N_VConst_Serial(ZERO, y);
IJth(NV_DATA_S(y), 2, 2) = ONE;
/* ----------------------------
* Call KINSol to solve problem
* ---------------------------- */
/* No scaling used */
N_VConst_Serial(ONE,scale);
/* Call main solver */
flag = KINSol(kmem, /* KINSol memory block */
y, /* initial guess on input; solution vector */
KIN_PICARD, /* global strategy choice */
scale, /* scaling vector, for the variable cc */
scale); /* scaling vector for function values fval */
if (check_flag(&flag, "KINSol", 1)) return(1);
/* ------------------------------------
* Print solution and solver statistics
* ------------------------------------ */
/* Get scaled norm of the system function */
flag = KINGetFuncNorm(kmem, &fnorm);
if (check_flag(&flag, "KINGetfuncNorm", 1)) return(1);
printf("\nComputed solution (||F|| = %g):\n\n",fnorm);
PrintOutput(y);
PrintFinalStats(kmem);
/* -----------
* Free memory
* ----------- */
N_VDestroy_Serial(y);
N_VDestroy_Serial(scale);
KINFree(&kmem);
return(0);
}
static void OutputGradient(int myId, N_Vector qB, ProblemData d)
{
FILE *fid;
char filename[20];
int *l_m, *m_start, i[DIM],ip;
realtype *xmin, *xmax, *dx;
realtype x[DIM], *pdata, p, *qBdata, g;
sprintf(filename,"grad%03d.m",myId);
fid = fopen(filename,"w");
l_m = d->l_m;
m_start = d->m_start;
xmin = d->xmin;
xmax = d->xmax;
dx = d->dx;
qBdata = NV_DATA_P(qB);
pdata = NV_DATA_P(d->p);
/* Write matlab files with solutions from each process */
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 = IJth(qBdata, i);
p = IJth(pdata, i);
#if defined(SUNDIALS_EXTENDED_PRECISION)
fprintf(fid,"x%d(%d,1) = %Le; \n", myId, i[0]+1, x[0]);
fprintf(fid,"y%d(%d,1) = %Le; \n", myId, i[1]+1, x[1]);
fprintf(fid,"z%d(%d,1) = %Le; \n", myId, i[2]+1, x[2]);
fprintf(fid,"p%d(%d,%d,%d) = %Le; \n", myId, i[1]+1, i[0]+1, i[2]+1, p);
fprintf(fid,"g%d(%d,%d,%d) = %Le; \n", myId, i[1]+1, i[0]+1, i[2]+1, g);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
fprintf(fid,"x%d(%d,1) = %le; \n", myId, i[0]+1, x[0]);
fprintf(fid,"y%d(%d,1) = %le; \n", myId, i[1]+1, x[1]);
fprintf(fid,"z%d(%d,1) = %le; \n", myId, i[2]+1, x[2]);
fprintf(fid,"p%d(%d,%d,%d) = %le; \n", myId, i[1]+1, i[0]+1, i[2]+1, p);
fprintf(fid,"g%d(%d,%d,%d) = %le; \n", myId, i[1]+1, i[0]+1, i[2]+1, g);
#else
fprintf(fid,"x%d(%d,1) = %e; \n", myId, i[0]+1, x[0]);
fprintf(fid,"y%d(%d,1) = %e; \n", myId, i[1]+1, x[1]);
fprintf(fid,"z%d(%d,1) = %e; \n", myId, i[2]+1, x[2]);
fprintf(fid,"p%d(%d,%d,%d) = %e; \n", myId, i[1]+1, i[0]+1, i[2]+1, p);
fprintf(fid,"g%d(%d,%d,%d) = %e; \n", myId, i[1]+1, i[0]+1, i[2]+1, g);
#endif
}
#else
g = IJth(qBdata, i);
p = IJth(pdata, i);
#if defined(SUNDIALS_EXTENDED_PRECISION)
fprintf(fid,"x%d(%d,1) = %Le; \n", myId, i[0]+1, x[0]);
fprintf(fid,"y%d(%d,1) = %Le; \n", myId, i[1]+1, x[1]);
fprintf(fid,"p%d(%d,%d) = %Le; \n", myId, i[1]+1, i[0]+1, p);
fprintf(fid,"g%d(%d,%d) = %Le; \n", myId, i[1]+1, i[0]+1, g);
#elif defined(SUNDIALS_DOUBLE_PRECISION)
fprintf(fid,"x%d(%d,1) = %e; \n", myId, i[0]+1, x[0]);
fprintf(fid,"y%d(%d,1) = %e; \n", myId, i[1]+1, x[1]);
fprintf(fid,"p%d(%d,%d) = %e; \n", myId, i[1]+1, i[0]+1, p);
fprintf(fid,"g%d(%d,%d) = %e; \n", myId, i[1]+1, i[0]+1, g);
#else
fprintf(fid,"x%d(%d,1) = %e; \n", myId, i[0]+1, x[0]);
fprintf(fid,"y%d(%d,1) = %e; \n", myId, i[1]+1, x[1]);
fprintf(fid,"p%d(%d,%d) = %e; \n", myId, i[1]+1, i[0]+1, p);
fprintf(fid,"g%d(%d,%d) = %e; \n", myId, i[1]+1, i[0]+1, g);
#endif
#endif
}
}
fclose(fid);
/* Write matlab driver */
if (myId == 0) {
fid = fopen("grad.m","w");
#ifdef USE3D
fprintf(fid,"clear;\nfigure;\nhold on\n");
fprintf(fid,"trans = 0.7;\n");
fprintf(fid,"ecol = 'none';\n");
#if defined(SUNDIALS_EXTENDED_PRECISION)
fprintf(fid,"xp=[%Lf %Lf];\n",G1_X,G2_X);
fprintf(fid,"yp=[%Lf %Lf];\n",G1_Y,G2_Y);
fprintf(fid,"zp=[%Lf %Lf];\n",G1_Z,G2_Z);
#else
fprintf(fid,"xp=[%f %f];\n",G1_X,G2_X);
fprintf(fid,"yp=[%f %f];\n",G1_Y,G2_Y);
fprintf(fid,"zp=[%f %f];\n",G1_Z,G2_Z);
#endif
fprintf(fid,"ns = length(xp)*length(yp)*length(zp);\n");
for (ip=0; ip<d->npes; ip++) {
fprintf(fid,"\ngrad%03d;\n",ip);
fprintf(fid,"[X,Y,Z]=meshgrid(x%d,y%d,z%d);\n",ip,ip,ip);
fprintf(fid,"s%d=slice(X,Y,Z,g%d,xp,yp,zp);\n",ip,ip);
fprintf(fid,"for i = 1:ns\n");
fprintf(fid," set(s%d(i),'FaceAlpha',trans);\n",ip);
fprintf(fid," set(s%d(i),'EdgeColor',ecol);\n",ip);
fprintf(fid,"end\n");
}
fprintf(fid,"view(3)\n");
fprintf(fid,"\nshading interp\naxis equal\n");
#else
fprintf(fid,"clear;\nfigure;\n");
fprintf(fid,"trans = 0.7;\n");
fprintf(fid,"ecol = 'none';\n");
for (ip=0; ip<d->npes; ip++) {
fprintf(fid,"\ngrad%03d;\n",ip);
fprintf(fid,"\nsubplot(1,2,1)\n");
fprintf(fid,"s=surf(x%d,y%d,g%d);\n",ip,ip,ip);
fprintf(fid,"set(s,'FaceAlpha',trans);\n");
fprintf(fid,"set(s,'EdgeColor',ecol);\n");
fprintf(fid,"hold on\n");
fprintf(fid,"axis tight\n");
fprintf(fid,"box on\n");
fprintf(fid,"\nsubplot(1,2,2)\n");
fprintf(fid,"s=surf(x%d,y%d,p%d);\n",ip,ip,ip);
fprintf(fid,"set(s,'CData',g%d);\n",ip);
fprintf(fid,"set(s,'FaceAlpha',trans);\n");
fprintf(fid,"set(s,'EdgeColor',ecol);\n");
fprintf(fid,"hold on\n");
fprintf(fid,"axis tight\n");
fprintf(fid,"box on\n");
}
#endif
fclose(fid);
}
}
/* Preconditioner setup routine. Generate and preprocess P. */
static int Precond(realtype tn, N_Vector u, N_Vector fu,
booleantype jok, booleantype *jcurPtr,
realtype gamma, void *P_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
realtype c1, c2, cydn, cyup, diag, ydn, yup, q4coef, dely, verdco, hordco;
realtype **(*P)[MYSUB], **(*Jbd)[MYSUB];
long int nvmxsub, *(*pivot)[MYSUB], ier, offset;
int lx, ly, jx, jy, isubx, isuby;
realtype *udata, **a, **j;
PreconData predata;
UserData data;
/* Make local copies of pointers in P_data, pointer to u's data,
and PE index pair */
predata = (PreconData) P_data;
data = (UserData) (predata->f_data);
P = predata->P;
Jbd = predata->Jbd;
pivot = predata->pivot;
udata = NV_DATA_P(u);
isubx = data->isubx; isuby = data->isuby;
nvmxsub = data->nvmxsub;
if (jok) {
/* jok = TRUE: Copy Jbd to P */
for (ly = 0; ly < MYSUB; ly++)
for (lx = 0; lx < MXSUB; lx++)
dencopy(Jbd[lx][ly], P[lx][ly], NVARS, NVARS);
*jcurPtr = FALSE;
}
else {
/* jok = FALSE: Generate Jbd from scratch and copy to P */
/* Make local copies of problem variables, for efficiency */
q4coef = data->q4;
dely = data->dy;
verdco = data->vdco;
hordco = data->hdco;
/* Compute 2x2 diagonal Jacobian blocks (using q4 values
computed on the last f call). Load into P. */
for (ly = 0; ly < MYSUB; ly++) {
jy = ly + isuby*MYSUB;
ydn = YMIN + (jy - RCONST(0.5))*dely;
yup = ydn + dely;
cydn = verdco*EXP(RCONST(0.2)*ydn);
cyup = verdco*EXP(RCONST(0.2)*yup);
diag = -(cydn + cyup + RCONST(2.0)*hordco);
for (lx = 0; lx < MXSUB; lx++) {
jx = lx + isubx*MXSUB;
offset = lx*NVARS + ly*nvmxsub;
c1 = udata[offset];
c2 = udata[offset+1];
j = Jbd[lx][ly];
a = P[lx][ly];
IJth(j,1,1) = (-Q1*C3 - Q2*c2) + diag;
IJth(j,1,2) = -Q2*c1 + q4coef;
IJth(j,2,1) = Q1*C3 - Q2*c2;
IJth(j,2,2) = (-Q2*c1 - q4coef) + diag;
dencopy(j, a, NVARS, NVARS);
}
}
*jcurPtr = TRUE;
}
/* Scale by -gamma */
for (ly = 0; ly < MYSUB; ly++)
for (lx = 0; lx < MXSUB; lx++)
denscale(-gamma, P[lx][ly], NVARS, NVARS);
/* Add identity matrix and do LU decompositions on blocks in place */
for (lx = 0; lx < MXSUB; lx++) {
for (ly = 0; ly < MYSUB; ly++) {
denaddI(P[lx][ly], NVARS);
ier = denGETRF(P[lx][ly], NVARS, NVARS, pivot[lx][ly]);
if (ier != 0) return(1);
}
}
return(0);
}
static int Precond(realtype tn, N_Vector u, N_Vector fu,
booleantype jok, booleantype *jcurPtr, realtype gamma,
void *P_data, N_Vector vtemp1, N_Vector vtemp2,
N_Vector vtemp3)
{
realtype c1, c2, cydn, cyup, diag, ydn, yup, q4coef, dely, verdco, hordco;
realtype **(*P)[MY], **(*Jbd)[MY];
long int *(*pivot)[MY], ier;
int jx, jy;
realtype *udata, **a, **j;
UserData data;
/* Make local copies of pointers in P_data, and of pointer to u's data */
data = (UserData) P_data;
P = data->P;
Jbd = data->Jbd;
pivot = data->pivot;
udata = NV_DATA_S(u);
if (jok) {
/* jok = TRUE: Copy Jbd to P */
for (jy=0; jy < MY; jy++)
for (jx=0; jx < MX; jx++)
dencopy(Jbd[jx][jy], P[jx][jy], NUM_SPECIES);
*jcurPtr = FALSE;
}
else {
/* jok = FALSE: Generate Jbd from scratch and copy to P */
/* Make local copies of problem variables, for efficiency. */
q4coef = data->q4;
dely = data->dy;
verdco = data->vdco;
hordco = data->hdco;
/* Compute 2x2 diagonal Jacobian blocks (using q4 values
computed on the last f call). Load into P. */
for (jy=0; jy < MY; jy++) {
ydn = YMIN + (jy - RCONST(0.5))*dely;
yup = ydn + dely;
cydn = verdco*exp(RCONST(0.2)*ydn);
cyup = verdco*exp(RCONST(0.2)*yup);
diag = -(cydn + cyup + TWO*hordco);
for (jx=0; jx < MX; jx++) {
c1 = IJKth(udata,1,jx,jy);
c2 = IJKth(udata,2,jx,jy);
j = Jbd[jx][jy];
a = P[jx][jy];
IJth(j,1,1) = (-Q1*C3 - Q2*c2) + diag;
IJth(j,1,2) = -Q2*c1 + q4coef;
IJth(j,2,1) = Q1*C3 - Q2*c2;
IJth(j,2,2) = (-Q2*c1 - q4coef) + diag;
dencopy(j, a, NUM_SPECIES);
}
}
*jcurPtr = TRUE;
}
/* Scale by -gamma */
for (jy=0; jy < MY; jy++)
for (jx=0; jx < MX; jx++)
denscale(-gamma, P[jx][jy], NUM_SPECIES);
/* Add identity matrix and do LU decompositions on blocks in place. */
for (jx=0; jx < MX; jx++) {
for (jy=0; jy < MY; jy++) {
denaddI(P[jx][jy], NUM_SPECIES);
ier = gefa(P[jx][jy], NUM_SPECIES, pivot[jx][jy]);
if (ier != 0) return(1);
}
}
return(0);
}
static int Precond(realtype tn, N_Vector y, N_Vector fy, booleantype jok,
booleantype *jcurPtr, realtype gamma, void *P_data,
N_Vector vtemp1, N_Vector vtemp2, N_Vector vtemp3)
{
realtype c1, c2, czdn, czup, diag, zdn, zup, q4coef, delz, verdco, hordco;
realtype **(*P)[MZ], **(*Jbd)[MZ];
long int *(*pivot)[MZ];
int ier, jx, jz;
realtype *ydata, **a, **j;
UserData data;
realtype Q1, Q2, C3, A3, A4, KH, VEL, KV0;
/* Make local copies of pointers in P_data, and of pointer to y's data */
data = (UserData) P_data;
P = data->P;
Jbd = data->Jbd;
pivot = data->pivot;
ydata = NV_DATA_S(y);
/* Load problem coefficients and parameters */
Q1 = data->p[0];
Q2 = data->p[1];
C3 = data->p[2];
A3 = data->p[3];
A4 = data->p[4];
KH = data->p[5];
VEL = data->p[6];
KV0 = data->p[7];
if (jok) {
/* jok = TRUE: Copy Jbd to P */
for (jz=0; jz < MZ; jz++)
for (jx=0; jx < MX; jx++)
dencopy(Jbd[jx][jz], P[jx][jz], NUM_SPECIES);
*jcurPtr = FALSE;
}
else {
/* jok = FALSE: Generate Jbd from scratch and copy to P */
/* Make local copies of problem variables, for efficiency. */
q4coef = data->q4;
delz = data->dz;
verdco = data->vdco;
hordco = data->hdco;
/* Compute 2x2 diagonal Jacobian blocks (using q4 values
computed on the last f call). Load into P. */
for (jz=0; jz < MZ; jz++) {
zdn = ZMIN + (jz - RCONST(0.5))*delz;
zup = zdn + delz;
czdn = verdco*EXP(RCONST(0.2)*zdn);
czup = verdco*EXP(RCONST(0.2)*zup);
diag = -(czdn + czup + RCONST(2.0)*hordco);
for (jx=0; jx < MX; jx++) {
c1 = IJKth(ydata,1,jx,jz);
c2 = IJKth(ydata,2,jx,jz);
j = Jbd[jx][jz];
a = P[jx][jz];
IJth(j,1,1) = (-Q1*C3 - Q2*c2) + diag;
IJth(j,1,2) = -Q2*c1 + q4coef;
IJth(j,2,1) = Q1*C3 - Q2*c2;
IJth(j,2,2) = (-Q2*c1 - q4coef) + diag;
dencopy(j, a, NUM_SPECIES);
}
}
*jcurPtr = TRUE;
}
/* Scale by -gamma */
for (jz=0; jz < MZ; jz++)
for (jx=0; jx < MX; jx++)
denscale(-gamma, P[jx][jz], NUM_SPECIES);
/* Add identity matrix and do LU decompositions on blocks in place. */
for (jx=0; jx < MX; jx++) {
for (jz=0; jz < MZ; jz++) {
denaddI(P[jx][jz], NUM_SPECIES);
ier = gefa(P[jx][jz], NUM_SPECIES, pivot[jx][jz]);
if (ier != 0) return(1);
}
}
return(0);
}
static int jac(N_Vector y, N_Vector f,SUNMatrix J,
void *user_data, N_Vector tmp1, N_Vector tmp2)
{
int i;
realtype *yd;
realtype x1, x2, x3, x4, x5, x6, x7, x8;
yd = N_VGetArrayPointer_Serial(y);
x1 = yd[0];
x2 = yd[1];
x3 = yd[2];
x4 = yd[3];
x5 = yd[4];
x6 = yd[5];
x7 = yd[6];
x8 = yd[7];
/* Nonlinear equations */
/*
- 0.1238*x1 + x7 - 0.001637*x2
- 0.9338*x4 + 0.004731*x1*x3 - 0.3578*x2*x3 - 0.3571
*/
IJth(J,1,1) = - 0.1238 + 0.004731*x3;
IJth(J,1,2) = - 0.001637 - 0.3578*x3;
IJth(J,1,3) = 0.004731*x1 - 0.3578*x2;
IJth(J,1,4) = - 0.9338;
IJth(J,1,7) = 1.0;
/*
0.2638*x1 - x7 - 0.07745*x2
- 0.6734*x4 + 0.2238*x1*x3 + 0.7623*x2*x3 - 0.6022
*/
IJth(J,2,1) = 0.2638 + 0.2238*x3;
IJth(J,2,2) = - 0.07745 + 0.7623*x3;
IJth(J,2,3) = 0.2238*x1 + 0.7623*x2;
IJth(J,2,4) = - 0.6734;
IJth(J,2,7) = -1.0;
/*
0.3578*x1 + 0.004731*x2 + x6*x8
*/
IJth(J,3,1) = 0.3578;
IJth(J,3,2) = 0.004731;
IJth(J,3,6) = x8;
IJth(J,3,8) = x6;
/*
- 0.7623*x1 + 0.2238*x2 + 0.3461
*/
IJth(J,4,1) = - 0.7623;
IJth(J,4,2) = 0.2238;
/*
x1*x1 + x2*x2 - 1
*/
IJth(J,5,1) = 2.0*x1;
IJth(J,5,2) = 2.0*x2;
/*
x3*x3 + x4*x4 - 1
*/
IJth(J,6,3) = 2.0*x3;
IJth(J,6,4) = 2.0*x4;
/*
x5*x5 + x6*x6 - 1
*/
IJth(J,7,5) = 2.0*x5;
IJth(J,7,6) = 2.0*x6;
/*
x7*x7 + x8*x8 - 1
*/
IJth(J,8,7) = 2.0*x7;
IJth(J,8,8) = 2.0*x8;
/*
Lower bounds ( l_i = 1 + x_i >= 0)
l_i - 1.0 - x_i
*/
for(i=1;i<=8;i++) {
IJth(J,8+i,i) = -1.0;
IJth(J,8+i,8+i) = 1.0;
}
/*
Upper bounds ( u_i = 1 - x_i >= 0)
u_i - 1.0 + x_i
*/
for(i=1;i<=8;i++) {
IJth(J,16+i,i) = 1.0;
IJth(J,16+i,16+i) = 1.0;
}
return(0);
}
