PetscErrorCode SNESComputeJacobianDefaultColor(SNES snes,Vec x1,Mat J,Mat B,void *ctx)
{
MatFDColoring color = (MatFDColoring)ctx;
PetscErrorCode ierr;
DM dm;
MatColoring mc;
ISColoring iscoloring;
PetscBool hascolor;
PetscBool solvec,matcolor = PETSC_FALSE;
PetscFunctionBegin;
if (color) PetscValidHeaderSpecific(color,MAT_FDCOLORING_CLASSID,6);
if (!color) {ierr = PetscObjectQuery((PetscObject)B,"SNESMatFDColoring",(PetscObject*)&color);CHKERRQ(ierr);}
if (!color) {
ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr);
ierr = DMHasColoring(dm,&hascolor);CHKERRQ(ierr);
matcolor = PETSC_FALSE;
ierr = PetscOptionsGetBool(((PetscObject)snes)->options,((PetscObject)snes)->prefix,"-snes_fd_color_use_mat",&matcolor,NULL);CHKERRQ(ierr);
if (hascolor && !matcolor) {
ierr = DMCreateColoring(dm,IS_COLORING_GLOBAL,&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringCreate(B,iscoloring,&color);CHKERRQ(ierr);
ierr = MatFDColoringSetFunction(color,(PetscErrorCode (*)(void))SNESComputeFunctionCtx,NULL);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(color);CHKERRQ(ierr);
ierr = MatFDColoringSetUp(B,iscoloring,color);CHKERRQ(ierr);
ierr = ISColoringDestroy(&iscoloring);CHKERRQ(ierr);
} else {
ierr = MatColoringCreate(B,&mc);CHKERRQ(ierr);
ierr = MatColoringSetDistance(mc,2);CHKERRQ(ierr);
ierr = MatColoringSetType(mc,MATCOLORINGSL);CHKERRQ(ierr);
ierr = MatColoringSetFromOptions(mc);CHKERRQ(ierr);
ierr = MatColoringApply(mc,&iscoloring);CHKERRQ(ierr);
ierr = MatColoringDestroy(&mc);CHKERRQ(ierr);
ierr = MatFDColoringCreate(B,iscoloring,&color);CHKERRQ(ierr);
ierr = MatFDColoringSetFunction(color,(PetscErrorCode (*)(void))SNESComputeFunctionCtx,NULL);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(color);CHKERRQ(ierr);
ierr = MatFDColoringSetUp(B,iscoloring,color);CHKERRQ(ierr);
ierr = ISColoringDestroy(&iscoloring);CHKERRQ(ierr);
}
ierr = PetscObjectCompose((PetscObject)B,"SNESMatFDColoring",(PetscObject)color);CHKERRQ(ierr);
ierr = PetscObjectDereference((PetscObject)color);CHKERRQ(ierr);
}
/* F is only usable if there is no RHS on the SNES and the full solution corresponds to x1 */
ierr = VecEqual(x1,snes->vec_sol,&solvec);CHKERRQ(ierr);
if (!snes->vec_rhs && solvec) {
Vec F;
ierr = SNESGetFunction(snes,&F,NULL,NULL);CHKERRQ(ierr);
ierr = MatFDColoringSetF(color,F);CHKERRQ(ierr);
}
ierr = MatFDColoringApply(B,color,x1,snes);CHKERRQ(ierr);
if (J != B) {
ierr = MatAssemblyBegin(J,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(J,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
PetscErrorCode SNESComputeJacobianDefaultColor(SNES snes,Vec x1,Mat *J,Mat *B,MatStructure *flag,void *ctx)
{
MatFDColoring color = (MatFDColoring)ctx;
PetscErrorCode ierr;
DM dm;
PetscErrorCode (*func)(SNES,Vec,Vec,void*);
Vec F;
void *funcctx;
ISColoring iscoloring;
PetscBool hascolor;
PetscBool solvec;
PetscFunctionBegin;
if (color) PetscValidHeaderSpecific(color,MAT_FDCOLORING_CLASSID,6);
else {ierr = PetscObjectQuery((PetscObject)*B,"SNESMatFDColoring",(PetscObject*)&color);CHKERRQ(ierr);}
*flag = SAME_NONZERO_PATTERN;
ierr = SNESGetFunction(snes,&F,&func,&funcctx);CHKERRQ(ierr);
if (!color) {
ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr);
ierr = DMHasColoring(dm,&hascolor);CHKERRQ(ierr);
if (hascolor) {
ierr = DMCreateColoring(dm,IS_COLORING_GLOBAL,&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringCreate(*B,iscoloring,&color);CHKERRQ(ierr);
ierr = ISColoringDestroy(&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFunction(color,(PetscErrorCode (*)(void))func,funcctx);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(color);CHKERRQ(ierr);
} else {
ierr = MatGetColoring(*B,MATCOLORINGSL,&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringCreate(*B,iscoloring,&color);CHKERRQ(ierr);
ierr = ISColoringDestroy(&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFunction(color,(PetscErrorCode (*)(void))func,(void*)funcctx);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(color);CHKERRQ(ierr);
}
ierr = PetscObjectCompose((PetscObject)*B,"SNESMatFDColoring",(PetscObject)color);CHKERRQ(ierr);
ierr = PetscObjectDereference((PetscObject)color);CHKERRQ(ierr);
}
/* F is only usable if there is no RHS on the SNES and the full solution corresponds to x1 */
ierr = VecEqual(x1,snes->vec_sol,&solvec);CHKERRQ(ierr);
if (!snes->vec_rhs && solvec) {
ierr = MatFDColoringSetF(color,F);CHKERRQ(ierr);
}
ierr = MatFDColoringApply(*B,color,x1,flag,snes);CHKERRQ(ierr);
if (*J != *B) {
ierr = MatAssemblyBegin(*J,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(*J,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
static PetscErrorCode SNESComputeJacobian_DMLocal(SNES snes,Vec X,Mat A,Mat B,void *ctx)
{
PetscErrorCode ierr;
DM dm;
DMSNES_Local *dmlocalsnes = (DMSNES_Local*)ctx;
Vec Xloc;
PetscFunctionBegin;
ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr);
if (dmlocalsnes->jacobianlocal) {
ierr = DMGetLocalVector(dm,&Xloc);CHKERRQ(ierr);
ierr = VecZeroEntries(Xloc);CHKERRQ(ierr);
if (dmlocalsnes->boundarylocal) {ierr = (*dmlocalsnes->boundarylocal)(dm,Xloc,dmlocalsnes->boundarylocalctx);CHKERRQ(ierr);}
ierr = DMGlobalToLocalBegin(dm,X,INSERT_VALUES,Xloc);CHKERRQ(ierr);
ierr = DMGlobalToLocalEnd(dm,X,INSERT_VALUES,Xloc);CHKERRQ(ierr);
CHKMEMQ;
ierr = (*dmlocalsnes->jacobianlocal)(dm,Xloc,A,B,dmlocalsnes->jacobianlocalctx);CHKERRQ(ierr);
CHKMEMQ;
ierr = DMRestoreLocalVector(dm,&Xloc);CHKERRQ(ierr);
} else {
MatFDColoring fdcoloring;
ierr = PetscObjectQuery((PetscObject)dm,"DMDASNES_FDCOLORING",(PetscObject*)&fdcoloring);CHKERRQ(ierr);
if (!fdcoloring) {
ISColoring coloring;
ierr = DMCreateColoring(dm,dm->coloringtype,&coloring);CHKERRQ(ierr);
ierr = MatFDColoringCreate(B,coloring,&fdcoloring);CHKERRQ(ierr);
ierr = ISColoringDestroy(&coloring);CHKERRQ(ierr);
switch (dm->coloringtype) {
case IS_COLORING_GLOBAL:
ierr = MatFDColoringSetFunction(fdcoloring,(PetscErrorCode (*)(void))SNESComputeFunction_DMLocal,dmlocalsnes);CHKERRQ(ierr);
break;
default: SETERRQ1(PetscObjectComm((PetscObject)snes),PETSC_ERR_SUP,"No support for coloring type '%s'",ISColoringTypes[dm->coloringtype]);
}
ierr = PetscObjectSetOptionsPrefix((PetscObject)fdcoloring,((PetscObject)dm)->prefix);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(fdcoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetUp(B,coloring,fdcoloring);CHKERRQ(ierr);
ierr = PetscObjectCompose((PetscObject)dm,"DMDASNES_FDCOLORING",(PetscObject)fdcoloring);CHKERRQ(ierr);
ierr = PetscObjectDereference((PetscObject)fdcoloring);CHKERRQ(ierr);
/* The following breaks an ugly reference counting loop that deserves a paragraph. MatFDColoringApply() will call
* VecDuplicate() with the state Vec and store inside the MatFDColoring. This Vec will duplicate the Vec, but the
* MatFDColoring is composed with the DM. We dereference the DM here so that the reference count will eventually
* drop to 0. Note the code in DMDestroy() that exits early for a negative reference count. That code path will be
* taken when the PetscObjectList for the Vec inside MatFDColoring is destroyed.
*/
ierr = PetscObjectDereference((PetscObject)dm);CHKERRQ(ierr);
}
ierr = MatFDColoringApply(B,fdcoloring,X,snes);CHKERRQ(ierr);
}
/* This will be redundant if the user called both, but it's too common to forget. */
if (A != B) {
ierr = MatAssemblyBegin(A,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(A,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
EXTERN_C_BEGIN
/*
MatFDColoringSetFunction sticks the Fortran function and its context into the MatFDColoring structure and passes the MatFDColoring object
in as the function context. ourmafdcoloringfunctionsnes() and ourmatfdcoloringfunctionts() then access the function and its context from the
MatFDColoring that is passed in. This is the same way that fortran_func_pointers is used in PETSc objects.
NOTE: FORTRAN USER CANNOT PUT IN A NEW J OR B currently.
*/
void PETSC_STDCALL matfdcoloringsetfunctionts_(MatFDColoring *fd,void (PETSC_STDCALL *f)(TS*,double*,Vec*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr)
{
(*fd)->ftn_func_pointer = (void*) f;
(*fd)->ftn_func_cntx = ctx;
*ierr = MatFDColoringSetFunction(*fd,(PetscErrorCodeFunction)ourmatfdcoloringfunctionts,*fd);
}
int main(int argc,char **argv)
{
PetscErrorCode ierr;
DM da; /* structured grid topology object */
TS ts; /* time-stepping object (contains snes) */
SNES snes; /* Newton solver object */
Vec X,residual; /* solution, residual */
Mat J; /* Jacobian matrix */
PetscInt Mx,My,fsteps,steps;
ISColoring iscoloring;
PetscReal tstart,tend,ftime,secperday=3600.0*24.0,Y0;
PetscBool fdflg = PETSC_FALSE, mfileflg = PETSC_FALSE, optflg = PETSC_FALSE;
char mfile[PETSC_MAX_PATH_LEN] = "out.m";
MatFDColoring matfdcoloring;
PorousCtx user; /* user-defined work context */
PetscInitialize(&argc,&argv,(char *)0,help);
ierr = DMDACreate2d(PETSC_COMM_WORLD,
DMDA_BOUNDARY_NONE, DMDA_BOUNDARY_NONE, // correct for zero Dirichlet
DMDA_STENCIL_STAR, // nonlinear diffusion but diffusivity
// depends on soln W not grad W
-21,-21, // default to 20x20 grid but override with
// -da_grid_x, -da_grid_y (or -da_refine)
PETSC_DECIDE,PETSC_DECIDE, // num of procs in each dim
2, // dof = 2: node = (W,Y)
// or node = (P,dPsqr)
// or node = (ddxE,ddyN)
1, // s = 1 (stencil extends out one cell)
PETSC_NULL,PETSC_NULL, // no specify proc decomposition
&da);CHKERRQ(ierr);
ierr = DMSetApplicationContext(da,&user);CHKERRQ(ierr);
/* get Vecs and Mats for this grid */
ierr = DMCreateGlobalVector(da,&X);CHKERRQ(ierr);
ierr = VecDuplicate(X,&residual);CHKERRQ(ierr);
ierr = VecDuplicate(X,&user.geom);CHKERRQ(ierr);
ierr = DMGetMatrix(da,MATAIJ,&J);CHKERRQ(ierr);
/* set up contexts */
tstart = 10.0 * secperday; /* 10 days in seconds */
tend = 30.0 * secperday;
steps = 20;
Y0 = 1.0; /* initial value of Y, for computing initial
value of P; note Ymin = 0.1 is different */
user.da = da;
ierr = DefaultContext(&user);CHKERRQ(ierr);
ierr = PetscOptionsBegin(PETSC_COMM_WORLD,
"","options to (W,P)-space better hydrology model alt","");CHKERRQ(ierr);
{
ierr = PetscOptionsReal("-alt_sigma","nonlinear power","",
user.sigma,&user.sigma,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscOptionsReal("-alt_Ymin",
"min capacity thickness (esp. in pressure computation)","",
user.Ymin,&user.Ymin,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscOptionsReal("-alt_Wmin",
"min water amount (esp. in pressure computation)","",
user.Wmin,&user.Wmin,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscOptionsReal("-alt_Y0",
"constant initial capacity thickness","",
Y0,&Y0,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscOptionsReal("-alt_Cmelt",
"additional coefficient for amount of melt","",
user.Cmelt,&user.Cmelt,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscOptionsReal("-alt_Creep",
"creep closure coefficient","",
user.Creep,&user.Creep,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscOptionsReal("-alt_L","half-width of square region in meters","",
user.L,&user.L,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscOptionsReal("-alt_tstart_days","start time in days","",
tstart/secperday,&tstart,&optflg);CHKERRQ(ierr);
if (optflg) { tstart *= secperday; }
ierr = PetscOptionsReal("-alt_tend_days","end time in days","",
tend/secperday,&tend,&optflg);CHKERRQ(ierr);
if (optflg) { tend *= secperday; }
ierr = PetscOptionsInt("-alt_steps","number of timesteps to take","",
steps,&steps,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscOptionsBool("-alt_converge_check",
"run silent and check for convergence",
"",user.run_silent,&user.run_silent,PETSC_NULL);
CHKERRQ(ierr);
ierr = PetscOptionsString("-mfile",
"name of Matlab file to write results","",
mfile,mfile,PETSC_MAX_PATH_LEN,&mfileflg);
CHKERRQ(ierr);
}
ierr = PetscOptionsEnd();CHKERRQ(ierr);
/* fix remaining parameters */
ierr = DerivedConstants(&user);CHKERRQ(ierr);
ierr = VecStrideSet(user.geom,0,user.H0);CHKERRQ(ierr); /* H(x,y) = H0 */
ierr = VecStrideSet(user.geom,1,0.0);CHKERRQ(ierr); /* b(x,y) = 0 */
ierr = DMDASetUniformCoordinates(da, // square domain
-user.L, user.L, -user.L, user.L, 0.0, 1.0);CHKERRQ(ierr);
ierr = DMDAGetInfo(da,PETSC_IGNORE,&Mx,&My,
PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,
PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,
PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE);CHKERRQ(ierr);
user.dx = 2.0 * user.L / (Mx-1);
user.dy = 2.0 * user.L / (My-1);
/* setup TS = timestepping object */
ierr = TSCreate(PETSC_COMM_WORLD,&ts);CHKERRQ(ierr);
ierr = TSSetType(ts,TSCN);CHKERRQ(ierr);
ierr = TSSetRHSFunction(ts,residual,RHSFunction,&user);CHKERRQ(ierr);
/* use coloring to compute rhs Jacobian efficiently */
ierr = PetscOptionsGetBool(PETSC_NULL,"-fd",&fdflg,PETSC_NULL);CHKERRQ(ierr);
if (fdflg){
ierr = DMGetColoring(da,IS_COLORING_GLOBAL,MATAIJ,&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringCreate(J,iscoloring,&matfdcoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(matfdcoloring);CHKERRQ(ierr);
ierr = ISColoringDestroy(&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFunction(matfdcoloring,
(PetscErrorCode (*)(void))RHSFunction,&user);CHKERRQ(ierr);
ierr = TSSetRHSJacobian(ts,J,J,TSDefaultComputeJacobianColor,
matfdcoloring);CHKERRQ(ierr);
} else { /* default case */
ierr = TSSetRHSJacobian(ts,J,J,RHSJacobian,&user);CHKERRQ(ierr);
}
/* set initial state: W = barenblatt, P = pi (W/Y0)^sigma */
ierr = InitialState(da,&user,tstart,Y0,X);CHKERRQ(ierr);
/* set up times for time-stepping */
ierr = TSSetInitialTimeStep(ts,tstart,
(tend - tstart) / (PetscReal)steps);CHKERRQ(ierr);
ierr = TSSetDuration(ts,steps,tend);CHKERRQ(ierr);
ierr = TSSetExactFinalTime(ts,PETSC_TRUE);CHKERRQ(ierr);
ierr = TSMonitorSet(ts,MyTSMonitor,&user,PETSC_NULL);CHKERRQ(ierr);
/* Set SNESVI type and supply upper and lower bounds. */
ierr = TSGetSNES(ts,&snes);CHKERRQ(ierr);
ierr = SNESVISetComputeVariableBounds(snes,FormPositivityBounds);
CHKERRQ(ierr);
/* ask user to finalize settings */
ierr = TSSetFromOptions(ts);CHKERRQ(ierr);
/* report on setup */
if (!user.run_silent) {
ierr = PetscPrintf(PETSC_COMM_WORLD,
"setup done: square side length = %.3f km\n"
" grid Mx,My = %d,%d\n"
" spacing dx,dy = %.3f,%.3f m\n"
" times tstart:dt:tend = %.3f:%.3f:%.3f days\n",
2.0 * user.L / 1000.0, Mx, My, user.dx, user.dy,
tstart / secperday, (tend-tstart)/(steps*secperday), tend / secperday);
CHKERRQ(ierr);
}
if (mfileflg) {
if (!user.run_silent) {
ierr = PetscPrintf(PETSC_COMM_WORLD,
"writing initial W,P and geometry H,b to Matlab file %s ...\n",
mfile);CHKERRQ(ierr);
}
ierr = print2vecmatlab(da,X,"W_init","P_init",mfile,PETSC_FALSE);CHKERRQ(ierr);
ierr = print2vecmatlab(da,user.geom,"H","b",mfile,PETSC_TRUE);CHKERRQ(ierr);
}
/* run time-stepping with implicit steps */
ierr = TSSolve(ts,X,&ftime);CHKERRQ(ierr);
/* make a report on run and final state */
ierr = TSGetTimeStepNumber(ts,&fsteps);CHKERRQ(ierr);
if ((!user.run_silent) && (ftime != tend)) {
ierr = PetscPrintf(PETSC_COMM_WORLD,
"***WARNING3***: reported final time wrong: ftime(=%.12e) != tend(=%.12e) (days)\n",
ftime / secperday, tend / secperday);CHKERRQ(ierr); }
if ((!user.run_silent) && (fsteps != steps)) {
ierr = PetscPrintf(PETSC_COMM_WORLD,
"***WARNING4***: reported number of steps wrong: fsteps(=%D) != steps(=%D)\n",
fsteps, steps);CHKERRQ(ierr); }
if (mfileflg) {
if (!user.run_silent) {
ierr = PetscPrintf(PETSC_COMM_WORLD,
"writing final fields to %s ...\n",mfile);CHKERRQ(ierr);
}
ierr = print2vecmatlab(da,X,"W_final","P_final",mfile,PETSC_TRUE);CHKERRQ(ierr);
ierr = printfigurematlab(da,2,"W_init","W_final",mfile,PETSC_TRUE);CHKERRQ(ierr);
ierr = printfigurematlab(da,3,"P_init","P_final",mfile,PETSC_TRUE);CHKERRQ(ierr);
}
if (user.run_silent) {
ierr = PetscPrintf(PETSC_COMM_WORLD, "%6d %6d %9.3f %.12e\n",
Mx, My, (tend-tstart)/secperday, user.maxrnorm);CHKERRQ(ierr);
}
/* Free work space. */
ierr = MatDestroy(&J);CHKERRQ(ierr);
if (fdflg) { ierr = MatFDColoringDestroy(&matfdcoloring);CHKERRQ(ierr); }
ierr = VecDestroy(&X);CHKERRQ(ierr);
ierr = VecDestroy(&user.geom);CHKERRQ(ierr);
ierr = VecDestroy(&residual);CHKERRQ(ierr);
ierr = TSDestroy(&ts);CHKERRQ(ierr);
ierr = DMDestroy(&da);CHKERRQ(ierr);
ierr = PetscFinalize();CHKERRQ(ierr);
PetscFunctionReturn((PetscInt)(user.not_converged_warning));
}
int main(int argc,char **argv)
{
PetscErrorCode ierr;
int time; /* amount of loops */
struct in put;
PetscScalar rh; /* relative humidity */
PetscScalar x; /* memory varialbe for relative humidity calculation */
PetscScalar deep_grnd_temp; /* temperature of ground under top soil surface layer */
PetscScalar emma; /* absorption-emission constant for air */
PetscScalar pressure1 = 101300; /* surface pressure */
PetscScalar mixratio; /* mixing ratio */
PetscScalar airtemp; /* temperature of air near boundary layer inversion */
PetscScalar dewtemp; /* dew point temperature */
PetscScalar sfctemp; /* temperature at surface */
PetscScalar pwat; /* total column precipitable water */
PetscScalar cloudTemp; /* temperature at base of cloud */
AppCtx user; /* user-defined work context */
MonitorCtx usermonitor; /* user-defined monitor context */
PetscMPIInt rank,size;
TS ts;
SNES snes;
DM da;
Vec T,rhs; /* solution vector */
Mat J; /* Jacobian matrix */
PetscReal ftime,dt;
PetscInt steps,dof = 5;
PetscBool use_coloring = PETSC_TRUE;
MatFDColoring matfdcoloring = 0;
PetscBool monitor_off = PETSC_FALSE;
PetscInitialize(&argc,&argv,(char*)0,help);
ierr = MPI_Comm_size(PETSC_COMM_WORLD,&size);CHKERRQ(ierr);
ierr = MPI_Comm_rank(PETSC_COMM_WORLD,&rank);CHKERRQ(ierr);
/* Inputs */
readinput(&put);
sfctemp = put.Ts;
dewtemp = put.Td;
cloudTemp = put.Tc;
airtemp = put.Ta;
pwat = put.pwt;
if (!rank) PetscPrintf(PETSC_COMM_SELF,"Initial Temperature = %g\n",sfctemp); /* input surface temperature */
deep_grnd_temp = sfctemp - 10; /* set underlying ground layer temperature */
emma = emission(pwat); /* accounts for radiative effects of water vapor */
/* Converts from Fahrenheit to Celsuis */
sfctemp = fahr_to_cel(sfctemp);
airtemp = fahr_to_cel(airtemp);
dewtemp = fahr_to_cel(dewtemp);
cloudTemp = fahr_to_cel(cloudTemp);
deep_grnd_temp = fahr_to_cel(deep_grnd_temp);
/* Converts from Celsius to Kelvin */
sfctemp += 273;
airtemp += 273;
dewtemp += 273;
cloudTemp += 273;
deep_grnd_temp += 273;
/* Calculates initial relative humidity */
x = calcmixingr(dewtemp,pressure1);
mixratio = calcmixingr(sfctemp,pressure1);
rh = (x/mixratio)*100;
if (!rank) printf("Initial RH = %.1f percent\n\n",rh); /* prints initial relative humidity */
time = 3600*put.time; /* sets amount of timesteps to run model */
/* Configure PETSc TS solver */
/*------------------------------------------*/
/* Create grid */
ierr = DMDACreate2d(PETSC_COMM_WORLD,DMDA_BOUNDARY_PERIODIC,DMDA_BOUNDARY_PERIODIC,DMDA_STENCIL_STAR,-20,-20,
PETSC_DECIDE,PETSC_DECIDE,dof,1,NULL,NULL,&da);CHKERRQ(ierr);
ierr = DMDASetUniformCoordinates(da, 0.0, 1.0, 0.0, 1.0, 0.0, 1.0);CHKERRQ(ierr);
/* Define output window for each variable of interest */
ierr = DMDASetFieldName(da,0,"Ts");CHKERRQ(ierr);
ierr = DMDASetFieldName(da,1,"Ta");CHKERRQ(ierr);
ierr = DMDASetFieldName(da,2,"u");CHKERRQ(ierr);
ierr = DMDASetFieldName(da,3,"v");CHKERRQ(ierr);
ierr = DMDASetFieldName(da,4,"p");CHKERRQ(ierr);
/* set values for appctx */
user.da = da;
user.Ts = sfctemp;
user.fract = put.fr; /* fraction of sky covered by clouds */
user.dewtemp = dewtemp; /* dew point temperature (mositure in air) */
user.csoil = 2000000; /* heat constant for layer */
user.dzlay = 0.08; /* thickness of top soil layer */
user.emma = emma; /* emission parameter */
user.wind = put.wnd; /* wind spped */
user.pressure1 = pressure1; /* sea level pressure */
user.airtemp = airtemp; /* temperature of air near boundar layer inversion */
user.Tc = cloudTemp; /* temperature at base of lowest cloud layer */
user.init = put.init; /* user chosen initiation scenario */
user.lat = 70*0.0174532; /* converts latitude degrees to latitude in radians */
user.deep_grnd_temp = deep_grnd_temp; /* temp in lowest ground layer */
/* set values for MonitorCtx */
usermonitor.drawcontours = PETSC_FALSE;
ierr = PetscOptionsHasName(NULL,"-drawcontours",&usermonitor.drawcontours);CHKERRQ(ierr);
if (usermonitor.drawcontours) {
PetscReal bounds[] = {1000.0,-1000., -1000.,-1000., 1000.,-1000., 1000.,-1000., 1000,-1000, 100700,100800};
ierr = PetscViewerDrawOpen(PETSC_COMM_WORLD,0,0,0,0,300,300,&usermonitor.drawviewer);CHKERRQ(ierr);
ierr = PetscViewerDrawSetBounds(usermonitor.drawviewer,dof,bounds);CHKERRQ(ierr);
}
usermonitor.interval = 1;
ierr = PetscOptionsGetInt(NULL,"-monitor_interval",&usermonitor.interval,NULL);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Extract global vectors from DA;
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = DMCreateGlobalVector(da,&T);CHKERRQ(ierr);
ierr = VecDuplicate(T,&rhs);CHKERRQ(ierr); /* r: vector to put the computed right hand side */
ierr = TSCreate(PETSC_COMM_WORLD,&ts);CHKERRQ(ierr);
ierr = TSSetProblemType(ts,TS_NONLINEAR);CHKERRQ(ierr);
ierr = TSSetType(ts,TSBEULER);CHKERRQ(ierr);
ierr = TSSetRHSFunction(ts,rhs,RhsFunc,&user);CHKERRQ(ierr);
/* Set Jacobian evaluation routine - use coloring to compute finite difference Jacobian efficiently */
ierr = DMSetMatType(da,MATAIJ);CHKERRQ(ierr);
ierr = DMCreateMatrix(da,&J);CHKERRQ(ierr);
ierr = TSGetSNES(ts,&snes);CHKERRQ(ierr);
if (use_coloring) {
ISColoring iscoloring;
ierr = DMCreateColoring(da,IS_COLORING_GLOBAL,&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringCreate(J,iscoloring,&matfdcoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(matfdcoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetUp(J,iscoloring,matfdcoloring);CHKERRQ(ierr);
ierr = ISColoringDestroy(&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFunction(matfdcoloring,(PetscErrorCode (*)(void))SNESTSFormFunction,ts);CHKERRQ(ierr);
ierr = SNESSetJacobian(snes,J,J,SNESComputeJacobianDefaultColor,matfdcoloring);CHKERRQ(ierr);
} else {
ierr = SNESSetJacobian(snes,J,J,SNESComputeJacobianDefault,NULL);CHKERRQ(ierr);
}
/* Define what to print for ts_monitor option */
ierr = PetscOptionsHasName(NULL,"-monitor_off",&monitor_off);CHKERRQ(ierr);
if (!monitor_off) {
ierr = TSMonitorSet(ts,Monitor,&usermonitor,NULL);CHKERRQ(ierr);
}
ierr = FormInitialSolution(da,T,&user);CHKERRQ(ierr);
dt = TIMESTEP; /* initial time step */
ftime = TIMESTEP*time;
if (!rank) printf("time %d, ftime %g hour, TIMESTEP %g\n",time,ftime/3600,dt);
ierr = TSSetInitialTimeStep(ts,0.0,dt);CHKERRQ(ierr);
ierr = TSSetDuration(ts,time,ftime);CHKERRQ(ierr);
ierr = TSSetSolution(ts,T);CHKERRQ(ierr);
ierr = TSSetDM(ts,da);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Set runtime options
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = TSSetFromOptions(ts);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Solve nonlinear system
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = TSSolve(ts,T);CHKERRQ(ierr);
ierr = TSGetSolveTime(ts,&ftime);CHKERRQ(ierr);
ierr = TSGetTimeStepNumber(ts,&steps);CHKERRQ(ierr);
if (!rank) PetscPrintf(PETSC_COMM_WORLD,"Solution T after %g hours %d steps\n",ftime/3600,steps);
if (matfdcoloring) {ierr = MatFDColoringDestroy(&matfdcoloring);CHKERRQ(ierr);}
if (usermonitor.drawcontours) {
ierr = PetscViewerDestroy(&usermonitor.drawviewer);CHKERRQ(ierr);
}
ierr = MatDestroy(&J);CHKERRQ(ierr);
ierr = VecDestroy(&T);CHKERRQ(ierr);
ierr = VecDestroy(&rhs);CHKERRQ(ierr);
ierr = TSDestroy(&ts);CHKERRQ(ierr);
ierr = DMDestroy(&da);CHKERRQ(ierr);
PetscFinalize();
return 0;
}
int main(int argc,char **argv)
{
PetscErrorCode ierr;
SNES snes; /* nonlinear solver */
Vec Hu,r; /* solution, residual vectors */
Mat J; /* Jacobian matrix */
AppCtx user; /* user-defined work context */
PetscInt its, i, tmpxs, tmpxm; /* iteration count, index, etc. */
PetscReal tmp1, tmp2, tmp3, tmp4, tmp5,
errnorms[2], descaleNode[2];
PetscTruth eps_set = PETSC_FALSE, dump = PETSC_FALSE, exactinitial = PETSC_FALSE,
snes_mf_set, snes_fd_set;
MatFDColoring matfdcoloring = 0;
ISColoring iscoloring;
SNESConvergedReason reason; /* Check convergence */
PetscInitialize(&argc,&argv,(char *)0,help);
ierr = MPI_Comm_rank(PETSC_COMM_WORLD, &user.rank); CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD,
"BODVARDSSON solves for thickness and velocity in 1D, steady ice stream\n"
" [run with -help for info and options]\n");CHKERRQ(ierr);
user.n = 3.0; /* Glen flow law exponent */
user.secpera = 31556926.0;
user.rho = 910.0; /* kg m^-3 */
user.rhow = 1028.0; /* kg m^-3 */
user.g = 9.81; /* m s^-2 */
/* ask Test N for its parameters, but only those we need to solve */
ierr = params_exactN(&(user.H0), &tmp1, &(user.xc), &tmp2, &tmp3, &tmp4, &tmp5,
&(user.Txc)); CHKERRQ(ierr);
/* regularize using strain rate of 1/xc per year */
user.epsilon = (1.0 / user.secpera) / user.xc;
/* tools for non-dimensionalizing to improve equation scaling */
user.scaleNode[0] = 1000.0; user.scaleNode[1] = 100.0 / user.secpera;
ierr = PetscOptionsTruth("-snes_mf","","",PETSC_FALSE,&snes_mf_set,NULL);CHKERRQ(ierr);
ierr = PetscOptionsTruth("-snes_fd","","",PETSC_FALSE,&snes_fd_set,NULL);CHKERRQ(ierr);
if (!snes_mf_set && !snes_fd_set) {
PetscPrintf(PETSC_COMM_WORLD,
"\n***ERROR: bodvardsson needs one or zero of '-snes_mf', '-snes_fd'***\n\n"
"USAGE FOLLOWS ...\n\n%s",help);
PetscEnd();
}
if (snes_fd_set) {
ierr = PetscPrintf(PETSC_COMM_WORLD,
" using approximate Jacobian; finite-differencing using coloring\n");
CHKERRQ(ierr);
} else if (snes_mf_set) {
ierr = PetscPrintf(PETSC_COMM_WORLD,
" matrix free; no preconditioner\n"); CHKERRQ(ierr);
} else {
ierr = PetscPrintf(PETSC_COMM_WORLD,
" true Jacobian\n"); CHKERRQ(ierr);
}
ierr = PetscOptionsBegin(PETSC_COMM_WORLD,NULL,
"bodvardsson program options",__FILE__);CHKERRQ(ierr);
{
ierr = PetscOptionsTruth("-bod_up_one","","",PETSC_FALSE,&user.upwind1,NULL);CHKERRQ(ierr);
ierr = PetscOptionsTruth("-bod_exact_init","","",PETSC_FALSE,&exactinitial,NULL);CHKERRQ(ierr);
ierr = PetscOptionsTruth("-bod_dump",
"dump out exact and approximate solution and residual, as asci","",
dump,&dump,NULL);CHKERRQ(ierr);
ierr = PetscOptionsReal("-bod_epsilon","regularization (a strain rate in units of 1/a)","",
user.epsilon * user.secpera,&user.epsilon,&eps_set);CHKERRQ(ierr);
if (eps_set) user.epsilon *= 1.0 / user.secpera;
}
ierr = PetscOptionsEnd();CHKERRQ(ierr);
/* Create machinery for parallel grid management (DA), nonlinear solver (SNES),
and Vecs for fields (solution, RHS). Note default Mx=46 grid points means
dx=10 km. Also degrees of freedom = 2 (thickness and velocity
at each point) and stencil radius = ghost width = 2 for 2nd-order upwinding. */
user.solnghostwidth = 2;
ierr = DACreate1d(PETSC_COMM_WORLD,DA_NONPERIODIC,-46,2,user.solnghostwidth,PETSC_NULL,&user.da);
CHKERRQ(ierr);
ierr = DASetUniformCoordinates(user.da,0.0,user.xc,
PETSC_NULL,PETSC_NULL,PETSC_NULL,PETSC_NULL);CHKERRQ(ierr);
ierr = DASetFieldName(user.da,0,"ice thickness [non-dimensional]"); CHKERRQ(ierr);
ierr = DASetFieldName(user.da,1,"ice velocity [non-dimensional]"); CHKERRQ(ierr);
ierr = DAGetInfo(user.da,PETSC_IGNORE,&user.Mx,PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,
PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE);
ierr = DAGetCorners(user.da,&user.xs,PETSC_NULL,PETSC_NULL,&user.xm,PETSC_NULL,PETSC_NULL);
CHKERRQ(ierr);
user.dx = user.xc / (PetscReal)(user.Mx-1);
/* another DA for scalar parameters, with same length */
ierr = DACreate1d(PETSC_COMM_WORLD,DA_NONPERIODIC,user.Mx,1,1,PETSC_NULL,&user.scalarda);CHKERRQ(ierr);
ierr = DASetUniformCoordinates(user.scalarda,0.0,user.xc,
PETSC_NULL,PETSC_NULL,PETSC_NULL,PETSC_NULL);CHKERRQ(ierr);
/* check that parallel layout of scalar DA is same as dof=2 DA */
ierr = DAGetCorners(user.scalarda,&tmpxs,PETSC_NULL,PETSC_NULL,&tmpxm,PETSC_NULL,PETSC_NULL);
CHKERRQ(ierr);
if ((tmpxs != user.xs) || (tmpxm != user.xm)) {
PetscPrintf(PETSC_COMM_SELF,
"\n***ERROR: rank %d gets different ownership range for the two DAs! ENDING ...***\n\n",
user.rank);
PetscEnd();
}
ierr = PetscPrintf(PETSC_COMM_WORLD,
" Mx = %D points, dx = %.3f m\n H0 = %.2f m, xc = %.2f km, Txc = %.5e Pa m\n",
user.Mx, user.dx, user.H0, user.xc/1000.0, user.Txc);CHKERRQ(ierr);
/* Extract/allocate global vectors from DAs and duplicate for remaining same types */
ierr = DACreateGlobalVector(user.da,&Hu);CHKERRQ(ierr);
ierr = VecSetBlockSize(Hu,2);CHKERRQ(ierr);
ierr = VecDuplicate(Hu,&r);CHKERRQ(ierr); /* inherits block size */
ierr = VecDuplicate(Hu,&user.Huexact);CHKERRQ(ierr); /* ditto */
ierr = DACreateGlobalVector(user.scalarda,&user.M);CHKERRQ(ierr);
ierr = VecDuplicate(user.M,&user.Bstag);CHKERRQ(ierr);
ierr = VecDuplicate(user.M,&user.beta);CHKERRQ(ierr);
ierr = DASetLocalFunction(user.da,(DALocalFunction1)scshell);CHKERRQ(ierr);
ierr = DASetLocalJacobian(user.da,(DALocalFunction1)BodJacobianMatrixLocal);CHKERRQ(ierr);
ierr = SNESCreate(PETSC_COMM_WORLD,&snes);CHKERRQ(ierr);
ierr = SNESSetFunction(snes,r,SNESDAFormFunction,&user);CHKERRQ(ierr);
/* setting up a matrix is only actually needed for -snes_fd case */
ierr = DAGetMatrix(user.da,MATAIJ,&J);CHKERRQ(ierr);
if (snes_fd_set) {
/* tools needed so DA can use sparse matrix for its F.D. Jacobian approx */
ierr = DAGetColoring(user.da,IS_COLORING_GLOBAL,MATAIJ,&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringCreate(J,iscoloring,&matfdcoloring);CHKERRQ(ierr);
ierr = ISColoringDestroy(iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFunction(matfdcoloring,
(PetscErrorCode (*)(void))SNESDAFormFunction,&user);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(matfdcoloring);CHKERRQ(ierr);
ierr = SNESSetJacobian(snes,J,J,SNESDefaultComputeJacobianColor,matfdcoloring);CHKERRQ(ierr);
} else {
ierr = SNESSetJacobian(snes,J,J,SNESDAComputeJacobian,&user);CHKERRQ(ierr);
}
ierr = SNESSetFromOptions(snes);CHKERRQ(ierr);
/* the the Bodvardsson (1955) exact solution allows setting M(x), B(x), beta(x), T(xc) */
ierr = FillDistributedParams(&user);CHKERRQ(ierr);
/* the exact thickness and exact ice velocity (user.uHexact) are known from Bodvardsson (1955) */
ierr = FillExactSoln(&user); CHKERRQ(ierr);
if (exactinitial) {
ierr = PetscPrintf(PETSC_COMM_WORLD," using exact solution as initial guess\n");
CHKERRQ(ierr);
/* the initial guess is the exact continuum solution */
ierr = VecCopy(user.Huexact,Hu); CHKERRQ(ierr);
} else {
ierr = FillInitial(&user, &Hu); CHKERRQ(ierr);
}
/************ SOLVE NONLINEAR SYSTEM ************/
/* recall that RHS r is used internally by KSP, and is set by the SNES */
for (i = 0; i < 2; i++) descaleNode[i] = 1.0 / user.scaleNode[i];
ierr = VecStrideScaleAll(Hu,descaleNode); CHKERRQ(ierr); /* de-dimensionalize initial guess */
ierr = SNESSolve(snes,PETSC_NULL,Hu);CHKERRQ(ierr);
ierr = VecStrideScaleAll(Hu,user.scaleNode); CHKERRQ(ierr); /* put back in "real" scale */
ierr = SNESGetIterationNumber(snes,&its);CHKERRQ(ierr);
ierr = SNESGetConvergedReason(snes,&reason);CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD,
" %s Number of Newton iterations = %D\n",
SNESConvergedReasons[reason],its);CHKERRQ(ierr);
if (dump) {
ierr = PetscPrintf(PETSC_COMM_WORLD,
" viewing combined result Hu\n");CHKERRQ(ierr);
ierr = VecView(Hu,PETSC_VIEWER_STDOUT_WORLD); CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD,
" viewing combined exact result Huexact\n");CHKERRQ(ierr);
ierr = VecView(user.Huexact,PETSC_VIEWER_STDOUT_WORLD); CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD,
" viewing final combined residual at Hu\n");CHKERRQ(ierr);
ierr = VecView(r,PETSC_VIEWER_STDOUT_WORLD); CHKERRQ(ierr);
}
/* evaluate error relative to exact solution */
ierr = VecAXPY(Hu,-1.0,user.Huexact); CHKERRQ(ierr); /* Hu = - Huexact + Hu */
ierr = VecStrideNormAll(Hu,NORM_INFINITY,errnorms); CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD,
"(dx,errHinf,erruinf) %.3f %.4e %.4e\n",
user.dx,errnorms[0],errnorms[1]*user.secpera);CHKERRQ(ierr);
ierr = VecDestroy(Hu);CHKERRQ(ierr);
ierr = VecDestroy(r);CHKERRQ(ierr);
ierr = VecDestroy(user.Huexact);CHKERRQ(ierr);
ierr = VecDestroy(user.M);CHKERRQ(ierr);
ierr = VecDestroy(user.Bstag);CHKERRQ(ierr);
ierr = VecDestroy(user.beta);CHKERRQ(ierr);
ierr = MatDestroy(J); CHKERRQ(ierr);
ierr = SNESDestroy(snes);CHKERRQ(ierr);
ierr = DADestroy(user.da);CHKERRQ(ierr);
ierr = DADestroy(user.scalarda);CHKERRQ(ierr);
ierr = PetscFinalize();CHKERRQ(ierr);
return 0;
}
int main(int argc,char **argv)
{
PetscErrorCode ierr;
PetscInt time_steps=100,iout,NOUT=1;
PetscMPIInt size;
Vec global;
PetscReal dt,ftime,ftime_original;
TS ts;
PetscViewer viewfile;
Mat J = 0;
Vec x;
Data data;
PetscInt mn;
PetscBool flg;
MatColoring mc;
ISColoring iscoloring;
MatFDColoring matfdcoloring = 0;
PetscBool fd_jacobian_coloring = PETSC_FALSE;
SNES snes;
KSP ksp;
PC pc;
PetscViewer viewer;
char pcinfo[120],tsinfo[120];
TSType tstype;
PetscBool sundials;
ierr = PetscInitialize(&argc,&argv,(char*)0,help);CHKERRQ(ierr);
ierr = MPI_Comm_size(PETSC_COMM_WORLD,&size);CHKERRQ(ierr);
/* set data */
data.m = 9;
data.n = 9;
data.a = 1.0;
data.epsilon = 0.1;
data.dx = 1.0/(data.m+1.0);
data.dy = 1.0/(data.n+1.0);
mn = (data.m)*(data.n);
ierr = PetscOptionsGetInt(NULL,"-time",&time_steps,NULL);CHKERRQ(ierr);
/* set initial conditions */
ierr = VecCreate(PETSC_COMM_WORLD,&global);CHKERRQ(ierr);
ierr = VecSetSizes(global,PETSC_DECIDE,mn);CHKERRQ(ierr);
ierr = VecSetFromOptions(global);CHKERRQ(ierr);
ierr = Initial(global,&data);CHKERRQ(ierr);
ierr = VecDuplicate(global,&x);CHKERRQ(ierr);
/* create timestep context */
ierr = TSCreate(PETSC_COMM_WORLD,&ts);CHKERRQ(ierr);
ierr = TSMonitorSet(ts,Monitor,&data,NULL);CHKERRQ(ierr);
#if defined(PETSC_HAVE_SUNDIALS)
ierr = TSSetType(ts,TSSUNDIALS);CHKERRQ(ierr);
#else
ierr = TSSetType(ts,TSEULER);CHKERRQ(ierr);
#endif
dt = 0.1;
ftime_original = data.tfinal = 1.0;
ierr = TSSetInitialTimeStep(ts,0.0,dt);CHKERRQ(ierr);
ierr = TSSetDuration(ts,time_steps,ftime_original);CHKERRQ(ierr);
ierr = TSSetSolution(ts,global);CHKERRQ(ierr);
/* set user provided RHSFunction and RHSJacobian */
ierr = TSSetRHSFunction(ts,NULL,RHSFunction,&data);CHKERRQ(ierr);
ierr = MatCreate(PETSC_COMM_WORLD,&J);CHKERRQ(ierr);
ierr = MatSetSizes(J,PETSC_DECIDE,PETSC_DECIDE,mn,mn);CHKERRQ(ierr);
ierr = MatSetFromOptions(J);CHKERRQ(ierr);
ierr = MatSeqAIJSetPreallocation(J,5,NULL);CHKERRQ(ierr);
ierr = MatMPIAIJSetPreallocation(J,5,NULL,5,NULL);CHKERRQ(ierr);
ierr = PetscOptionsHasName(NULL,"-ts_fd",&flg);CHKERRQ(ierr);
if (!flg) {
ierr = TSSetRHSJacobian(ts,J,J,RHSJacobian,&data);CHKERRQ(ierr);
} else {
ierr = TSGetSNES(ts,&snes);CHKERRQ(ierr);
ierr = PetscOptionsHasName(NULL,"-fd_color",&fd_jacobian_coloring);CHKERRQ(ierr);
if (fd_jacobian_coloring) { /* Use finite differences with coloring */
/* Get data structure of J */
PetscBool pc_diagonal;
ierr = PetscOptionsHasName(NULL,"-pc_diagonal",&pc_diagonal);CHKERRQ(ierr);
if (pc_diagonal) { /* the preconditioner of J is a diagonal matrix */
PetscInt rstart,rend,i;
PetscScalar zero=0.0;
ierr = MatGetOwnershipRange(J,&rstart,&rend);CHKERRQ(ierr);
for (i=rstart; i<rend; i++) {
ierr = MatSetValues(J,1,&i,1,&i,&zero,INSERT_VALUES);CHKERRQ(ierr);
}
ierr = MatAssemblyBegin(J,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(J,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
} else {
/* Fill the structure using the expensive SNESComputeJacobianDefault. Temporarily set up the TS so we can call this function */
ierr = TSSetType(ts,TSBEULER);CHKERRQ(ierr);
ierr = TSSetUp(ts);CHKERRQ(ierr);
ierr = SNESComputeJacobianDefault(snes,x,J,J,ts);CHKERRQ(ierr);
}
/* create coloring context */
ierr = MatColoringCreate(J,&mc);CHKERRQ(ierr);
ierr = MatColoringSetType(mc,MATCOLORINGSL);CHKERRQ(ierr);
ierr = MatColoringSetFromOptions(mc);CHKERRQ(ierr);
ierr = MatColoringApply(mc,&iscoloring);CHKERRQ(ierr);
ierr = MatColoringDestroy(&mc);CHKERRQ(ierr);
ierr = MatFDColoringCreate(J,iscoloring,&matfdcoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFunction(matfdcoloring,(PetscErrorCode (*)(void))SNESTSFormFunction,ts);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(matfdcoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetUp(J,iscoloring,matfdcoloring);CHKERRQ(ierr);
ierr = SNESSetJacobian(snes,J,J,SNESComputeJacobianDefaultColor,matfdcoloring);CHKERRQ(ierr);
ierr = ISColoringDestroy(&iscoloring);CHKERRQ(ierr);
} else { /* Use finite differences (slow) */
ierr = SNESSetJacobian(snes,J,J,SNESComputeJacobianDefault,NULL);CHKERRQ(ierr);
}
}
/* Pick up a Petsc preconditioner */
/* one can always set method or preconditioner during the run time */
ierr = TSGetSNES(ts,&snes);CHKERRQ(ierr);
ierr = SNESGetKSP(snes,&ksp);CHKERRQ(ierr);
ierr = KSPGetPC(ksp,&pc);CHKERRQ(ierr);
ierr = PCSetType(pc,PCJACOBI);CHKERRQ(ierr);
ierr = TSSetFromOptions(ts);CHKERRQ(ierr);
ierr = TSSetUp(ts);CHKERRQ(ierr);
/* Test TSSetPostStep() */
ierr = PetscOptionsHasName(NULL,"-test_PostStep",&flg);CHKERRQ(ierr);
if (flg) {
ierr = TSSetPostStep(ts,PostStep);CHKERRQ(ierr);
}
ierr = PetscOptionsGetInt(NULL,"-NOUT",&NOUT,NULL);CHKERRQ(ierr);
for (iout=1; iout<=NOUT; iout++) {
ierr = TSSetDuration(ts,time_steps,iout*ftime_original/NOUT);CHKERRQ(ierr);
ierr = TSSolve(ts,global);CHKERRQ(ierr);
ierr = TSGetSolveTime(ts,&ftime);CHKERRQ(ierr);
ierr = TSSetInitialTimeStep(ts,ftime,dt);CHKERRQ(ierr);
}
/* Interpolate solution at tfinal */
ierr = TSGetSolution(ts,&global);CHKERRQ(ierr);
ierr = TSInterpolate(ts,ftime_original,global);CHKERRQ(ierr);
ierr = PetscOptionsHasName(NULL,"-matlab_view",&flg);CHKERRQ(ierr);
if (flg) { /* print solution into a MATLAB file */
ierr = PetscViewerASCIIOpen(PETSC_COMM_WORLD,"out.m",&viewfile);CHKERRQ(ierr);
ierr = PetscViewerSetFormat(viewfile,PETSC_VIEWER_ASCII_MATLAB);CHKERRQ(ierr);
ierr = VecView(global,viewfile);CHKERRQ(ierr);
ierr = PetscViewerDestroy(&viewfile);CHKERRQ(ierr);
}
/* display solver info for Sundials */
ierr = TSGetType(ts,&tstype);CHKERRQ(ierr);
ierr = PetscObjectTypeCompare((PetscObject)ts,TSSUNDIALS,&sundials);CHKERRQ(ierr);
if (sundials) {
ierr = PetscViewerStringOpen(PETSC_COMM_WORLD,tsinfo,120,&viewer);CHKERRQ(ierr);
ierr = TSView(ts,viewer);CHKERRQ(ierr);
ierr = PetscViewerDestroy(&viewer);CHKERRQ(ierr);
ierr = PetscViewerStringOpen(PETSC_COMM_WORLD,pcinfo,120,&viewer);CHKERRQ(ierr);
ierr = PCView(pc,viewer);CHKERRQ(ierr);
ierr = PetscPrintf(PETSC_COMM_WORLD,"%d Procs,%s TSType, %s Preconditioner\n",size,tsinfo,pcinfo);CHKERRQ(ierr);
ierr = PetscViewerDestroy(&viewer);CHKERRQ(ierr);
}
/* free the memories */
ierr = TSDestroy(&ts);CHKERRQ(ierr);
ierr = VecDestroy(&global);CHKERRQ(ierr);
ierr = VecDestroy(&x);CHKERRQ(ierr);
ierr = MatDestroy(&J);CHKERRQ(ierr);
if (fd_jacobian_coloring) {ierr = MatFDColoringDestroy(&matfdcoloring);CHKERRQ(ierr);}
ierr = PetscFinalize();
return 0;
}
void
NonlinearSystem::setupColoringFiniteDifferencedPreconditioner()
{
#ifdef LIBMESH_HAVE_PETSC
// Make sure that libMesh isn't going to override our preconditioner
_transient_sys.nonlinear_solver->jacobian = nullptr;
PetscNonlinearSolver<Number> & petsc_nonlinear_solver =
dynamic_cast<PetscNonlinearSolver<Number> &>(*_transient_sys.nonlinear_solver);
// Pointer to underlying PetscMatrix type
PetscMatrix<Number> * petsc_mat = dynamic_cast<PetscMatrix<Number> *>(_transient_sys.matrix);
#if PETSC_VERSION_LESS_THAN(3, 2, 0)
// This variable is only needed for PETSC < 3.2.0
PetscVector<Number> * petsc_vec =
dynamic_cast<PetscVector<Number> *>(_transient_sys.solution.get());
#endif
Moose::compute_jacobian(*_transient_sys.current_local_solution, *petsc_mat, _transient_sys);
if (!petsc_mat)
mooseError("Could not convert to Petsc matrix.");
petsc_mat->close();
PetscErrorCode ierr = 0;
ISColoring iscoloring;
#if PETSC_VERSION_LESS_THAN(3, 2, 0)
// PETSc 3.2.x
ierr = MatGetColoring(petsc_mat->mat(), MATCOLORING_LF, &iscoloring);
CHKERRABORT(libMesh::COMM_WORLD, ierr);
#elif PETSC_VERSION_LESS_THAN(3, 5, 0)
// PETSc 3.3.x, 3.4.x
ierr = MatGetColoring(petsc_mat->mat(), MATCOLORINGLF, &iscoloring);
CHKERRABORT(_communicator.get(), ierr);
#else
// PETSc 3.5.x
MatColoring matcoloring;
ierr = MatColoringCreate(petsc_mat->mat(), &matcoloring);
CHKERRABORT(_communicator.get(), ierr);
ierr = MatColoringSetType(matcoloring, MATCOLORINGLF);
CHKERRABORT(_communicator.get(), ierr);
ierr = MatColoringSetFromOptions(matcoloring);
CHKERRABORT(_communicator.get(), ierr);
ierr = MatColoringApply(matcoloring, &iscoloring);
CHKERRABORT(_communicator.get(), ierr);
ierr = MatColoringDestroy(&matcoloring);
CHKERRABORT(_communicator.get(), ierr);
#endif
MatFDColoringCreate(petsc_mat->mat(), iscoloring, &_fdcoloring);
MatFDColoringSetFromOptions(_fdcoloring);
MatFDColoringSetFunction(_fdcoloring,
(PetscErrorCode(*)(void)) & libMesh::__libmesh_petsc_snes_fd_residual,
&petsc_nonlinear_solver);
#if !PETSC_RELEASE_LESS_THAN(3, 5, 0)
MatFDColoringSetUp(petsc_mat->mat(), iscoloring, _fdcoloring);
#endif
#if PETSC_VERSION_LESS_THAN(3, 4, 0)
SNESSetJacobian(petsc_nonlinear_solver.snes(),
petsc_mat->mat(),
petsc_mat->mat(),
SNESDefaultComputeJacobianColor,
_fdcoloring);
#else
SNESSetJacobian(petsc_nonlinear_solver.snes(),
petsc_mat->mat(),
petsc_mat->mat(),
SNESComputeJacobianDefaultColor,
_fdcoloring);
#endif
#if PETSC_VERSION_LESS_THAN(3, 2, 0)
Mat my_mat = petsc_mat->mat();
MatStructure my_struct;
SNESComputeJacobian(
petsc_nonlinear_solver.snes(), petsc_vec->vec(), &my_mat, &my_mat, &my_struct);
#endif
#if PETSC_VERSION_LESS_THAN(3, 2, 0)
ISColoringDestroy(iscoloring);
#else
// PETSc 3.3.0
ISColoringDestroy(&iscoloring);
#endif
#endif
}
int main(int argc,char **argv)
{
TS ts; /* nonlinear solver */
Vec x,r; /* solution, residual vectors */
Mat J; /* Jacobian matrix */
PetscInt steps,Mx,maxsteps = 10000000;
PetscErrorCode ierr;
DM da;
MatFDColoring matfdcoloring;
ISColoring iscoloring;
PetscReal dt;
PetscReal vbounds[] = {-100000,100000,-1.1,1.1};
PetscBool wait;
Vec ul,uh;
SNES snes;
UserCtx ctx;
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Initialize program
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = PetscInitialize(&argc,&argv,(char*)0,help);if (ierr) return ierr;
ctx.kappa = 1.0;
ierr = PetscOptionsGetReal(NULL,"-kappa",&ctx.kappa,NULL);CHKERRQ(ierr);
ctx.cahnhillard = PETSC_FALSE;
ierr = PetscOptionsGetBool(NULL,NULL,"-cahn-hillard",&ctx.cahnhillard,NULL);CHKERRQ(ierr);
ierr = PetscViewerDrawSetBounds(PETSC_VIEWER_DRAW_(PETSC_COMM_WORLD),2,vbounds);CHKERRQ(ierr);
ierr = PetscViewerDrawResize(PETSC_VIEWER_DRAW_(PETSC_COMM_WORLD),600,600);CHKERRQ(ierr);
ctx.energy = 1;
/* ierr = PetscOptionsGetInt(NULL,NULL,"-energy",&ctx.energy,NULL);CHKERRQ(ierr); */
ierr = PetscOptionsGetInt(NULL,NULL,"-energy",&ctx.energy,NULL);CHKERRQ(ierr);
ctx.tol = 1.0e-8;
ierr = PetscOptionsGetReal(NULL,"-tol",&ctx.tol,NULL);CHKERRQ(ierr);
ctx.theta = .001;
ctx.theta_c = 1.0;
ierr = PetscOptionsGetReal(NULL,"-theta",&ctx.theta,NULL);CHKERRQ(ierr);
ierr = PetscOptionsGetReal(NULL,"-theta_c",&ctx.theta_c,NULL);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Create distributed array (DMDA) to manage parallel grid and vectors
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = DMDACreate1d(PETSC_COMM_WORLD, DM_BOUNDARY_PERIODIC, -10,2,2,NULL,&da);CHKERRQ(ierr);
ierr = DMSetFromOptions(da);CHKERRQ(ierr);
ierr = DMSetUp(da);CHKERRQ(ierr);
ierr = DMDASetFieldName(da,0,"Biharmonic heat equation: w = -kappa*u_xx");CHKERRQ(ierr);
ierr = DMDASetFieldName(da,1,"Biharmonic heat equation: u");CHKERRQ(ierr);
ierr = DMDAGetInfo(da,0,&Mx,0,0,0,0,0,0,0,0,0,0,0);CHKERRQ(ierr);
dt = 1.0/(10.*ctx.kappa*Mx*Mx*Mx*Mx);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Extract global vectors from DMDA; then duplicate for remaining
vectors that are the same types
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = DMCreateGlobalVector(da,&x);CHKERRQ(ierr);
ierr = VecDuplicate(x,&r);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Create timestepping solver context
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = TSCreate(PETSC_COMM_WORLD,&ts);CHKERRQ(ierr);
ierr = TSSetDM(ts,da);CHKERRQ(ierr);
ierr = TSSetProblemType(ts,TS_NONLINEAR);CHKERRQ(ierr);
ierr = TSSetIFunction(ts,NULL,FormFunction,&ctx);CHKERRQ(ierr);
ierr = TSSetDuration(ts,maxsteps,.02);CHKERRQ(ierr);
ierr = TSSetExactFinalTime(ts,TS_EXACTFINALTIME_STEPOVER);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Create matrix data structure; set Jacobian evaluation routine
< Set Jacobian matrix data structure and default Jacobian evaluation
routine. User can override with:
-snes_mf : matrix-free Newton-Krylov method with no preconditioning
(unless user explicitly sets preconditioner)
-snes_mf_operator : form preconditioning matrix as set by the user,
but use matrix-free approx for Jacobian-vector
products within Newton-Krylov method
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = TSGetSNES(ts,&snes);CHKERRQ(ierr);
ierr = DMCreateColoring(da,IS_COLORING_GLOBAL,&iscoloring);CHKERRQ(ierr);
ierr = DMSetMatType(da,MATAIJ);CHKERRQ(ierr);
ierr = DMCreateMatrix(da,&J);CHKERRQ(ierr);
ierr = MatFDColoringCreate(J,iscoloring,&matfdcoloring);CHKERRQ(ierr);
ierr = ISColoringDestroy(&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFunction(matfdcoloring,(PetscErrorCode (*)(void))SNESTSFormFunction,ts);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(matfdcoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetUp(J,iscoloring,matfdcoloring);CHKERRQ(ierr);
ierr = SNESSetJacobian(snes,J,J,SNESComputeJacobianDefaultColor,matfdcoloring);CHKERRQ(ierr);
{
ierr = VecDuplicate(x,&ul);CHKERRQ(ierr);
ierr = VecDuplicate(x,&uh);CHKERRQ(ierr);
ierr = VecStrideSet(ul,0,PETSC_NINFINITY);CHKERRQ(ierr);
ierr = VecStrideSet(ul,1,-1.0);CHKERRQ(ierr);
ierr = VecStrideSet(uh,0,PETSC_INFINITY);CHKERRQ(ierr);
ierr = VecStrideSet(uh,1,1.0);CHKERRQ(ierr);
ierr = TSVISetVariableBounds(ts,ul,uh);CHKERRQ(ierr);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Customize nonlinear solver
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = TSSetType(ts,TSBEULER);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Set initial conditions
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = FormInitialSolution(da,x,ctx.kappa);CHKERRQ(ierr);
ierr = TSSetInitialTimeStep(ts,0.0,dt);CHKERRQ(ierr);
ierr = TSSetSolution(ts,x);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Set runtime options
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = TSSetFromOptions(ts);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Solve nonlinear system
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = TSSolve(ts,x);CHKERRQ(ierr);
wait = PETSC_FALSE;
ierr = PetscOptionsGetBool(NULL,NULL,"-wait",&wait,NULL);CHKERRQ(ierr);
if (wait) {
ierr = PetscSleep(-1);CHKERRQ(ierr);
}
ierr = TSGetTimeStepNumber(ts,&steps);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Free work space. All PETSc objects should be destroyed when they
are no longer needed.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
{
ierr = VecDestroy(&ul);CHKERRQ(ierr);
ierr = VecDestroy(&uh);CHKERRQ(ierr);
}
ierr = MatDestroy(&J);CHKERRQ(ierr);
ierr = MatFDColoringDestroy(&matfdcoloring);CHKERRQ(ierr);
ierr = VecDestroy(&x);CHKERRQ(ierr);
ierr = VecDestroy(&r);CHKERRQ(ierr);
ierr = TSDestroy(&ts);CHKERRQ(ierr);
ierr = DMDestroy(&da);CHKERRQ(ierr);
ierr = PetscFinalize();
PetscFunctionReturn(0);
}
void PETSC_STDCALL matfdcoloringsetfunction_(MatFDColoring *fd,void (PETSC_STDCALL *f)(SNES*,Vec*,Vec*,void*,PetscErrorCode*),void *ctx,PetscErrorCode *ierr)
{
(*fd)->ftn_func_pointer = (void*) f;
(*fd)->ftn_func_cntx = ctx;
*ierr = MatFDColoringSetFunction(*fd,(PetscErrorCodeFunction)ourmatfdcoloringfunctionsnes,*fd);
}
int main(int argc,char **argv)
{
TS ts; /* nonlinear solver */
Vec u; /* solution, residual vectors */
Mat J; /* Jacobian matrix */
PetscInt steps,maxsteps = 1000; /* iterations for convergence */
PetscErrorCode ierr;
DM da;
MatFDColoring matfdcoloring = PETSC_NULL;
PetscReal ftime,dt;
MonitorCtx usermonitor; /* user-defined monitor context */
AppCtx user; /* user-defined work context */
JacobianType jacType;
PetscInitialize(&argc,&argv,(char *)0,help);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Create distributed array (DMDA) to manage parallel grid and vectors
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = DMDACreate1d(PETSC_COMM_WORLD,DMDA_BOUNDARY_NONE,-11,1,1,PETSC_NULL,&da);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Extract global vectors from DMDA;
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = DMCreateGlobalVector(da,&u);CHKERRQ(ierr);
/* Initialize user application context */
user.c = -30.0;
user.boundary = 0; /* 0: Dirichlet BC; 1: Neumann BC */
user.viewJacobian = PETSC_FALSE;
ierr = PetscOptionsGetInt(PETSC_NULL,"-boundary",&user.boundary,PETSC_NULL);CHKERRQ(ierr);
ierr = PetscOptionsHasName(PETSC_NULL,"-viewJacobian",&user.viewJacobian);CHKERRQ(ierr);
usermonitor.drawcontours = PETSC_FALSE;
ierr = PetscOptionsHasName(PETSC_NULL,"-drawcontours",&usermonitor.drawcontours);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Create timestepping solver context
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = TSCreate(PETSC_COMM_WORLD,&ts);CHKERRQ(ierr);
ierr = TSSetProblemType(ts,TS_NONLINEAR);CHKERRQ(ierr);
ierr = TSSetType(ts,TSTHETA);CHKERRQ(ierr);
ierr = TSThetaSetTheta(ts,1.0);CHKERRQ(ierr); /* Make the Theta method behave like backward Euler */
ierr = TSSetIFunction(ts,PETSC_NULL,FormIFunction,&user);CHKERRQ(ierr);
ierr = DMCreateMatrix(da,MATAIJ,&J);CHKERRQ(ierr);
jacType = JACOBIAN_ANALYTIC; /* use user-provide Jacobian */
ierr = TSSetIJacobian(ts,J,J,FormIJacobian,&user);CHKERRQ(ierr);
ierr = TSSetDM(ts,da);CHKERRQ(ierr); /* Use TSGetDM() to access. Setting here allows easy use of geometric multigrid. */
ftime = 1.0;
ierr = TSSetDuration(ts,maxsteps,ftime);CHKERRQ(ierr);
ierr = TSMonitorSet(ts,MyTSMonitor,&usermonitor,PETSC_NULL);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Set initial conditions
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = FormInitialSolution(ts,u,&user);CHKERRQ(ierr);
ierr = TSSetSolution(ts,u);CHKERRQ(ierr);
dt = .01;
ierr = TSSetInitialTimeStep(ts,0.0,dt);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Set runtime options
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = TSSetFromOptions(ts);CHKERRQ(ierr);
/* Use slow fd Jacobian or fast fd Jacobian with colorings.
Note: this requirs snes which is not created until TSSetUp()/TSSetFromOptions() is called */
ierr = PetscOptionsBegin(((PetscObject)da)->comm,PETSC_NULL,"Options for Jacobian evaluation",PETSC_NULL);CHKERRQ(ierr);
ierr = PetscOptionsEnum("-jac_type","Type of Jacobian","",JacobianTypes,(PetscEnum)jacType,(PetscEnum*)&jacType,0);CHKERRQ(ierr);
ierr = PetscOptionsEnd();CHKERRQ(ierr);
if (jacType == JACOBIAN_FD_COLORING) {
SNES snes;
ISColoring iscoloring;
ierr = DMCreateColoring(da,IS_COLORING_GLOBAL,MATAIJ,&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringCreate(J,iscoloring,&matfdcoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(matfdcoloring);CHKERRQ(ierr);
ierr = ISColoringDestroy(&iscoloring);CHKERRQ(ierr);
ierr = MatFDColoringSetFunction(matfdcoloring,(PetscErrorCode(*)(void))SNESTSFormFunction,ts);CHKERRQ(ierr);
ierr = TSGetSNES(ts,&snes);CHKERRQ(ierr);
ierr = SNESSetJacobian(snes,J,J,SNESDefaultComputeJacobianColor,matfdcoloring);CHKERRQ(ierr);
} else if (jacType == JACOBIAN_FD_FULL){
SNES snes;
ierr = TSGetSNES(ts,&snes);CHKERRQ(ierr);
ierr = SNESSetJacobian(snes,J,J,SNESDefaultComputeJacobian,&user);CHKERRQ(ierr);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Solve nonlinear system
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = TSSolve(ts,u,&ftime);CHKERRQ(ierr);
ierr = TSGetTimeStepNumber(ts,&steps);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Free work space.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = MatDestroy(&J);CHKERRQ(ierr);
if (matfdcoloring) {ierr = MatFDColoringDestroy(&matfdcoloring);CHKERRQ(ierr);}
ierr = VecDestroy(&u);CHKERRQ(ierr);
ierr = TSDestroy(&ts);CHKERRQ(ierr);
ierr = DMDestroy(&da);CHKERRQ(ierr);
ierr = PetscFinalize();
PetscFunctionReturn(0);
}
static PetscErrorCode SNESComputeJacobian_DMDA(SNES snes,Vec X,Mat *A,Mat *B,MatStructure *mstr,void *ctx)
{
PetscErrorCode ierr;
DM dm;
DMSNES_DA *dmdasnes = (DMSNES_DA*)ctx;
DMDALocalInfo info;
Vec Xloc;
void *x;
PetscFunctionBegin;
if (!dmdasnes->residuallocal) SETERRQ(PetscObjectComm((PetscObject)snes),PETSC_ERR_PLIB,"Corrupt context");
ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr);
if (dmdasnes->jacobianlocal) {
ierr = DMGetLocalVector(dm,&Xloc);CHKERRQ(ierr);
ierr = DMGlobalToLocalBegin(dm,X,INSERT_VALUES,Xloc);CHKERRQ(ierr);
ierr = DMGlobalToLocalEnd(dm,X,INSERT_VALUES,Xloc);CHKERRQ(ierr);
ierr = DMDAGetLocalInfo(dm,&info);CHKERRQ(ierr);
ierr = DMDAVecGetArray(dm,Xloc,&x);CHKERRQ(ierr);
CHKMEMQ;
ierr = (*dmdasnes->jacobianlocal)(&info,x,*A,*B,mstr,dmdasnes->jacobianlocalctx);CHKERRQ(ierr);
CHKMEMQ;
ierr = DMDAVecRestoreArray(dm,Xloc,&x);CHKERRQ(ierr);
ierr = DMRestoreLocalVector(dm,&Xloc);CHKERRQ(ierr);
} else {
MatFDColoring fdcoloring;
ierr = PetscObjectQuery((PetscObject)dm,"DMDASNES_FDCOLORING",(PetscObject*)&fdcoloring);CHKERRQ(ierr);
if (!fdcoloring) {
ISColoring coloring;
ierr = DMCreateColoring(dm,dm->coloringtype,&coloring);CHKERRQ(ierr);
ierr = MatFDColoringCreate(*B,coloring,&fdcoloring);CHKERRQ(ierr);
ierr = ISColoringDestroy(&coloring);CHKERRQ(ierr);
switch (dm->coloringtype) {
case IS_COLORING_GLOBAL:
ierr = MatFDColoringSetFunction(fdcoloring,(PetscErrorCode (*)(void))SNESComputeFunction_DMDA,dmdasnes);CHKERRQ(ierr);
break;
default: SETERRQ1(PetscObjectComm((PetscObject)snes),PETSC_ERR_SUP,"No support for coloring type '%s'",ISColoringTypes[dm->coloringtype]);
}
ierr = PetscObjectSetOptionsPrefix((PetscObject)fdcoloring,((PetscObject)dm)->prefix);CHKERRQ(ierr);
ierr = MatFDColoringSetFromOptions(fdcoloring);CHKERRQ(ierr);
ierr = PetscObjectCompose((PetscObject)dm,"DMDASNES_FDCOLORING",(PetscObject)fdcoloring);CHKERRQ(ierr);
ierr = PetscObjectDereference((PetscObject)fdcoloring);CHKERRQ(ierr);
/* The following breaks an ugly reference counting loop that deserves a paragraph. MatFDColoringApply() will call
* VecDuplicate() with the state Vec and store inside the MatFDColoring. This Vec will duplicate the Vec, but the
* MatFDColoring is composed with the DM. We dereference the DM here so that the reference count will eventually
* drop to 0. Note the code in DMDestroy() that exits early for a negative reference count. That code path will be
* taken when the PetscObjectList for the Vec inside MatFDColoring is destroyed.
*/
ierr = PetscObjectDereference((PetscObject)dm);CHKERRQ(ierr);
}
*mstr = SAME_NONZERO_PATTERN;
ierr = MatFDColoringApply(*B,fdcoloring,X,mstr,snes);CHKERRQ(ierr);
}
/* This will be redundant if the user called both, but it's too common to forget. */
if (*A != *B) {
ierr = MatAssemblyBegin(*A,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
ierr = MatAssemblyEnd(*A,MAT_FINAL_ASSEMBLY);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
EXTERN_C_END
EXTERN_C_BEGIN
#undef __FUNCT__
#define __FUNCT__ "TaoAppDefaultComputeHessianColor"
/*@C
TaoAppDefaultComputeHessianColor - Computes the Hessian using colored finite differences.
Collective on TAO_APPLICATION
Input Parameters:
+ tao - the TAO_APPLICATION context
. V - compute Hessian at this point
- ctx - the TAO_APPLICATION structure, cast to (void*)
Output Parameters:
+ H - Hessian matrix (not altered in this routine)
. B - newly computed Hessian matrix to use with preconditioner (generally the same as H)
- flag - flag indicating whether the matrix sparsity structure has changed
Options Database Keys:
+ -mat_fd_coloring_freq <freq>
- -tao_view_hessian - view the hessian after each evaluation using PETSC_VIEWER_STDOUT_WORLD
Level: intermediate
Note:
The gradient evaluation must be set using the routine TaoSetPetscGradient().
.keywords: TAO_APPLICATION, finite differences, Hessian, coloring, sparse
.seealso: TaoAppSetHessianRoutine(), TaoAppDefaultComputeHessian(),SNESDefaultComputeJacobianColor(),
TaoAppSetGradientRoutine(), TaoAppSetColoring()
@*/
int TaoAppDefaultComputeHessianColor(TAO_APPLICATION taoapp, Vec V, Mat *HH,Mat *BB,
MatStructure *flag,void *ctx){
int info;
MPI_Comm comm;
Vec G=0;
Mat H=*HH,B=*BB;
SNES snes;
ISColoring iscoloring;
MatFDColoring matfdcoloring;
TAO_SOLVER tao;
PetscFunctionBegin;
PetscValidHeaderSpecific(H,MAT_COOKIE,3);
PetscValidHeaderSpecific(B,MAT_COOKIE,4);
PetscCheckSameComm(V,2,H,3);
PetscCheckSameComm(H,3,B,4);
info = TaoAppGetTaoSolver(taoapp,&tao); CHKERRQ(info);
info = TaoAppGetColoring(taoapp,&iscoloring); CHKERRQ(info);
if (!iscoloring){
SETERRQ(1,"Must set coloring before using this routine. Try Finite Differences without coloring\n");
}
info = VecDuplicate(V,&G);CHKERRQ(info);
info=PetscInfo(G,"TAO computing matrix using finite differences and coloring\n"); CHKERRQ(info);
info=TaoAppComputeGradient(taoapp,V,G); CHKERRQ(info);
tao->ngrads++;
info = PetscObjectGetComm((PetscObject)(H),&comm);CHKERRQ(info);
info = SNESCreate(comm,&snes);CHKERRQ(info);
info = MatFDColoringCreate(H,iscoloring,&matfdcoloring);CHKERRQ(info);
info = MatFDColoringSetFunction(matfdcoloring,(int (*)(void)) Ftemp,taoapp);CHKERRQ(info);
info = MatFDColoringSetFromOptions(matfdcoloring);CHKERRQ(info);
info = SNESSetFunction(snes,G,Ftemp,taoapp);CHKERRQ(info);
info = SNESSetJacobian(snes,H,B,SNESDefaultComputeJacobianColor,(void*)matfdcoloring);CHKERRQ(info);
info = SNESDefaultComputeJacobianColor(snes,V,HH,BB,flag,matfdcoloring);CHKERRQ(info);
info = MatFDColoringDestroy(matfdcoloring);CHKERRQ(info);
info = SNESDestroy(snes);CHKERRQ(info);
info = VecDestroy(G);CHKERRQ(info);
PetscFunctionReturn(0);
}
