static int Precondbd(N_Vector cc, N_Vector cscale,
N_Vector fval, N_Vector fscale,
void *P_data,
N_Vector vtemp1, N_Vector vtemp2)
{
realtype r, r0, uround, sqruround, xx, yy, delx, dely, csave, fac;
realtype *cxy, *scxy, **Pxy, *ratesxy, *Pxycol, perturb_rates[NUM_SPECIES];
long int i, j, jx, jy, ret;
UserData data;
data = (UserData)P_data;
delx = data->dx;
dely = data->dy;
uround = data->uround;
sqruround = data->sqruround;
fac = N_VWL2Norm(fval, fscale);
r0 = THOUSAND * uround * fac * NEQ;
if(r0 == ZERO) r0 = ONE;
/* Loop over spatial points; get size NUM_SPECIES Jacobian block at each */
for (jy = 0; jy < MYSUB; jy++) {
yy = dely*(jy + data->isuby * MYSUB);
for (jx = 0; jx < MXSUB; jx++) {
xx = delx*(jx + data->isubx * MXSUB);
Pxy = (data->P)[jx][jy];
cxy = IJ_Vptr(cc,jx,jy);
scxy= IJ_Vptr(cscale,jx,jy);
ratesxy = IJ_Vptr((data->rates),jx,jy);
/* Compute difference quotients of interaction rate fn. */
for (j = 0; j < NUM_SPECIES; j++) {
csave = cxy[j]; /* Save the j,jx,jy element of cc */
r = MAX(sqruround*ABS(csave), r0/scxy[j]);
cxy[j] += r; /* Perturb the j,jx,jy element of cc */
fac = ONE/r;
WebRate(xx, yy, cxy, perturb_rates, data);
/* Restore j,jx,jy element of cc */
cxy[j] = csave;
/* Load the j-th column of difference quotients */
Pxycol = Pxy[j];
for (i = 0; i < NUM_SPECIES; i++)
Pxycol[i] = (perturb_rates[i] - ratesxy[i]) * fac;
} /* end of j loop */
/* Do LU decomposition of size NUM_SPECIES preconditioner block */
ret = denGETRF(Pxy, NUM_SPECIES, NUM_SPECIES, (data->pivot)[jx][jy]);
if (ret != 0) return(1);
} /* end of jx loop */
} /* end of jy loop */
return(0);
}
static int kinLapackBandSolve(KINMem kin_mem, N_Vector x, N_Vector b, realtype *res_norm)
{
KINDlsMem kindls_mem;
realtype *xd;
int ier, one = 1;
kindls_mem = (KINDlsMem) lmem;
/* Copy the right-hand side into x */
N_VScale(ONE, b, x);
xd = N_VGetArrayPointer(x);
/* Back-solve and get solution in x */
dgbtrs_f77("N", &n, &ml, &mu, &one, J->data, &(J->ldim), pivots, xd, &n, &ier, 1);
if (ier > 0) return(-1);
/* Compute the terms Jpnorm and sfdotJp for use in the global strategy
* routines and in KINForcingTerm. Both of these terms are subsequently
* corrected if the step is reduced by constraints or the line search.
*
* sJpnorm is the norm of the scaled product (scaled by fscale) of
* the current Jacobian matrix J and the step vector p.
*
* sfdotJp is the dot product of the scaled f vector and the scaled
* vector J*p, where the scaling uses fscale.
*/
sJpnorm = N_VWL2Norm(b,fscale);
N_VProd(b, fscale, b);
N_VProd(b, fscale, b);
sfdotJp = N_VDotProd(fval, b);
last_flag = KINDLS_SUCCESS;
return(0);
}
realtype N_VWL2Norm_SensWrapper(N_Vector x, N_Vector w)
{
int i;
realtype nrm, tmp;
nrm = ZERO;
for (i=0; i < NV_NVECS_SW(x); i++) {
tmp = N_VWL2Norm(NV_VEC_SW(x,i), NV_VEC_SW(w,i));
if (tmp > nrm) nrm = tmp;
}
return(nrm);
}
static int KINDenseSolve(KINMem kin_mem, N_Vector x, N_Vector b, realtype *res_norm)
{
KINDenseMem kindense_mem;
realtype *xd;
kindense_mem = (KINDenseMem) lmem;
/* Copy the right-hand side into x */
N_VScale(ONE, b, x);
xd = N_VGetArrayPointer(x);
/* Back-solve and get solution in x */
DenseGETRS(J, pivots, xd);
/* Compute the terms Jpnorm and sfdotJp for use in the global strategy
routines and in KINForcingTerm. Both of these terms are subsequently
corrected if the step is reduced by constraints or the line search.
sJpnorm is the norm of the scaled product (scaled by fscale) of
the current Jacobian matrix J and the step vector p.
sfdotJp is the dot product of the scaled f vector and the scaled
vector J*p, where the scaling uses fscale. */
sJpnorm = N_VWL2Norm(b,fscale);
N_VProd(b, fscale, b);
N_VProd(b, fscale, b);
sfdotJp = N_VDotProd(fval, b);
last_flag = KINDENSE_SUCCESS;
return(0);
}
int nlsKinsolSolve(DATA *data, threadData_t *threadData, int sysNumber)
{
NONLINEAR_SYSTEM_DATA *nlsData = &(data->simulationInfo->nonlinearSystemData[sysNumber]);
NLS_KINSOL_DATA *kinsolData = (NLS_KINSOL_DATA*)nlsData->solverData;
long eqSystemNumber = nlsData->equationIndex;
int indexes[2] = {1,eqSystemNumber};
int flag, i;
long nFEval;
int success = 0;
int retry = 0;
double *xStart = NV_DATA_S(kinsolData->initialGuess);
double *xScaling = NV_DATA_S(kinsolData->xScale);
double *fScaling = NV_DATA_S(kinsolData->fScale);
double fNormValue;
/* set user data */
kinsolData->userData.data = data;
kinsolData->userData.threadData = threadData;
kinsolData->userData.sysNumber = sysNumber;
/* reset configuration settings */
nlsKinsolConfigSetup(kinsolData);
infoStreamPrint(LOG_NLS, 0, "------------------------------------------------------");
infoStreamPrintWithEquationIndexes(LOG_NLS, 1, indexes, "Start solving non-linear system >>%ld<< using Kinsol solver at time %g", eqSystemNumber, data->localData[0]->timeValue);
nlsKinsolResetInitial(data, kinsolData, nlsData, INITIAL_EXTRAPOLATION);
/* set x scaling */
nlsKinsolXScaling(data, kinsolData, nlsData, SCALING_NOMINALSTART);
/* set f scaling */
_omc_fillVector(_omc_createVector(nlsData->size, fScaling), 1.);
/* */
do{
/* dump configuration */
nlsKinsolConfigPrint(kinsolData, nlsData);
flag = KINSol(kinsolData->kinsolMemory, /* KINSol memory block */
kinsolData->initialGuess, /* initial guess on input; solution vector */
kinsolData->kinsolStrategy, /* global strategy choice */
kinsolData->xScale, /* scaling vector, for the variable cc */
kinsolData->fScale); /* scaling vector for function values fval */
infoStreamPrint(LOG_NLS_V, 0, "KINSol finished with errorCode %d.", flag);
/* check for errors */
if(flag < 0)
{
retry = nlsKinsolErrorHandler(flag, data, nlsData, kinsolData);
}
/* solution found */
if ((flag == KIN_SUCCESS) || (flag == KIN_INITIAL_GUESS_OK) || (flag == KIN_STEP_LT_STPTOL))
{
success = 1;
}
kinsolData->retries++;
/* write statistics */
KINGetNumNonlinSolvIters(kinsolData->kinsolMemory, &nFEval);
nlsData->numberOfIterations += nFEval;
nlsData->numberOfFEval += kinsolData->countResCalls;
infoStreamPrint(LOG_NLS_V, 0, "Next try? success = %d, retry = %d, retries = %d = %s\n", success, retry, kinsolData->retries,!success && !(retry<1) && kinsolData->retries<RETRY_MAX ? "true" : "false" );
}while(!success && !(retry<0) && kinsolData->retries < RETRY_MAX);
/* solution found */
if (success)
{
/* check if solution really solves the residuals */
nlsKinsolResiduals(kinsolData->initialGuess, kinsolData->fRes, &kinsolData->userData);
fNormValue = N_VWL2Norm(kinsolData->fRes, kinsolData->fRes);
infoStreamPrint(LOG_NLS, 0, "scaled Euclidean norm of F(u) = %e", fNormValue);
if (FTOL_WITH_LESS_ACCURANCY<fNormValue)
{
warningStreamPrint(LOG_NLS, 0, "False positive solution. FNorm is too small.");
success = 0;
}
else /* solved system for reuse linear solver information */
{
kinsolData->solved = 1;
}
/* copy solution */
memcpy(nlsData->nlsx, xStart, nlsData->size*(sizeof(double)));
/* dump solution */
if(ACTIVE_STREAM(LOG_NLS))
{
infoStreamPrintWithEquationIndexes(LOG_NLS, 1, indexes, "solution for NLS %ld at t=%g", eqSystemNumber, kinsolData->userData.data->localData[0]->timeValue);
for(i=0; i<nlsData->size; ++i)
{
infoStreamPrintWithEquationIndexes(LOG_NLS, 0, indexes, "[%d] %s = %g", i+1, modelInfoGetEquation(&kinsolData->userData.data->modelData->modelDataXml,eqSystemNumber).vars[i], nlsData->nlsx[i]);
}
messageClose(LOG_NLS);
}
}
messageClose(LOG_NLS);
return success;
}
static int KINSptfqmrSolve(KINMem kin_mem, N_Vector xx, N_Vector bb,
realtype *sJpnorm, realtype *sFdotJp)
{
KINSpilsMem kinspils_mem;
SptfqmrMem sptfqmr_mem;
int ret, nli_inc, nps_inc;
realtype res_norm;
kinspils_mem = (KINSpilsMem) lmem;
sptfqmr_mem = (SptfqmrMem) spils_mem;
/* Set initial guess to xx = 0. bb is set, by the routine
calling KINSptfqmrSolve, to the RHS vector for the system
to be solved. */
N_VConst(ZERO, xx);
new_uu = TRUE; /* set flag required for user Jacobian routine */
/* call SptfqmrSolve */
ret = SptfqmrSolve(sptfqmr_mem, kin_mem, xx, bb, pretype, eps,
kin_mem, fscale, fscale, KINSpilsAtimes,
KINSpilsPSolve, &res_norm, &nli_inc, &nps_inc);
/* increment counters nli, nps, and ncfl
(nni is updated in the KINSol main iteration loop) */
nli = nli + (long int) nli_inc;
nps = nps + (long int) nps_inc;
if (printfl > 2)
KINPrintInfo(kin_mem, PRNT_NLI, "KINSPTFQMR", "KINSptfqmrSolve", INFO_NLI, nli_inc);
if (ret != 0) ncfl++;
last_flag = ret;
if ( (ret != 0) && (ret != SPTFQMR_RES_REDUCED) ) {
/* Handle all failure returns from SptfqmrSolve */
switch(ret) {
case SPTFQMR_PSOLVE_FAIL_REC:
case SPTFQMR_ATIMES_FAIL_REC:
return(1);
break;
case SPTFQMR_CONV_FAIL:
case SPTFQMR_MEM_NULL:
case SPTFQMR_ATIMES_FAIL_UNREC:
case SPTFQMR_PSOLVE_FAIL_UNREC:
return(-1);
break;
}
}
/* SptfqmrSolve returned either SPTFQMR_SUCCESS or SPTFQMR_RES_REDUCED.
Compute the terms sJpnorm and sFdotJp for use in the linesearch
routine and in KINForcingTerm. Both of these terms are subsequently
corrected if the step is reduced by constraints or the linesearch.
sJpnorm is the norm of the scaled product (scaled by fscale) of the
current Jacobian matrix J and the step vector p (= solution vector xx).
sFdotJp is the dot product of the scaled f vector and the scaled
vector J*p, where the scaling uses fscale. */
ret = KINSpilsAtimes(kin_mem, xx, bb);
if (ret > 0) {
last_flag = SPTFQMR_ATIMES_FAIL_REC;
return(1);
}
else if (ret < 0) {
last_flag = SPTFQMR_ATIMES_FAIL_UNREC;
return(-1);
}
*sJpnorm = N_VWL2Norm(bb, fscale);
N_VProd(bb, fscale, bb);
N_VProd(bb, fscale, bb);
*sFdotJp = N_VDotProd(fval, bb);
if (printfl > 2) KINPrintInfo(kin_mem, PRNT_EPS, "KINSPTFQMR",
"KINSptfqmrSolve", INFO_EPS, res_norm, eps);
return(0);
}
static int KINSpbcgSolve(KINMem kin_mem, N_Vector xx, N_Vector bb,
realtype *res_norm)
{
KINSpilsMem kinspils_mem;
SpbcgMem spbcg_mem;
int ret, nli_inc, nps_inc;
kinspils_mem = (KINSpilsMem) lmem;
spbcg_mem = (SpbcgMem) spils_mem;
/* Set initial guess to xx = 0. bb is set, by the routine
calling KINSpbcgSolve, to the RHS vector for the system
to be solved. */
N_VConst(ZERO, xx);
new_uu = TRUE; /* set flag required for user Jacobian routine */
/* call SpbcgSolve */
ret = SpbcgSolve(spbcg_mem, kin_mem, xx, bb, pretype, eps,
kin_mem, fscale, fscale, KINSpilsAtimes,
KINSpilsPSolve, res_norm, &nli_inc, &nps_inc);
/* increment counters nli, nps, and ncfl
(nni is updated in the KINSol main iteration loop) */
nli = nli + (long int) nli_inc;
nps = nps + (long int) nps_inc;
if (printfl > 2)
KINPrintInfo(kin_mem, PRNT_NLI, "KINSPBCG", "KINSpbcgSolve", INFO_NLI, nli_inc);
if (ret != 0) ncfl++;
/* Compute the terms sJpnorm and sfdotJp for use in the global strategy
routines and in KINForcingTerm. Both of these terms are subsequently
corrected if the step is reduced by constraints or the line search.
sJpnorm is the norm of the scaled product (scaled by fscale) of
the current Jacobian matrix J and the step vector p.
sfdotJp is the dot product of the scaled f vector and the scaled
vector J*p, where the scaling uses fscale. */
ret = KINSpilsAtimes(kin_mem, xx, bb);
if (ret == 0) ret = SPBCG_SUCCESS;
else if (ret > 0) ret = SPBCG_ATIMES_FAIL_REC;
else if (ret < 0) ret = SPBCG_ATIMES_FAIL_UNREC;
sJpnorm = N_VWL2Norm(bb,fscale);
N_VProd(bb, fscale, bb);
N_VProd(bb, fscale, bb);
sfdotJp = N_VDotProd(fval, bb);
if (printfl > 2)
KINPrintInfo(kin_mem, PRNT_EPS, "KINSPBCG", "KINSpbcgSolve", INFO_EPS, *res_norm, eps);
/* Interpret return value from SpbcgSolve */
last_flag = ret;
switch(ret) {
case SPBCG_SUCCESS:
case SPBCG_RES_REDUCED:
return(0);
break;
case SPBCG_PSOLVE_FAIL_REC:
case SPBCG_ATIMES_FAIL_REC:
return(1);
break;
case SPBCG_CONV_FAIL:
case SPBCG_MEM_NULL:
case SPBCG_ATIMES_FAIL_UNREC:
case SPBCG_PSOLVE_FAIL_UNREC:
return(-1);
break;
}
return(0);
}
static int KINSolInit(void *kinmem, integer Neq,
N_Vector uu, SysFn func, int globalstrategy,
N_Vector uscale, N_Vector fscale,
real fnormtol, real scsteptol, N_Vector constraints,
boole optIn, long int iopt[], real ropt[], void *f_data)
{
boole ioptExists, roptExists, ioptBad, roptNeg;
KINMem kin_mem;
FILE *fp;
/* Check for legal input parameters */
kin_mem = (KINMem)kinmem;
fp = kin_mem->kin_msgfp;
if (Neq <= 0)
{
fprintf(fp, MSG_BAD_NEQ, Neq);
return(-1);
}
if (uu == NULL)
{
fprintf(fp, MSG_UU_NULL);
return(-1);
}
if (func == NULL)
{
fprintf(fp, MSG_FUNC_NULL);
return(-1);
}
if ((globalstrategy != INEXACT_NEWTON) && (globalstrategy != LINESEARCH))
{
fprintf(fp, MSG_BAD_GLSTRAT, globalstrategy, INEXACT_NEWTON, LINESEARCH);
return(-1);
}
if (uscale == NULL)
{
fprintf(fp, MSG_BAD_USCALE);
return(-1);
}
if (N_VMin(uscale) <= ZERO)
{
fprintf(fp, MSG_USCALE_NONPOSITIVE);
return(-1);
}
if (fscale == NULL)
{
fprintf(fp, MSG_BAD_FSCALE);
return(-1);
}
if (N_VMin(fscale) <= ZERO)
{
fprintf(fp, MSG_FSCALE_NONPOSITIVE);
return(-1);
}
if (fnormtol < ZERO)
{
fprintf(fp, MSG_BAD_FNORMTOL, fnormtol);
return(-1);
}
if (scsteptol < ZERO)
{
fprintf(fp, MSG_BAD_SCSTEPTOL, scsteptol);
return(-1);
}
if ((optIn != FALSE) && (optIn != TRUE))
{
fprintf(fp, MSG_BAD_OPTIN, optIn, FALSE, TRUE);
return(-1);
}
if ((optIn) && (iopt == NULL) && (ropt == NULL))
{
fprintf(fp, MSG_BAD_OPT);
return(-1);
}
kin_mem->kin_ioptExists = ioptExists = (iopt != NULL);
kin_mem->kin_roptExists = roptExists = (ropt != NULL);
/* Set the constraints flag */
if (constraints == NULL)
constraintsSet = FALSE;
else
constraintsSet = TRUE;
/* All error checking is complete at this point */
/* Copy the input parameters into KINSol state */
kin_mem->kin_uu = uu;
kin_mem->kin_func = func;
kin_mem->kin_f_data = f_data;
kin_mem->kin_globalstrategy = globalstrategy;
kin_mem->kin_fnormtol = fnormtol;
kin_mem->kin_scsteptol = scsteptol;
kin_mem->kin_iopt = iopt;
kin_mem->kin_ropt = ropt;
kin_mem->kin_constraints = constraints;
kin_mem->kin_uscale = uscale;
kin_mem->kin_fscale = fscale;
kin_mem->kin_precondflag = FALSE; /* set to the correct state in KINSpgmr */
/* (additional readability constants are defined below/after KINMalloc) */
/* check the value of the two tolerances */
if (scsteptol <= ZERO)
scsteptol = RPowerR(uround, TWOTHIRDS);
if (fnormtol <= ZERO)
fnormtol = RPowerR(uround, ONETHIRD);
/* Handle the remaining optional inputs */
printfl = PRINTFL_DEFAULT;
mxiter = MXITER_DEFAULT;
if (ioptExists && optIn)
{
if (iopt[PRINTFL] > 0 && iopt[PRINTFL] < 4)
printfl = iopt[PRINTFL];
if (iopt[MXITER] > 0)
mxiter = iopt[MXITER];
ioptBad = (iopt[PRINTFL] < 0 || iopt[MXITER] < 0 || iopt[PRINTFL] > 3);
if (ioptBad)
{
fprintf(fp, MSG_IOPT_OUT);
free(kin_mem);
return(-1);
}
}
if (printfl > 0)
fprintf(fp, "scsteptol used: %12.3g \n", scsteptol);
if (printfl > 0)
fprintf(fp, "fnormtol used: %12.3g \n", fnormtol);
sqrt_relfunc = RSqrt(uround);
/* calculate the default value for mxnewtstep (max Newton step) */
mxnewtstep = THOUSAND * N_VWL2Norm(uu, uscale);
if (mxnewtstep < ONE)
mxnewtstep = ONE;
relu = RELU_DEFAULT;
if (roptExists && optIn)
{
if (ropt[MXNEWTSTEP] > ZERO)
mxnewtstep = ropt[MXNEWTSTEP];
if (ropt[RELFUNC] > ZERO)
sqrt_relfunc = RSqrt(ropt[RELFUNC]);
if (ropt[RELU] > ZERO)
relu = ropt[RELU];
roptNeg = (ropt[MXNEWTSTEP] < ZERO || ropt[RELFUNC] < ZERO || ropt[RELU] < ZERO);
if (roptNeg)
{
fprintf(fp, MSG_ROPT_OUT);
free(kin_mem);
return(-1);
}
}
/* set up the coefficients for the eta calculation */
etaflag = ETACHOICE1; /* default choice */
if (ioptExists && optIn)
{
etaflag = iopt[ETACHOICE];
if (etaflag < ETACHOICE1 || etaflag > ETACONSTANT)
{
fprintf(fp, MSG_BAD_ETACHOICE);
etaflag = ETACHOICE1;
}
}
callForcingTerm = (etaflag != ETACONSTANT);
if (etaflag == ETACHOICE1)
/* this value ALWAYS used for Choice 1 */
ealpha = ONE + HALF * RSqrt(FIVE);
if (etaflag == ETACHOICE2)
{
/* default values: */
ealpha = TWO;
egamma = POINT9;
}
if (etaflag == ETACONSTANT)
eta = POINT1;
/* default value used --constant case */
else
eta = HALF;
/* Initial value for eta set to 0.5 for other than the ETACONSTANT option */
if (roptExists && optIn)
{
if (etaflag == ETACHOICE2)
{
ealpha = ropt[ETAALPHA];
egamma = ropt[ETAGAMMA];
if (ealpha <= ONE || ealpha > TWO)
{
/* alpha value out of range */
if (ealpha != ZERO)
fprintf(fp, MSG_ALPHA_BAD);
ealpha = 2.;
}
if (egamma <= ZERO || egamma > ONE)
{
/* gamma value out of range */
if (egamma != ZERO)
fprintf(fp, MSG_GAMMA_BAD);
egamma = POINT9;
}
}
else if (etaflag == ETACONSTANT)
eta = ropt[ETACONST];
if (eta <= ZERO || eta > ONE)
{
if (eta != ZERO)
fprintf(fp, MSG_ETACONST_BAD);
eta = POINT1;
}
}
/* Initialize all the counters */
nfe = nnilpre = nni = nbcf = nbktrk = 0;
/* Initialize optional output locations in iopt, ropt */
if (ioptExists)
{
iopt[NFE] = iopt[NNI] = 0;
iopt[NBKTRK] = 0;
}
if (roptExists)
{
ropt[FNORM] = ZERO;
ropt[STEPL] = ZERO;
}
/* check the initial guess uu against the constraints, if any, and
* also see if the system func(uu) = 0 is satisfied by the initial guess uu */
if (constraintsSet)
{
if (!KINInitialConstraint(kin_mem))
{
fprintf(fp, MSG_INITIAL_CNSTRNT);
KINFreeVectors(kin_mem);
free(kin_mem);
return(-1);
}
}
if (KINInitialStop(kin_mem))
return(+1);
/* initialize the L2 norms of f for the linear iteration steps */
fnorm = N_VWL2Norm(fval, fscale);
f1norm = HALF * fnorm * fnorm;
if (printfl > 0)
fprintf(fp,
"KINSolInit nni= %4ld fnorm= %26.16g nfe=%6ld \n", nni, fnorm, nfe);
/* Problem has been successfully initialized */
return(0);
}
static int KINLineSearch(KINMem kin_mem, real *fnormp, real *f1normp,
boole *maxStepTaken)
{
int ret, ivio, nfesav, rladjust = 0;
real pnorm, ratio, ratio1, slpi, rlmin, rlength, rl, rlmax, rldiff;
real rltmp, rlprev, pt1trl, f1nprv, f1lo, rllo, rlincr, alpha, beta;
real alpha_cond, beta_cond;
*maxStepTaken = FALSE;
pnorm = N_VWL2Norm(pp, uscale);
ratio = ONE; alpha = POINTOHOHOHONE; beta = POINT9;
if (pnorm > mxnewtstep)
{
ratio = mxnewtstep / pnorm;
N_VScale(ratio, pp, pp);
pnorm = mxnewtstep;
}
stepl = pnorm;
ivio = 0;
/* check if constraints are active, and
* constrain the step by the constraints*/
if (constraintsSet)
{
loop {
ret = KINConstraint(kin_mem);
if (ret == 1)
{
ivio = 1;
ratio1 = stepl / pnorm;
ratio *= ratio1;
N_VScale(ratio1, pp, pp);
pnorm = stepl;
if (printfl > 0)
fprintf(msgfp, " --- in routine KINLineSearch"
"(ivio=1, pnorm= %12.4e )\n", pnorm);
}
else
break;
}
}
slpi = sfdotJp * ratio;
rlength = KINScSteplength(kin_mem, uu, pp, uscale);
rlmin = scsteptol / rlength;
rl = ONE;
if (printfl > 2)
fprintf(msgfp, "KINLineSearch -----\n"
" min_lam%11.4e f1norm%11.4e pnorm"
"%11.4e\n", rlmin, f1norm, pnorm);
/* now begin the iteration to find a rl value which satisfies both the
* alpha- and beta- conditions. if rl becomes < rlmin, then terminate with a
* 1 being returned... */
nfesav = nfe;
loop {
N_VLinearSum(ONE, uu, rl, pp, unew);
func(Neq, unew, fval, f_data); nfe++;
*fnormp = N_VWL2Norm(fval, fscale);
*f1normp = HALF * (*fnormp) * (*fnormp);
alpha_cond = f1norm + alpha * slpi * rl;
if (printfl > 2 && rladjust > 0)
fprintf(msgfp,
" fnormp%15.8e f1normp%15.8e alpha_cond%15.8e lam%15.8e\n",
*fnormp, *f1normp, alpha_cond, rl);
if ((*f1normp) <= alpha_cond)
break;
/* alpha condition not satisfied perform quadratic backtrack to compute
* new rl value */
if (rl < rlmin)
{
/* no satisfactory unew can be found sufficiently distinct from uu.
* copy uu into unew and return. */
N_VScale(ONE, uu, unew);
func(Neq, unew, fval, f_data); nfe++;
*fnormp = N_VWL2Norm(fval, fscale);
*f1normp = HALF * (*fnormp) * (*fnormp);
nbktrk = nfe - nfesav - 1;
return(1);
}
rltmp = -slpi / (TWO * ((*f1normp) - f1norm - slpi));
if (rltmp > HALF * rl)
rltmp = HALF * rl;
rlprev = rl;
f1nprv = (*f1normp);
pt1trl = POINT1 * rl;
rl = MAX(pt1trl, rltmp);
rladjust++;
}
/* the alpha condition is satisfied. now check the beta condition. */
beta_cond = f1norm + beta * slpi * rl;
if (*f1normp < beta_cond)
{
if (rl == ONE && pnorm < stepl)
{
rlmax = stepl / pnorm;
if (ivio == 1)
rlmax = ONE;
do
{
rlprev = rl;
f1nprv = *f1normp;
rl = MIN(TWO * rl, rlmax);
rladjust++;
N_VLinearSum(ONE, uu, rl, pp, unew);
func(Neq, unew, fval, f_data); nfe++;
*fnormp = N_VWL2Norm(fval, fscale);
*f1normp = HALF * (*fnormp) * (*fnormp);
alpha_cond = f1norm + alpha * slpi * rl;
beta_cond = f1norm + beta * slpi * rl;
if (printfl > 2)
fprintf(msgfp, " f1normp%15.8e beta_cond%15.8e "
"lam=%15.8e\n", *f1normp, beta_cond, rl);
}
while ((*f1normp) <= alpha_cond &&
(*f1normp) < beta_cond && (rl < rlmax));
}
if (rl < ONE ||
((rl > ONE) && (*f1normp > alpha_cond)))
{
rllo = MIN(rl, rlprev);
rldiff = ABS(rlprev - rl);
if (rl < rlprev)
f1lo = *f1normp;
else
f1lo = f1nprv;
do
{
rlincr = HALF * rldiff;
rl = rllo + rlincr;
rladjust++;
N_VLinearSum(ONE, uu, rl, pp, unew);
func(Neq, unew, fval, f_data); nfe++;
*fnormp = N_VWL2Norm(fval, fscale);
*f1normp = HALF * *fnormp * *fnormp;
alpha_cond = f1norm + alpha * slpi * rl;
beta_cond = f1norm + beta * slpi * rl;
if (printfl > 2 && rladjust > 0)
fprintf(msgfp, " f1normp%12.5e alpha_cond%12.5e "
"beta_cond%12.5e lam%12.5e\n", *f1normp, alpha_cond, beta_cond, rl);
if ((*f1normp) > alpha_cond)
rldiff = rlincr;
else if (*f1normp < beta_cond)
{
rllo = rl;
rldiff = rldiff - rlincr;
f1lo = *f1normp;
}
}
while (*f1normp > alpha_cond ||
((*f1normp < beta_cond) && (rldiff > rlmin)));
if ((*f1normp) < beta_cond)
{
/* beta condition could not be satisfied. set unew to last
* u value that satisfied the alpha condition and continue.
* increment counter on number of steps beta condition not satisfied */
N_VLinearSum(ONE, uu, rllo, pp, unew);
func(Neq, unew, fval, f_data); nfe++;
*fnormp = N_VWL2Norm(fval, fscale);
*f1normp = HALF * *fnormp * *fnormp;
nbcf++;
}
} /* end of if rl < ONE block */
} /* end of f1normp < test loop */
nbktrk = nfe - nfesav - 1;
if (printfl > 1 && rladjust > 0)
fprintf(msgfp, "Number of lambda adjustments "
"%d\n", rladjust);
/* scale the following two expressions by rl and ratio for
* subsequent use in the KINForcingTerm routine */
sfdotJp = sfdotJp * rl * ratio;
sJpnorm = sJpnorm * rl * ratio;
if (rl * pnorm > POINT99 * mxnewtstep)
*maxStepTaken = TRUE;
return(0);
}
static int KINInexactNewton(KINMem kin_mem, real *fnormp, real *f1normp,
boole *maxStepTaken)
{
int ret;
real pnorm, ratio, ratio1;
*maxStepTaken = FALSE;
pnorm = N_VWL2Norm(pp, uscale);
ratio = ONE;
if (pnorm > mxnewtstep)
{
ratio = mxnewtstep / pnorm;
N_VScale(ratio, pp, pp);
pnorm = mxnewtstep;
}
stepl = pnorm;
if (printfl > 0)
fprintf(msgfp,
" ----- in routine KINInexactNewton (pnorm= %12.4e ) -----\n", pnorm);
/* check if constraints are active, and
* constrain the step by the constraints*/
if (constraintsSet)
{
loop {
ret = KINConstraint(kin_mem); /* NOTE: this routine changes stepl */
if (ret == 1)
{
ratio1 = stepl / pnorm;
ratio *= ratio1;
N_VScale(ratio1, pp, pp);
pnorm = stepl;
if (printfl > 0)
fprintf(msgfp,
" --- in routine KINInexactNewton (pnorm= %12.4e \n", pnorm);
if (pnorm <= scsteptol)
return(1);
}
else
break;
}
}
/* scale the following two expressions by ratio for
* subsequent use in the KINForcingTerm routine */
sfdotJp = sfdotJp * ratio;
sJpnorm = sJpnorm * ratio;
/* compute the iterate unew !! */
N_VLinearSum(ONE, uu, ONE, pp, unew);
func(Neq, unew, fval, f_data); nfe++;
*fnormp = N_VWL2Norm(fval, fscale);
*f1normp = HALF * (*fnormp) * (*fnormp);
if (printfl > 1)
fprintf(msgfp, " fnorm (L2) = %20.8e\n", (*fnormp));
if (pnorm > POINT99 * mxnewtstep)
*maxStepTaken = TRUE;
return(0);
}
/* Main Program */
int main()
{
/* general problem parameters */
realtype T0 = RCONST(0.0); /* initial time */
realtype Tf = RCONST(10.0); /* final time */
int Nt = 100; /* total number of output times */
int Nvar = 3; /* number of solution fields */
UserData udata = NULL;
realtype *data;
long int N = 201; /* spatial mesh size */
realtype a = 0.6; /* problem parameters */
realtype b = 2.0;
realtype du = 0.025;
realtype dv = 0.025;
realtype dw = 0.025;
realtype ep = 1.0e-5; /* stiffness parameter */
realtype reltol = 1.0e-6; /* tolerances */
realtype abstol = 1.0e-10;
long int NEQ, i;
/* general problem variables */
int flag; /* reusable error-checking flag */
N_Vector y = NULL; /* empty vector for storing solution */
N_Vector umask = NULL; /* empty mask vectors for viewing solution components */
N_Vector vmask = NULL;
N_Vector wmask = NULL;
void *arkode_mem = NULL; /* empty ARKode memory structure */
realtype pi, t, dTout, tout, u, v, w;
FILE *FID, *UFID, *VFID, *WFID;
int iout;
long int nst, nst_a, nfe, nfi, nsetups, nje, nfeLS, nni, ncfn, netf;
/* allocate udata structure */
udata = (UserData) malloc(sizeof(*udata));
if (check_flag((void *) udata, "malloc", 2)) return 1;
/* store the inputs in the UserData structure */
udata->N = N;
udata->a = a;
udata->b = b;
udata->du = du;
udata->dv = dv;
udata->dw = dw;
udata->ep = ep;
/* set total allocated vector length */
NEQ = Nvar*udata->N;
/* Initial problem output */
printf("\n1D Brusselator PDE test problem:\n");
printf(" N = %li, NEQ = %li\n", udata->N, NEQ);
printf(" problem parameters: a = %g, b = %g, ep = %g\n",
udata->a, udata->b, udata->ep);
printf(" diffusion coefficients: du = %g, dv = %g, dw = %g\n",
udata->du, udata->dv, udata->dw);
printf(" reltol = %.1e, abstol = %.1e\n\n", reltol, abstol);
/* Initialize data structures */
y = N_VNew_Serial(NEQ); /* Create serial vector for solution */
if (check_flag((void *)y, "N_VNew_Serial", 0)) return 1;
udata->dx = RCONST(1.0)/(N-1); /* set spatial mesh spacing */
data = N_VGetArrayPointer(y); /* Access data array for new NVector y */
if (check_flag((void *)data, "N_VGetArrayPointer", 0)) return 1;
umask = N_VNew_Serial(NEQ); /* Create serial vector masks */
if (check_flag((void *)umask, "N_VNew_Serial", 0)) return 1;
vmask = N_VNew_Serial(NEQ);
if (check_flag((void *)vmask, "N_VNew_Serial", 0)) return 1;
wmask = N_VNew_Serial(NEQ);
if (check_flag((void *)wmask, "N_VNew_Serial", 0)) return 1;
/* Set initial conditions into y */
pi = RCONST(4.0)*atan(RCONST(1.0));
for (i=0; i<N; i++) {
data[IDX(i,0)] = a + RCONST(0.1)*sin(pi*i*udata->dx); /* u */
data[IDX(i,1)] = b/a + RCONST(0.1)*sin(pi*i*udata->dx); /* v */
data[IDX(i,2)] = b + RCONST(0.1)*sin(pi*i*udata->dx); /* w */
}
/* Set mask array values for each solution component */
N_VConst(0.0, umask);
data = N_VGetArrayPointer(umask);
if (check_flag((void *)data, "N_VGetArrayPointer", 0)) return 1;
for (i=0; i<N; i++) data[IDX(i,0)] = RCONST(1.0);
N_VConst(0.0, vmask);
data = N_VGetArrayPointer(vmask);
if (check_flag((void *)data, "N_VGetArrayPointer", 0)) return 1;
for (i=0; i<N; i++) data[IDX(i,1)] = RCONST(1.0);
N_VConst(0.0, wmask);
data = N_VGetArrayPointer(wmask);
if (check_flag((void *)data, "N_VGetArrayPointer", 0)) return 1;
for (i=0; i<N; i++) data[IDX(i,2)] = RCONST(1.0);
/* Create the solver memory */
arkode_mem = ARKodeCreate();
if (check_flag((void *)arkode_mem, "ARKodeCreate", 0)) return 1;
/* Call ARKodeInit to initialize the integrator memory and specify the
right-hand side function in y'=f(t,y), the inital time T0, and
the initial dependent variable vector y. Note: since this
problem is fully implicit, we set f_E to NULL and f_I to f. */
flag = ARKodeInit(arkode_mem, NULL, f, T0, y);
if (check_flag(&flag, "ARKodeInit", 1)) return 1;
/* Set routines */
flag = ARKodeSetUserData(arkode_mem, (void *) udata); /* Pass udata to user functions */
if (check_flag(&flag, "ARKodeSetUserData", 1)) return 1;
flag = ARKodeSStolerances(arkode_mem, reltol, abstol); /* Specify tolerances */
if (check_flag(&flag, "ARKodeSStolerances", 1)) return 1;
/* Linear solver specification */
flag = ARKBand(arkode_mem, NEQ, 4, 4); /* Specify the band linear solver */
if (check_flag(&flag, "ARKBand", 1)) return 1;
flag = ARKDlsSetBandJacFn(arkode_mem, Jac); /* Set the Jacobian routine */
if (check_flag(&flag, "ARKDlsSetBandJacFn", 1)) return 1;
/* output spatial mesh to disk */
FID = fopen("bruss_mesh.txt","w");
for (i=0; i<N; i++) fprintf(FID," %.16e\n", udata->dx*i);
fclose(FID);
/* Open output streams for results, access data array */
UFID=fopen("bruss_u.txt","w");
VFID=fopen("bruss_v.txt","w");
WFID=fopen("bruss_w.txt","w");
/* output initial condition to disk */
data = N_VGetArrayPointer(y);
if (check_flag((void *)data, "N_VGetArrayPointer", 0)) return 1;
for (i=0; i<N; i++) fprintf(UFID," %.16e", data[IDX(i,0)]);
for (i=0; i<N; i++) fprintf(VFID," %.16e", data[IDX(i,1)]);
for (i=0; i<N; i++) fprintf(WFID," %.16e", data[IDX(i,2)]);
fprintf(UFID,"\n");
fprintf(VFID,"\n");
fprintf(WFID,"\n");
/* Main time-stepping loop: calls ARKode to perform the integration, then
prints results. Stops when the final time has been reached */
t = T0;
dTout = (Tf-T0)/Nt;
tout = T0+dTout;
printf(" t ||u||_rms ||v||_rms ||w||_rms\n");
printf(" ----------------------------------------------\n");
for (iout=0; iout<Nt; iout++) {
flag = ARKode(arkode_mem, tout, y, &t, ARK_NORMAL); /* call integrator */
if (check_flag(&flag, "ARKode", 1)) break;
u = N_VWL2Norm(y,umask); /* access/print solution statistics */
u = SUNRsqrt(u*u/N);
v = N_VWL2Norm(y,vmask);
v = SUNRsqrt(v*v/N);
w = N_VWL2Norm(y,wmask);
w = SUNRsqrt(w*w/N);
printf(" %10.6f %10.6f %10.6f %10.6f\n", t, u, v, w);
if (flag >= 0) { /* successful solve: update output time */
tout += dTout;
tout = (tout > Tf) ? Tf : tout;
} else { /* unsuccessful solve: break */
fprintf(stderr,"Solver failure, stopping integration\n");
break;
}
/* output results to disk */
for (i=0; i<N; i++) fprintf(UFID," %.16e", data[IDX(i,0)]);
for (i=0; i<N; i++) fprintf(VFID," %.16e", data[IDX(i,1)]);
for (i=0; i<N; i++) fprintf(WFID," %.16e", data[IDX(i,2)]);
fprintf(UFID,"\n");
fprintf(VFID,"\n");
fprintf(WFID,"\n");
}
printf(" ----------------------------------------------\n");
fclose(UFID);
fclose(VFID);
fclose(WFID);
/* Print some final statistics */
flag = ARKodeGetNumSteps(arkode_mem, &nst);
check_flag(&flag, "ARKodeGetNumSteps", 1);
flag = ARKodeGetNumStepAttempts(arkode_mem, &nst_a);
check_flag(&flag, "ARKodeGetNumStepAttempts", 1);
flag = ARKodeGetNumRhsEvals(arkode_mem, &nfe, &nfi);
check_flag(&flag, "ARKodeGetNumRhsEvals", 1);
flag = ARKodeGetNumLinSolvSetups(arkode_mem, &nsetups);
check_flag(&flag, "ARKodeGetNumLinSolvSetups", 1);
flag = ARKodeGetNumErrTestFails(arkode_mem, &netf);
check_flag(&flag, "ARKodeGetNumErrTestFails", 1);
flag = ARKodeGetNumNonlinSolvIters(arkode_mem, &nni);
check_flag(&flag, "ARKodeGetNumNonlinSolvIters", 1);
flag = ARKodeGetNumNonlinSolvConvFails(arkode_mem, &ncfn);
check_flag(&flag, "ARKodeGetNumNonlinSolvConvFails", 1);
flag = ARKDlsGetNumJacEvals(arkode_mem, &nje);
check_flag(&flag, "ARKDlsGetNumJacEvals", 1);
flag = ARKDlsGetNumRhsEvals(arkode_mem, &nfeLS);
check_flag(&flag, "ARKDlsGetNumRhsEvals", 1);
printf("\nFinal Solver Statistics:\n");
printf(" Internal solver steps = %li (attempted = %li)\n", nst, nst_a);
printf(" Total RHS evals: Fe = %li, Fi = %li\n", nfe, nfi);
printf(" Total linear solver setups = %li\n", nsetups);
printf(" Total RHS evals for setting up the linear system = %li\n", nfeLS);
printf(" Total number of Jacobian evaluations = %li\n", nje);
printf(" Total number of Newton iterations = %li\n", nni);
printf(" Total number of nonlinear solver convergence failures = %li\n", ncfn);
printf(" Total number of error test failures = %li\n\n", netf);
/* Clean up and return with successful completion */
N_VDestroy_Serial(y); /* Free vectors */
N_VDestroy_Serial(umask);
N_VDestroy_Serial(vmask);
N_VDestroy_Serial(wmask);
free(udata); /* Free user data */
ARKodeFree(&arkode_mem); /* Free integrator memory */
return 0;
}
int cpDoProjection(CPodeMem cp_mem, realtype saved_t, int *npfPtr)
{
int flag, retval;
realtype cnorm;
switch (proj_type) {
case CP_PROJ_INTERNAL:
/* Evaluate constraints at current time and with the corrected y */
retval = cfun(tn, y, ctemp, c_data);
nce++;
if (retval < 0) {flag = CP_CNSTRFUNC_FAIL; break;}
if (retval > 0) {flag = CNSTRFUNC_RECVR; break;}
/*
* If activated, evaluate WL2 norm of constraint violation.
* If the constraint violation is small enough, return.
*/
if (test_cnstr) {
cnorm = N_VWL2Norm(ctemp, ctol);
cnorm /= prjcoef;
#ifdef CPODES_DEBUG
printf(" Constraint violation norm = %lg\n",cnorm);
#endif
if (cnorm <= ONE) {
applyProj = FALSE;
return(CP_SUCCESS);
}
}
#ifdef CPODES_DEBUG
else {
printf(" No constraint testing\n");
}
#endif
/* Perform projection step
* On a successful return, the projection correction is available in acorP.
* Also, if projection of the error estimate was enabled, the new error
* estimate is available in errP and acnrm contains ||errP||_WRMS.
*/
nproj++;
if (cnstr_type == CP_CNSTR_NONLIN) flag = cpProjNonlinear(cp_mem);
else flag = cpProjLinear(cp_mem);
break;
case CP_PROJ_USER:
#ifdef CPODES_DEBUG
printf(" User-defined projection\n");
#endif
/* Use ftemp to store errP and tempv to store acorP
* (recall that in this case we did not allocate memory
* errP and acorP).
*/
errP = ftemp;
acorP = tempv;
/* Copy acor into errP */
N_VScale(ONE, acor, errP);
/* Call the user projection function */
retval = pfun(tn, y, acorP, prjcoef, errP, p_data);
nproj++;
if (retval < 0) {flag = CP_PROJFUNC_FAIL; break;}
if (retval > 0) {flag = PROJFUNC_RECVR; break;}
/* Recompute acnrm to be used in error test */
acnrm = N_VWrmsNorm(errP, ewt);
flag = CP_SUCCESS;
break;
}
#ifdef CPODES_DEBUG
printf(" acnrm = %lg\n",acnrm);
#endif
/* This is not the first projection anymore */
first_proj = FALSE;
/* If the projection was successful, return now. */
if (flag == CP_SUCCESS) {
applyProj = TRUE;
return(CP_SUCCESS);
}
/* The projection failed. Increment nprf and restore zn */
nprf++;
cpRestore(cp_mem, saved_t);
/* Return if lsetupP, lsolveP, cfun, or pfun failed unrecoverably */
if (flag == CP_PLSETUP_FAIL) return(CP_PLSETUP_FAIL);
if (flag == CP_PLSOLVE_FAIL) return(CP_PLSOLVE_FAIL);
if (flag == CP_CNSTRFUNC_FAIL) return(CP_CNSTRFUNC_FAIL);
if (flag == CP_PROJFUNC_FAIL) return(CP_PROJFUNC_FAIL);
/* At this point, flag = CONV_FAIL or CNSTRFUNC_RECVR or PRJFUNC_RECVR; increment npf */
(*npfPtr)++;
etamax = ONE;
/* If we had maxnpf failures or |h| = hmin,
return CP_PROJ_FAILURE or CP_REPTD_CNSTRFUNC_ERR or CP_REPTD_PROJFUNC_ERR. */
if ((ABS(h) <= hmin*ONEPSM) || (*npfPtr == maxnpf)) {
if (flag == CONV_FAIL) return(CP_PROJ_FAILURE);
if (flag == CNSTRFUNC_RECVR) return(CP_REPTD_CNSTRFUNC_ERR);
if (flag == PROJFUNC_RECVR) return(CP_REPTD_PROJFUNC_ERR);
}
/* Reduce step size; return to reattempt the step */
eta = MAX(ETAPR, hmin / ABS(h));
cpRescale(cp_mem);
return(PREDICT_AGAIN);
}
