/*
* -----------------------------------------------------------------
* Function : cpSptfqmrSolve
* -----------------------------------------------------------------
* This routine handles the call to the generic solver SptfqmrSolve
* for the solution of the linear system Ax = b with the SPTFQMR method.
* The solution x is returned in the vector b.
*
* If the WRMS norm of b is small, we return x = b (if this is the first
* Newton iteration) or x = 0 (if a later Newton iteration).
*
* Otherwise, we set the tolerance parameter and initial guess (x = 0),
* call SptfqmrSolve, and copy the solution x into b. The x-scaling and
* b-scaling arrays are both equal to weight.
*
* The counters nli, nps, and ncfl are incremented, and the return value
* is set according to the success of SptfqmrSolve. The success flag is
* returned if SptfqmrSolve converged, or if this is the first Newton
* iteration and the residual norm was reduced below its initial value.
* -----------------------------------------------------------------
*/
static int cpSptfqmrSolve(CPodeMem cp_mem, N_Vector b, N_Vector weight,
N_Vector yC, N_Vector ypC, N_Vector fctC)
{
realtype bnorm, res_norm;
CPSpilsMem cpspils_mem;
SptfqmrMem sptfqmr_mem;
int nli_inc, nps_inc, retval;
cpspils_mem = (CPSpilsMem) lmem;
sptfqmr_mem = (SptfqmrMem) spils_mem;
/* Test norm(b); if small, return x = 0 or x = b */
deltar = delt * tq[4];
bnorm = N_VWrmsNorm(b, weight);
if (bnorm <= deltar) {
if (mnewt > 0) N_VConst(ZERO, b);
return(0);
}
/* Set vectors ycur and fcur for use by the Atimes and Psolve routines */
ycur = yC;
ypcur = ypC;
fcur = fctC;
/* Set inputs delta and initial guess x = 0 to SptfqmrSolve */
delta = deltar * sqrtN;
N_VConst(ZERO, x);
/* Call SptfqmrSolve and copy x to b */
retval = SptfqmrSolve(sptfqmr_mem, cp_mem, x, b, pretype, delta,
cp_mem, weight, weight, cpSpilsAtimes, cpSpilsPSolve,
&res_norm, &nli_inc, &nps_inc);
N_VScale(ONE, x, b);
/* Increment counters nli, nps, and ncfl */
nli += nli_inc;
nps += nps_inc;
if (retval != SPTFQMR_SUCCESS) ncfl++;
/* Interpret return value from SpgmrSolve */
last_flag = retval;
switch(retval) {
case SPTFQMR_SUCCESS:
return(0);
break;
case SPTFQMR_RES_REDUCED:
if (mnewt == 0) return(0);
else return(1);
break;
case SPTFQMR_CONV_FAIL:
return(1);
break;
case SPTFQMR_PSOLVE_FAIL_REC:
return(1);
break;
case SPTFQMR_ATIMES_FAIL_REC:
return(1);
break;
case SPTFQMR_MEM_NULL:
return(-1);
break;
case SPTFQMR_ATIMES_FAIL_UNREC:
cpProcessError(cp_mem, SPTFQMR_ATIMES_FAIL_UNREC, "CPSPTFQMR", "CPSptfqmrSolve", MSGS_JTIMES_FAILED);
return(-1);
break;
case SPTFQMR_PSOLVE_FAIL_UNREC:
cpProcessError(cp_mem, SPTFQMR_PSOLVE_FAIL_UNREC, "CPSPTFQMR", "CPSptfqmrSolve", MSGS_PSOLVE_FAILED);
return(-1);
break;
}
return(0);
}
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 IDASptfqmrSolve(IDAMem IDA_mem, N_Vector bb, N_Vector weight,
N_Vector yy_now, N_Vector yp_now, N_Vector rr_now)
{
IDASpilsMem idaspils_mem;
SptfqmrMem sptfqmr_mem;
int pretype, nli_inc, nps_inc, retval;
realtype res_norm;
idaspils_mem = (IDASpilsMem) lmem;
sptfqmr_mem = (SptfqmrMem)spils_mem;
/* Set SptfqmrSolve convergence test constant epslin, in terms of the
Newton convergence test constant epsNewt and safety factors. The factor
sqrt(Neq) assures that the TFQMR convergence test is applied to the
WRMS norm of the residual vector, rather than the weighted L2 norm. */
epslin = sqrtN*eplifac*epsNewt;
/* Set vectors ycur, ypcur, and rcur for use by the Atimes and Psolve */
ycur = yy_now;
ypcur = yp_now;
rcur = rr_now;
/* Set SptfqmrSolve inputs pretype and initial guess xx = 0 */
pretype = (psolve == NULL) ? PREC_NONE : PREC_LEFT;
N_VConst(ZERO, xx);
/* Call SptfqmrSolve and copy xx to bb */
retval = SptfqmrSolve(sptfqmr_mem, IDA_mem, xx, bb, pretype, epslin,
IDA_mem, weight, weight, IDASpilsAtimes,
IDASpilsPSolve, &res_norm, &nli_inc, &nps_inc);
if (nli_inc == 0) N_VScale(ONE, SPTFQMR_VTEMP(sptfqmr_mem), bb);
else N_VScale(ONE, xx, bb);
/* Increment counters nli, nps, and return if successful */
nli += nli_inc;
nps += nps_inc;
if (retval != SPTFQMR_SUCCESS) ncfl++;
/* Interpret return value from SpgmrSolve */
last_flag = retval;
switch(retval) {
case SPTFQMR_SUCCESS:
return(0);
break;
case SPTFQMR_RES_REDUCED:
return(1);
break;
case SPTFQMR_CONV_FAIL:
return(1);
break;
case SPTFQMR_PSOLVE_FAIL_REC:
return(1);
break;
case SPTFQMR_ATIMES_FAIL_REC:
return(1);
break;
case SPTFQMR_MEM_NULL:
return(-1);
break;
case SPTFQMR_ATIMES_FAIL_UNREC:
IDAProcessError(IDA_mem, SPTFQMR_ATIMES_FAIL_UNREC, "IDASPTFQMR", "IDASptfqmrSolve", MSGS_JTIMES_FAILED);
return(-1);
break;
case SPTFQMR_PSOLVE_FAIL_UNREC:
IDAProcessError(IDA_mem, SPTFQMR_PSOLVE_FAIL_UNREC, "IDASPTFQMR", "IDASptfqmrSolve", MSGS_PSOLVE_FAILED);
return(-1);
break;
}
return(0);
}
