/*@C
TaoDefaultComputeHessian - Computes the Hessian using finite differences.
Collective on Tao
Input Parameters:
+ tao - the Tao context
. V - compute Hessian at this point
- dummy - not used
Output Parameters:
+ H - Hessian matrix (not altered in this routine)
- B - newly computed Hessian matrix to use with preconditioner (generally the same as H)
Options Database Key:
. -tao_fd_hessian - activates TaoDefaultComputeHessian()
Level: advanced
Notes:
This routine is slow and expensive, and is not currently optimized
to take advantage of sparsity in the problem. Although
TaoDefaultComputeHessian() is not recommended for general use
in large-scale applications, It can be useful in checking the
correctness of a user-provided Hessian.
.seealso: TaoSetHessianRoutine(), TaoDefaultComputeHessianColor(), SNESComputeJacobianDefault(), TaoSetGradientRoutine(), TaoDefaultComputeGradient()
@*/
PetscErrorCode TaoDefaultComputeHessian(Tao tao,Vec V,Mat H,Mat B,void *dummy)
{
PetscErrorCode ierr;
Vec G;
SNES snes;
DM dm;
PetscFunctionBegin;
ierr = VecDuplicate(V,&G);CHKERRQ(ierr);
ierr = PetscInfo(tao,"TAO Using finite differences w/o coloring to compute Hessian matrix\n");CHKERRQ(ierr);
ierr = TaoComputeGradient(tao,V,G);CHKERRQ(ierr);
ierr = SNESCreate(PetscObjectComm((PetscObject)H),&snes);CHKERRQ(ierr);
ierr = SNESSetFunction(snes,G,Fsnes,tao);CHKERRQ(ierr);
ierr = SNESGetDM(snes,&dm);CHKERRQ(ierr);
ierr = DMShellSetGlobalVector(dm,V);CHKERRQ(ierr);
ierr = SNESSetUp(snes);CHKERRQ(ierr);
if (H) {
PetscInt n,N;
ierr = VecGetSize(V,&N);CHKERRQ(ierr);
ierr = VecGetLocalSize(V,&n);CHKERRQ(ierr);
ierr = MatSetSizes(H,n,n,N,N);CHKERRQ(ierr);
ierr = MatSetUp(H);CHKERRQ(ierr);
}
if (B && B != H) {
PetscInt n,N;
ierr = VecGetSize(V,&N);CHKERRQ(ierr);
ierr = VecGetLocalSize(V,&n);CHKERRQ(ierr);
ierr = MatSetSizes(B,n,n,N,N);CHKERRQ(ierr);
ierr = MatSetUp(B);CHKERRQ(ierr);
}
ierr = SNESComputeJacobianDefault(snes,V,H,B,NULL);CHKERRQ(ierr);
ierr = SNESDestroy(&snes);CHKERRQ(ierr);
ierr = VecDestroy(&G);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode SNESSetUp_FAS(SNES snes)
{
SNES_FAS *fas = (SNES_FAS*) snes->data;
PetscErrorCode ierr;
PetscInt dm_levels;
Vec vec_sol, vec_func, vec_sol_update, vec_rhs; /* preserve these if they're set through the reset */
SNES next;
PetscBool isFine;
SNESLineSearch linesearch;
SNESLineSearch slinesearch;
void *lsprectx,*lspostctx;
PetscErrorCode (*precheck)(SNESLineSearch,Vec,Vec,PetscBool*,void*);
PetscErrorCode (*postcheck)(SNESLineSearch,Vec,Vec,Vec,PetscBool*,PetscBool*,void*);
PetscFunctionBegin;
ierr = SNESFASCycleIsFine(snes, &isFine);CHKERRQ(ierr);
if (fas->usedmfornumberoflevels && isFine) {
ierr = DMGetRefineLevel(snes->dm,&dm_levels);CHKERRQ(ierr);
dm_levels++;
if (dm_levels > fas->levels) {
/* we don't want the solution and func vectors to be destroyed in the SNESReset when it's called in SNESFASSetLevels_FAS*/
vec_sol = snes->vec_sol;
vec_func = snes->vec_func;
vec_sol_update = snes->vec_sol_update;
vec_rhs = snes->vec_rhs;
snes->vec_sol = NULL;
snes->vec_func = NULL;
snes->vec_sol_update = NULL;
snes->vec_rhs = NULL;
/* reset the number of levels */
ierr = SNESFASSetLevels(snes,dm_levels,NULL);CHKERRQ(ierr);
ierr = SNESSetFromOptions(snes);CHKERRQ(ierr);
snes->vec_sol = vec_sol;
snes->vec_func = vec_func;
snes->vec_rhs = vec_rhs;
snes->vec_sol_update = vec_sol_update;
}
}
ierr = SNESFASCycleGetCorrection(snes, &next);CHKERRQ(ierr);
if (!isFine) snes->gridsequence = 0; /* no grid sequencing inside the multigrid hierarchy! */
ierr = SNESSetWorkVecs(snes, 2);CHKERRQ(ierr); /* work vectors used for intergrid transfers */
/* set up the smoothers if they haven't already been set up */
if (!fas->smoothd) {
ierr = SNESFASCycleCreateSmoother_Private(snes, &fas->smoothd);CHKERRQ(ierr);
}
if (snes->dm) {
/* set the smoother DMs properly */
if (fas->smoothu) ierr = SNESSetDM(fas->smoothu, snes->dm);CHKERRQ(ierr);
ierr = SNESSetDM(fas->smoothd, snes->dm);CHKERRQ(ierr);
/* construct EVERYTHING from the DM -- including the progressive set of smoothers */
if (next) {
/* for now -- assume the DM and the evaluation functions have been set externally */
if (!next->dm) {
ierr = DMCoarsen(snes->dm, PetscObjectComm((PetscObject)next), &next->dm);CHKERRQ(ierr);
ierr = SNESSetDM(next, next->dm);CHKERRQ(ierr);
}
/* set the interpolation and restriction from the DM */
if (!fas->interpolate) {
ierr = DMCreateInterpolation(next->dm, snes->dm, &fas->interpolate, &fas->rscale);CHKERRQ(ierr);
if (!fas->restrct) {
ierr = PetscObjectReference((PetscObject)fas->interpolate);CHKERRQ(ierr);
fas->restrct = fas->interpolate;
}
}
/* set the injection from the DM */
if (!fas->inject) {
ierr = DMCreateInjection(next->dm, snes->dm, &fas->inject);CHKERRQ(ierr);
}
}
}
/*pass the smoother, function, and jacobian up to the next level if it's not user set already */
if (fas->galerkin) {
if (next) {
ierr = SNESSetFunction(next, NULL, SNESFASGalerkinDefaultFunction, next);CHKERRQ(ierr);
}
if (fas->smoothd && fas->level != fas->levels - 1) {
ierr = SNESSetFunction(fas->smoothd, NULL, SNESFASGalerkinDefaultFunction, snes);CHKERRQ(ierr);
}
if (fas->smoothu && fas->level != fas->levels - 1) {
ierr = SNESSetFunction(fas->smoothu, NULL, SNESFASGalerkinDefaultFunction, snes);CHKERRQ(ierr);
}
}
/* sets the down (pre) smoother's default norm and sets it from options */
if (fas->smoothd) {
if (fas->level == 0 && fas->levels != 1) {
ierr = SNESSetNormSchedule(fas->smoothd, SNES_NORM_NONE);CHKERRQ(ierr);
} else {
ierr = SNESSetNormSchedule(fas->smoothd, SNES_NORM_FINAL_ONLY);CHKERRQ(ierr);
}
ierr = PetscObjectCopyFortranFunctionPointers((PetscObject)snes, (PetscObject)fas->smoothd);CHKERRQ(ierr);
ierr = SNESSetFromOptions(fas->smoothd);CHKERRQ(ierr);
ierr = SNESGetLineSearch(snes,&linesearch);CHKERRQ(ierr);
ierr = SNESGetLineSearch(fas->smoothd,&slinesearch);CHKERRQ(ierr);
ierr = SNESLineSearchGetPreCheck(linesearch,&precheck,&lsprectx);CHKERRQ(ierr);
ierr = SNESLineSearchGetPostCheck(linesearch,&postcheck,&lspostctx);CHKERRQ(ierr);
ierr = SNESLineSearchSetPreCheck(slinesearch,precheck,lsprectx);CHKERRQ(ierr);
ierr = SNESLineSearchSetPostCheck(slinesearch,postcheck,lspostctx);CHKERRQ(ierr);
ierr = PetscObjectCopyFortranFunctionPointers((PetscObject)linesearch, (PetscObject)slinesearch);CHKERRQ(ierr);
fas->smoothd->vec_sol = snes->vec_sol;
ierr = PetscObjectReference((PetscObject)snes->vec_sol);CHKERRQ(ierr);
fas->smoothd->vec_sol_update = snes->vec_sol_update;
ierr = PetscObjectReference((PetscObject)snes->vec_sol_update);CHKERRQ(ierr);
fas->smoothd->vec_func = snes->vec_func;
ierr = PetscObjectReference((PetscObject)snes->vec_func);CHKERRQ(ierr);
if (fas->eventsmoothsetup) {ierr = PetscLogEventBegin(fas->eventsmoothsetup,0,0,0,0);CHKERRQ(ierr);}
ierr = SNESSetUp(fas->smoothd);CHKERRQ(ierr);
if (fas->eventsmoothsetup) {ierr = PetscLogEventEnd(fas->eventsmoothsetup,0,0,0,0);CHKERRQ(ierr);}
}
/* sets the up (post) smoother's default norm and sets it from options */
if (fas->smoothu) {
if (fas->level != fas->levels - 1) {
ierr = SNESSetNormSchedule(fas->smoothu, SNES_NORM_NONE);CHKERRQ(ierr);
} else {
ierr = SNESSetNormSchedule(fas->smoothu, SNES_NORM_FINAL_ONLY);CHKERRQ(ierr);
}
ierr = PetscObjectCopyFortranFunctionPointers((PetscObject)snes, (PetscObject)fas->smoothu);CHKERRQ(ierr);
ierr = SNESSetFromOptions(fas->smoothu);CHKERRQ(ierr);
ierr = SNESGetLineSearch(snes,&linesearch);CHKERRQ(ierr);
ierr = SNESGetLineSearch(fas->smoothu,&slinesearch);CHKERRQ(ierr);
ierr = SNESLineSearchGetPreCheck(linesearch,&precheck,&lsprectx);CHKERRQ(ierr);
ierr = SNESLineSearchGetPostCheck(linesearch,&postcheck,&lspostctx);CHKERRQ(ierr);
ierr = SNESLineSearchSetPreCheck(slinesearch,precheck,lsprectx);CHKERRQ(ierr);
ierr = SNESLineSearchSetPostCheck(slinesearch,postcheck,lspostctx);CHKERRQ(ierr);
ierr = PetscObjectCopyFortranFunctionPointers((PetscObject)linesearch, (PetscObject)slinesearch);CHKERRQ(ierr);
fas->smoothu->vec_sol = snes->vec_sol;
ierr = PetscObjectReference((PetscObject)snes->vec_sol);CHKERRQ(ierr);
fas->smoothu->vec_sol_update = snes->vec_sol_update;
ierr = PetscObjectReference((PetscObject)snes->vec_sol_update);CHKERRQ(ierr);
fas->smoothu->vec_func = snes->vec_func;
ierr = PetscObjectReference((PetscObject)snes->vec_func);CHKERRQ(ierr);
if (fas->eventsmoothsetup) {ierr = PetscLogEventBegin(fas->eventsmoothsetup,0,0,0,0);CHKERRQ(ierr);}
ierr = SNESSetUp(fas->smoothu);CHKERRQ(ierr);
if (fas->eventsmoothsetup) {ierr = PetscLogEventEnd(fas->eventsmoothsetup,0,0,0,0);CHKERRQ(ierr);}
}
if (next) {
/* gotta set up the solution vector for this to work */
if (!next->vec_sol) {ierr = SNESFASCreateCoarseVec(snes,&next->vec_sol);CHKERRQ(ierr);}
if (!next->vec_rhs) {ierr = SNESFASCreateCoarseVec(snes,&next->vec_rhs);CHKERRQ(ierr);}
ierr = PetscObjectCopyFortranFunctionPointers((PetscObject)snes, (PetscObject)next);CHKERRQ(ierr);
ierr = SNESGetLineSearch(snes,&linesearch);CHKERRQ(ierr);
ierr = SNESGetLineSearch(fas->next,&slinesearch);CHKERRQ(ierr);
ierr = SNESLineSearchGetPreCheck(linesearch,&precheck,&lsprectx);CHKERRQ(ierr);
ierr = SNESLineSearchGetPostCheck(linesearch,&postcheck,&lspostctx);CHKERRQ(ierr);
ierr = SNESLineSearchSetPreCheck(slinesearch,precheck,lsprectx);CHKERRQ(ierr);
ierr = SNESLineSearchSetPostCheck(slinesearch,postcheck,lspostctx);CHKERRQ(ierr);
ierr = PetscObjectCopyFortranFunctionPointers((PetscObject)linesearch, (PetscObject)slinesearch);CHKERRQ(ierr);
ierr = SNESSetUp(next);CHKERRQ(ierr);
}
/* setup FAS work vectors */
if (fas->galerkin) {
ierr = VecDuplicate(snes->vec_sol, &fas->Xg);CHKERRQ(ierr);
ierr = VecDuplicate(snes->vec_sol, &fas->Fg);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
int main(int argc,char **argv)
{
AppCtx user; /* user-defined work context */
PetscInt mx,my;
PetscErrorCode ierr;
MPI_Comm comm;
DM da;
Vec x;
Mat J = NULL,Jmf = NULL;
MatShellCtx matshellctx;
PetscInt mlocal,nlocal;
PC pc;
KSP ksp;
PetscBool errorinmatmult = PETSC_FALSE,errorinpcapply = PETSC_FALSE,errorinpcsetup = PETSC_FALSE;
ierr = PetscInitialize(&argc,&argv,(char*)0,help);if (ierr) return(1);
PetscFunctionBeginUser;
ierr = PetscOptionsGetBool(NULL,"-error_in_matmult",&errorinmatmult,NULL);CHKERRQ(ierr);
ierr = PetscOptionsGetBool(NULL,"-error_in_pcapply",&errorinpcapply,NULL);CHKERRQ(ierr);
ierr = PetscOptionsGetBool(NULL,"-error_in_pcsetup",&errorinpcsetup,NULL);CHKERRQ(ierr);
ierr = PetscOptionsGetBool(NULL,"-error_in_domain",&user.errorindomain,NULL);CHKERRQ(ierr);
ierr = PetscOptionsGetBool(NULL,"-error_in_domainmf",&user.errorindomainmf,NULL);CHKERRQ(ierr);
comm = PETSC_COMM_WORLD;
ierr = SNESCreate(comm,&user.snes);CHKERRQ(ierr);
/*
Create distributed array object to manage parallel grid and vectors
for principal unknowns (x) and governing residuals (f)
*/
ierr = DMDACreate2d(PETSC_COMM_WORLD,DM_BOUNDARY_NONE,DM_BOUNDARY_NONE,DMDA_STENCIL_STAR,-4,-4,PETSC_DECIDE,PETSC_DECIDE,4,1,0,0,&da);CHKERRQ(ierr);
ierr = SNESSetDM(user.snes,da);CHKERRQ(ierr);
ierr = DMDAGetInfo(da,0,&mx,&my,PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,
PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE,PETSC_IGNORE);CHKERRQ(ierr);
/*
Problem parameters (velocity of lid, prandtl, and grashof numbers)
*/
user.lidvelocity = 1.0/(mx*my);
user.prandtl = 1.0;
user.grashof = 1.0;
ierr = PetscOptionsGetReal(NULL,"-lidvelocity",&user.lidvelocity,NULL);CHKERRQ(ierr);
ierr = PetscOptionsGetReal(NULL,"-prandtl",&user.prandtl,NULL);CHKERRQ(ierr);
ierr = PetscOptionsGetReal(NULL,"-grashof",&user.grashof,NULL);CHKERRQ(ierr);
ierr = PetscOptionsHasName(NULL,"-contours",&user.draw_contours);CHKERRQ(ierr);
ierr = DMDASetFieldName(da,0,"x_velocity");CHKERRQ(ierr);
ierr = DMDASetFieldName(da,1,"y_velocity");CHKERRQ(ierr);
ierr = DMDASetFieldName(da,2,"Omega");CHKERRQ(ierr);
ierr = DMDASetFieldName(da,3,"temperature");CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Create user context, set problem data, create vector data structures.
Also, compute the initial guess.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Create nonlinear solver context
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = DMSetApplicationContext(da,&user);CHKERRQ(ierr);
ierr = DMDASNESSetFunctionLocal(da,INSERT_VALUES,(PetscErrorCode (*)(DMDALocalInfo*,void*,void*,void*))FormFunctionLocal,&user);CHKERRQ(ierr);
if (errorinmatmult) {
ierr = MatCreateSNESMF(user.snes,&Jmf);CHKERRQ(ierr);
ierr = MatSetFromOptions(Jmf);CHKERRQ(ierr);
ierr = MatGetLocalSize(Jmf,&mlocal,&nlocal);CHKERRQ(ierr);
matshellctx.Jmf = Jmf;
ierr = MatCreateShell(PetscObjectComm((PetscObject)Jmf),mlocal,nlocal,PETSC_DECIDE,PETSC_DECIDE,&matshellctx,&J);CHKERRQ(ierr);
ierr = MatShellSetOperation(J,MATOP_MULT,(void (*)(void))MatMult_MyShell);CHKERRQ(ierr);
ierr = MatShellSetOperation(J,MATOP_ASSEMBLY_END,(void (*)(void))MatAssemblyEnd_MyShell);CHKERRQ(ierr);
ierr = SNESSetJacobian(user.snes,J,J,MatMFFDComputeJacobian,NULL);CHKERRQ(ierr);
}
ierr = SNESSetFromOptions(user.snes);CHKERRQ(ierr);
ierr = PetscPrintf(comm,"lid velocity = %g, prandtl # = %g, grashof # = %g\n",(double)user.lidvelocity,(double)user.prandtl,(double)user.grashof);CHKERRQ(ierr);
if (errorinpcapply) {
ierr = SNESGetKSP(user.snes,&ksp);CHKERRQ(ierr);
ierr = KSPGetPC(ksp,&pc);CHKERRQ(ierr);
ierr = PCSetType(pc,PCSHELL);CHKERRQ(ierr);
ierr = PCShellSetApply(pc,PCApply_MyShell);CHKERRQ(ierr);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Solve the nonlinear system
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = DMCreateGlobalVector(da,&x);CHKERRQ(ierr);
ierr = FormInitialGuess(&user,da,x);CHKERRQ(ierr);
if (errorinpcsetup) {
ierr = SNESSetUp(user.snes);CHKERRQ(ierr);
ierr = SNESSetJacobian(user.snes,NULL,NULL,SNESComputeJacobian_MyShell,NULL);CHKERRQ(ierr);
}
ierr = SNESSolve(user.snes,NULL,x);CHKERRQ(ierr);
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Free work space. All PETSc objects should be destroyed when they
are no longer needed.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ierr = MatDestroy(&J);CHKERRQ(ierr);
ierr = MatDestroy(&Jmf);CHKERRQ(ierr);
ierr = VecDestroy(&x);CHKERRQ(ierr);
ierr = DMDestroy(&da);CHKERRQ(ierr);
ierr = SNESDestroy(&user.snes);CHKERRQ(ierr);
ierr = PetscFinalize();
return 0;
}
PetscErrorCode SNESDiffParameterCompute_More(SNES snes,void *nePv,Vec x,Vec p,double *fnoise,double *hopt)
{
DIFFPAR_MORE *neP = (DIFFPAR_MORE*)nePv;
Vec w, xp, fvec; /* work vectors to use in computing h */
double zero = 0.0, hl, hu, h, fnoise_s, fder2_s;
PetscScalar alpha;
PetscScalar fval[7], tab[7][7], eps[7], f = -1;
double rerrf = -1., fder2;
PetscErrorCode ierr;
PetscInt iter, k, i, j, info;
PetscInt nf = 7; /* number of function evaluations */
PetscInt fcount;
MPI_Comm comm;
FILE *fp;
PetscBool noise_test = PETSC_FALSE;
PetscFunctionBegin;
ierr = PetscObjectGetComm((PetscObject)snes,&comm);CHKERRQ(ierr);
/* Call to SNESSetUp() just to set data structures in SNES context */
if (!snes->setupcalled) {ierr = SNESSetUp(snes);CHKERRQ(ierr);}
w = neP->workv[0];
xp = neP->workv[1];
fvec = neP->workv[2];
fp = neP->fp;
/* Initialize parameters */
hl = zero;
hu = zero;
h = neP->h_first_try;
fnoise_s = zero;
fder2_s = zero;
fcount = neP->function_count;
/* We have 5 tries to attempt to compute a good hopt value */
ierr = SNESGetIterationNumber(snes,&i);CHKERRQ(ierr);
ierr = PetscFPrintf(comm,fp,"\n ------- SNES iteration %D ---------\n",i);CHKERRQ(ierr);
for (iter=0; iter<5; iter++) {
neP->h_first_try = h;
/* Compute the nf function values needed to estimate the noise from
the difference table */
for (k=0; k<nf; k++) {
alpha = h * (k+1 - (nf+1)/2);
ierr = VecWAXPY(xp,alpha,p,x);CHKERRQ(ierr);
ierr = SNESComputeFunction(snes,xp,fvec);CHKERRQ(ierr);
neP->function_count++;
ierr = VecDot(fvec,w,&fval[k]);CHKERRQ(ierr);
}
f = fval[(nf+1)/2 - 1];
/* Construct the difference table */
for (i=0; i<nf; i++) tab[i][0] = fval[i];
for (j=0; j<6; j++) {
for (i=0; i<nf-j; i++) {
tab[i][j+1] = tab[i+1][j] - tab[i][j];
}
}
/* Print the difference table */
ierr = PetscFPrintf(comm,fp,"Difference Table: iter = %D\n",iter);CHKERRQ(ierr);
for (i=0; i<nf; i++) {
for (j=0; j<nf-i; j++) {
ierr = PetscFPrintf(comm,fp," %10.2e ",tab[i][j]);CHKERRQ(ierr);
}
ierr = PetscFPrintf(comm,fp,"\n");CHKERRQ(ierr);
}
/* Call the noise estimator */
ierr = SNESNoise_dnest_(&nf,fval,&h,fnoise,&fder2,hopt,&info,eps);CHKERRQ(ierr);
/* Output statements */
rerrf = *fnoise/PetscAbsScalar(f);
if (info == 1) {ierr = PetscFPrintf(comm,fp,"%s\n","Noise detected");CHKERRQ(ierr);}
if (info == 2) {ierr = PetscFPrintf(comm,fp,"%s\n","Noise not detected; h is too small");CHKERRQ(ierr);}
if (info == 3) {ierr = PetscFPrintf(comm,fp,"%s\n","Noise not detected; h is too large");CHKERRQ(ierr);}
if (info == 4) {ierr = PetscFPrintf(comm,fp,"%s\n","Noise detected, but unreliable hopt");CHKERRQ(ierr);}
ierr = PetscFPrintf(comm,fp,"Approximate epsfcn %g %g %g %g %g %g\n",(double)eps[0],(double)eps[1],(double)eps[2],(double)eps[3],(double)eps[4],(double)eps[5]);CHKERRQ(ierr);
ierr = PetscFPrintf(comm,fp,"h = %g, fnoise = %g, fder2 = %g, rerrf = %g, hopt = %g\n\n",(double)h, (double)*fnoise, (double)fder2, (double)rerrf, (double)*hopt);CHKERRQ(ierr);
/* Save fnoise and fder2. */
if (*fnoise) fnoise_s = *fnoise;
if (fder2) fder2_s = fder2;
/* Check for noise detection. */
if (fnoise_s && fder2_s) {
*fnoise = fnoise_s;
fder2 = fder2_s;
*hopt = 1.68*sqrt(*fnoise/PetscAbsScalar(fder2));
goto theend;
} else {
/* Update hl and hu, and determine new h */
if (info == 2 || info == 4) {
hl = h;
if (hu == zero) h = 100*h;
else h = PetscMin(100*h,0.1*hu);
} else if (info == 3) {
hu = h;
h = PetscMax(1.0e-3,sqrt(hl/hu))*hu;
}
}
}
theend:
if (*fnoise < neP->fnoise_min) {
ierr = PetscFPrintf(comm,fp,"Resetting fnoise: fnoise1 = %g, fnoise_min = %g\n",(double)*fnoise,(double)neP->fnoise_min);CHKERRQ(ierr);
*fnoise = neP->fnoise_min;
neP->fnoise_resets++;
}
if (*hopt < neP->hopt_min) {
ierr = PetscFPrintf(comm,fp,"Resetting hopt: hopt1 = %g, hopt_min = %g\n",(double)*hopt,(double)neP->hopt_min);CHKERRQ(ierr);
*hopt = neP->hopt_min;
neP->hopt_resets++;
}
ierr = PetscFPrintf(comm,fp,"Errors in derivative:\n");CHKERRQ(ierr);
ierr = PetscFPrintf(comm,fp,"f = %g, fnoise = %g, fder2 = %g, hopt = %g\n",(double)f,(double)*fnoise,(double)fder2,(double)*hopt);CHKERRQ(ierr);
/* For now, compute h **each** MV Mult!! */
/*
ierr = PetscOptionsHasName(NULL,"-matrix_free_jorge_each_mvp",&flg);CHKERRQ(ierr);
if (!flg) {
Mat mat;
ierr = SNESGetJacobian(snes,&mat,NULL,NULL);CHKERRQ(ierr);
ierr = SNESDefaultMatrixFreeSetParameters2(mat,PETSC_DEFAULT,PETSC_DEFAULT,*hopt);CHKERRQ(ierr);
}
*/
fcount = neP->function_count - fcount;
ierr = PetscInfo5(snes,"fct_now = %D, fct_cum = %D, rerrf=%g, sqrt(noise)=%g, h_more=%g\n",fcount,neP->function_count,(double)rerrf,(double)PetscSqrtReal(*fnoise),(double)*hopt);CHKERRQ(ierr);
ierr = PetscOptionsGetBool(NULL,"-noise_test",&noise_test,NULL);CHKERRQ(ierr);
if (noise_test) {
ierr = JacMatMultCompare(snes,x,p,*hopt);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
PetscErrorCode SNESSetUp_Multiblock(SNES snes)
{
SNES_Multiblock *mb = (SNES_Multiblock *) snes->data;
BlockDesc blocks;
PetscInt i, numBlocks;
PetscErrorCode ierr;
PetscFunctionBegin;
/* ierr = SNESDefaultGetWork(snes, 1);CHKERRQ(ierr); */
ierr = SNESMultiblockSetDefaults(snes);CHKERRQ(ierr);
numBlocks = mb->numBlocks;
blocks = mb->blocks;
/* Create ISs */
if (!mb->issetup) {
PetscInt ccsize, rstart, rend, nslots, bs;
PetscBool sorted;
mb->issetup = PETSC_TRUE;
bs = mb->bs;
ierr = MatGetOwnershipRange(snes->jacobian_pre, &rstart, &rend);CHKERRQ(ierr);
ierr = MatGetLocalSize(snes->jacobian_pre, PETSC_NULL, &ccsize);CHKERRQ(ierr);
nslots = (rend - rstart)/bs;
for (i = 0; i < numBlocks; ++i) {
if (mb->defaultblocks) {
ierr = ISCreateStride(((PetscObject) snes)->comm, nslots, rstart+i, numBlocks, &blocks->is);CHKERRQ(ierr);
} else if (!blocks->is) {
if (blocks->nfields > 1) {
PetscInt *ii, j, k, nfields = blocks->nfields, *fields = blocks->fields;
ierr = PetscMalloc(nfields*nslots*sizeof(PetscInt), &ii);CHKERRQ(ierr);
for (j = 0; j < nslots; ++j) {
for (k = 0; k < nfields; ++k) {
ii[nfields*j + k] = rstart + bs*j + fields[k];
}
}
ierr = ISCreateGeneral(((PetscObject) snes)->comm, nslots*nfields, ii, PETSC_OWN_POINTER, &blocks->is);CHKERRQ(ierr);
} else {
ierr = ISCreateStride(((PetscObject) snes)->comm, nslots, rstart+blocks->fields[0], bs, &blocks->is);CHKERRQ(ierr);
}
}
ierr = ISSorted(blocks->is, &sorted);CHKERRQ(ierr);
if (!sorted) SETERRQ(PETSC_COMM_SELF, PETSC_ERR_USER, "Fields must be sorted when creating split");
blocks = blocks->next;
}
}
#if 0
/* Create matrices */
ilink = jac->head;
if (!jac->pmat) {
ierr = PetscMalloc(nsplit*sizeof(Mat),&jac->pmat);CHKERRQ(ierr);
for (i=0; i<nsplit; i++) {
ierr = MatGetSubMatrix(pc->pmat,ilink->is,ilink->is,MAT_INITIAL_MATRIX,&jac->pmat[i]);CHKERRQ(ierr);
ilink = ilink->next;
}
} else {
for (i=0; i<nsplit; i++) {
ierr = MatGetSubMatrix(pc->pmat,ilink->is,ilink->is,MAT_REUSE_MATRIX,&jac->pmat[i]);CHKERRQ(ierr);
ilink = ilink->next;
}
}
if (jac->realdiagonal) {
ilink = jac->head;
if (!jac->mat) {
ierr = PetscMalloc(nsplit*sizeof(Mat),&jac->mat);CHKERRQ(ierr);
for (i=0; i<nsplit; i++) {
ierr = MatGetSubMatrix(pc->mat,ilink->is,ilink->is,MAT_INITIAL_MATRIX,&jac->mat[i]);CHKERRQ(ierr);
ilink = ilink->next;
}
} else {
for (i=0; i<nsplit; i++) {
if (jac->mat[i]) {ierr = MatGetSubMatrix(pc->mat,ilink->is,ilink->is,MAT_REUSE_MATRIX,&jac->mat[i]);CHKERRQ(ierr);}
ilink = ilink->next;
}
}
} else {
jac->mat = jac->pmat;
}
#endif
#if 0
if (jac->type != PC_COMPOSITE_ADDITIVE && jac->type != PC_COMPOSITE_SCHUR) {
/* extract the rows of the matrix associated with each field: used for efficient computation of residual inside algorithm */
ilink = jac->head;
if (!jac->Afield) {
ierr = PetscMalloc(nsplit*sizeof(Mat),&jac->Afield);CHKERRQ(ierr);
for (i=0; i<nsplit; i++) {
ierr = MatGetSubMatrix(pc->mat,ilink->is,PETSC_NULL,MAT_INITIAL_MATRIX,&jac->Afield[i]);CHKERRQ(ierr);
ilink = ilink->next;
}
} else {
for (i=0; i<nsplit; i++) {
ierr = MatGetSubMatrix(pc->mat,ilink->is,PETSC_NULL,MAT_REUSE_MATRIX,&jac->Afield[i]);CHKERRQ(ierr);
ilink = ilink->next;
}
}
}
#endif
if (mb->type == PC_COMPOSITE_SCHUR) {
#if 0
IS ccis;
PetscInt rstart,rend;
if (nsplit != 2) SETERRQ(((PetscObject)pc)->comm,PETSC_ERR_ARG_INCOMP,"To use Schur complement preconditioner you must have exactly 2 fields");
/* When extracting off-diagonal submatrices, we take complements from this range */
ierr = MatGetOwnershipRangeColumn(pc->mat,&rstart,&rend);CHKERRQ(ierr);
/* need to handle case when one is resetting up the preconditioner */
if (jac->schur) {
ilink = jac->head;
ierr = ISComplement(ilink->is,rstart,rend,&ccis);CHKERRQ(ierr);
ierr = MatGetSubMatrix(pc->mat,ilink->is,ccis,MAT_REUSE_MATRIX,&jac->B);CHKERRQ(ierr);
ierr = ISDestroy(&ccis);CHKERRQ(ierr);
ilink = ilink->next;
ierr = ISComplement(ilink->is,rstart,rend,&ccis);CHKERRQ(ierr);
ierr = MatGetSubMatrix(pc->mat,ilink->is,ccis,MAT_REUSE_MATRIX,&jac->C);CHKERRQ(ierr);
ierr = ISDestroy(&ccis);CHKERRQ(ierr);
ierr = MatSchurComplementUpdate(jac->schur,jac->mat[0],jac->pmat[0],jac->B,jac->C,jac->pmat[1],pc->flag);CHKERRQ(ierr);
ierr = KSPSetOperators(jac->kspschur,jac->schur,FieldSplitSchurPre(jac),pc->flag);CHKERRQ(ierr);
} else {
KSP ksp;
char schurprefix[256];
/* extract the A01 and A10 matrices */
ilink = jac->head;
ierr = ISComplement(ilink->is,rstart,rend,&ccis);CHKERRQ(ierr);
ierr = MatGetSubMatrix(pc->mat,ilink->is,ccis,MAT_INITIAL_MATRIX,&jac->B);CHKERRQ(ierr);
ierr = ISDestroy(&ccis);CHKERRQ(ierr);
ilink = ilink->next;
ierr = ISComplement(ilink->is,rstart,rend,&ccis);CHKERRQ(ierr);
ierr = MatGetSubMatrix(pc->mat,ilink->is,ccis,MAT_INITIAL_MATRIX,&jac->C);CHKERRQ(ierr);
ierr = ISDestroy(&ccis);CHKERRQ(ierr);
/* Use mat[0] (diagonal block of the real matrix) preconditioned by pmat[0] */
ierr = MatCreateSchurComplement(jac->mat[0],jac->pmat[0],jac->B,jac->C,jac->mat[1],&jac->schur);CHKERRQ(ierr);
/* set tabbing and options prefix of KSP inside the MatSchur */
ierr = MatSchurComplementGetKSP(jac->schur,&ksp);CHKERRQ(ierr);
ierr = PetscObjectIncrementTabLevel((PetscObject)ksp,(PetscObject)pc,2);CHKERRQ(ierr);
ierr = PetscSNPrintf(schurprefix,sizeof(schurprefix),"%sfieldsplit_%s_",((PetscObject)pc)->prefix?((PetscObject)pc)->prefix:"",jac->head->splitname);CHKERRQ(ierr);
ierr = KSPSetOptionsPrefix(ksp,schurprefix);CHKERRQ(ierr);
ierr = MatSetFromOptions(jac->schur);CHKERRQ(ierr);
ierr = KSPCreate(((PetscObject)pc)->comm,&jac->kspschur);CHKERRQ(ierr);
ierr = PetscLogObjectParent((PetscObject)pc,(PetscObject)jac->kspschur);CHKERRQ(ierr);
ierr = PetscObjectIncrementTabLevel((PetscObject)jac->kspschur,(PetscObject)pc,1);CHKERRQ(ierr);
ierr = KSPSetOperators(jac->kspschur,jac->schur,FieldSplitSchurPre(jac),DIFFERENT_NONZERO_PATTERN);CHKERRQ(ierr);
if (jac->schurpre == PC_FIELDSPLIT_SCHUR_PRE_SELF) {
PC pc;
ierr = KSPGetPC(jac->kspschur,&pc);CHKERRQ(ierr);
ierr = PCSetType(pc,PCNONE);CHKERRQ(ierr);
/* Note: This is bad if there exist preconditioners for MATSCHURCOMPLEMENT */
}
ierr = PetscSNPrintf(schurprefix,sizeof(schurprefix),"%sfieldsplit_%s_",((PetscObject)pc)->prefix?((PetscObject)pc)->prefix:"",ilink->splitname);CHKERRQ(ierr);
ierr = KSPSetOptionsPrefix(jac->kspschur,schurprefix);CHKERRQ(ierr);
/* really want setfromoptions called in PCSetFromOptions_FieldSplit(), but it is not ready yet */
ierr = KSPSetFromOptions(jac->kspschur);CHKERRQ(ierr);
ierr = PetscMalloc2(2,Vec,&jac->x,2,Vec,&jac->y);CHKERRQ(ierr);
ierr = MatGetVecs(jac->pmat[0],&jac->x[0],&jac->y[0]);CHKERRQ(ierr);
ierr = MatGetVecs(jac->pmat[1],&jac->x[1],&jac->y[1]);CHKERRQ(ierr);
ilink = jac->head;
ilink->x = jac->x[0]; ilink->y = jac->y[0];
ilink = ilink->next;
ilink->x = jac->x[1]; ilink->y = jac->y[1];
}
#endif
} else {
/* Set up the individual SNESs */
blocks = mb->blocks;
i = 0;
while (blocks) {
/*TODO: Set these correctly */
/*ierr = SNESSetFunction(blocks->snes, blocks->x, func);CHKERRQ(ierr);*/
/*ierr = SNESSetJacobian(blocks->snes, blocks->x, jac);CHKERRQ(ierr);*/
ierr = VecDuplicate(blocks->snes->vec_sol, &blocks->x);CHKERRQ(ierr);
/* really want setfromoptions called in SNESSetFromOptions_Multiblock(), but it is not ready yet */
ierr = SNESSetFromOptions(blocks->snes);CHKERRQ(ierr);
ierr = SNESSetUp(blocks->snes);CHKERRQ(ierr);
blocks = blocks->next;
i++;
}
}
/* Compute scatter contexts needed by multiplicative versions and non-default splits */
if (!mb->blocks->sctx) {
Vec xtmp;
blocks = mb->blocks;
ierr = MatGetVecs(snes->jacobian_pre, &xtmp, PETSC_NULL);CHKERRQ(ierr);
while(blocks) {
ierr = VecScatterCreate(xtmp, blocks->is, blocks->x, PETSC_NULL, &blocks->sctx);CHKERRQ(ierr);
blocks = blocks->next;
}
ierr = VecDestroy(&xtmp);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
