/*
c ***********
c
c Subroutine dgqt
c
c Given an n by n symmetric matrix A, an n-vector b, and a
c positive number delta, this subroutine determines a vector
c x which approximately minimizes the quadratic function
c
c f(x) = (1/2)*x'*A*x + b'*x
c
c subject to the Euclidean norm constraint
c
c norm(x) <= delta.
c
c This subroutine computes an approximation x and a Lagrange
c multiplier par such that either par is zero and
c
c norm(x) <= (1+rtol)*delta,
c
c or par is positive and
c
c abs(norm(x) - delta) <= rtol*delta.
c
c If xsol is the solution to the problem, the approximation x
c satisfies
c
c f(x) <= ((1 - rtol)**2)*f(xsol)
c
c The subroutine statement is
c
c subroutine dgqt(n,a,lda,b,delta,rtol,atol,itmax,
c par,f,x,info,z,wa1,wa2)
c
c where
c
c n is an integer variable.
c On entry n is the order of A.
c On exit n is unchanged.
c
c a is a double precision array of dimension (lda,n).
c On entry the full upper triangle of a must contain the
c full upper triangle of the symmetric matrix A.
c On exit the array contains the matrix A.
c
c lda is an integer variable.
c On entry lda is the leading dimension of the array a.
c On exit lda is unchanged.
c
c b is an double precision array of dimension n.
c On entry b specifies the linear term in the quadratic.
c On exit b is unchanged.
c
c delta is a double precision variable.
c On entry delta is a bound on the Euclidean norm of x.
c On exit delta is unchanged.
c
c rtol is a double precision variable.
c On entry rtol is the relative accuracy desired in the
c solution. Convergence occurs if
c
c f(x) <= ((1 - rtol)**2)*f(xsol)
c
c On exit rtol is unchanged.
c
c atol is a double precision variable.
c On entry atol is the absolute accuracy desired in the
c solution. Convergence occurs when
c
c norm(x) <= (1 + rtol)*delta
c
c max(-f(x),-f(xsol)) <= atol
c
c On exit atol is unchanged.
c
c itmax is an integer variable.
c On entry itmax specifies the maximum number of iterations.
c On exit itmax is unchanged.
c
c par is a double precision variable.
c On entry par is an initial estimate of the Lagrange
c multiplier for the constraint norm(x) <= delta.
c On exit par contains the final estimate of the multiplier.
c
c f is a double precision variable.
c On entry f need not be specified.
c On exit f is set to f(x) at the output x.
c
c x is a double precision array of dimension n.
c On entry x need not be specified.
c On exit x is set to the final estimate of the solution.
c
c info is an integer variable.
c On entry info need not be specified.
c On exit info is set as follows:
c
c info = 1 The function value f(x) has the relative
c accuracy specified by rtol.
c
c info = 2 The function value f(x) has the absolute
c accuracy specified by atol.
c
c info = 3 Rounding errors prevent further progress.
c On exit x is the best available approximation.
c
c info = 4 Failure to converge after itmax iterations.
c On exit x is the best available approximation.
c
c z is a double precision work array of dimension n.
c
c wa1 is a double precision work array of dimension n.
c
c wa2 is a double precision work array of dimension n.
c
c Subprograms called
c
c MINPACK-2 ...... destsv
c
c LAPACK ......... dpotrf
c
c Level 1 BLAS ... daxpy, dcopy, ddot, dnrm2, dscal
c
c Level 2 BLAS ... dtrmv, dtrsv
c
c MINPACK-2 Project. October 1993.
c Argonne National Laboratory and University of Minnesota.
c Brett M. Averick, Richard Carter, and Jorge J. More'
c
c ***********
*/
PetscErrorCode gqt(PetscInt n, PetscReal *a, PetscInt lda, PetscReal *b,
PetscReal delta, PetscReal rtol, PetscReal atol,
PetscInt itmax, PetscReal *retpar, PetscReal *retf,
PetscReal *x, PetscInt *retinfo, PetscInt *retits,
PetscReal *z, PetscReal *wa1, PetscReal *wa2)
{
PetscErrorCode ierr;
PetscReal f=0.0,p001=0.001,p5=0.5,minusone=-1,delta2=delta*delta;
PetscInt iter, j, rednc,info;
PetscBLASInt indef;
PetscBLASInt blas1=1, blasn=n, iblas, blaslda = lda,blasldap1=lda+1,blasinfo;
PetscReal alpha, anorm, bnorm, parc, parf, parl, pars, par=*retpar,paru, prod, rxnorm, rznorm=0.0, temp, xnorm;
PetscFunctionBegin;
parf = 0.0;
xnorm = 0.0;
rxnorm = 0.0;
rednc = 0;
for (j=0; j<n; j++) {
x[j] = 0.0;
z[j] = 0.0;
}
/* Copy the diagonal and save A in its lower triangle */
PetscStackCallBLAS("BLAScopy",BLAScopy_(&blasn,a,&blasldap1, wa1, &blas1));
for (j=0;j<n-1;j++) {
iblas = n - j - 1;
PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,&a[j + lda*(j+1)], &blaslda, &a[j+1 + lda*j], &blas1));
}
/* Calculate the l1-norm of A, the Gershgorin row sums, and the
l2-norm of b */
anorm = 0.0;
for (j=0;j<n;j++) {
wa2[j] = BLASasum_(&blasn, &a[0 + lda*j], &blas1);
CHKMEMQ;
anorm = PetscMax(anorm,wa2[j]);
}
for (j=0;j<n;j++) {
wa2[j] = wa2[j] - PetscAbs(wa1[j]);
}
bnorm = BLASnrm2_(&blasn,b,&blas1);
CHKMEMQ;
/* Calculate a lower bound, pars, for the domain of the problem.
Also calculate an upper bound, paru, and a lower bound, parl,
for the Lagrange multiplier. */
pars = parl = paru = -anorm;
for (j=0;j<n;j++) {
pars = PetscMax(pars, -wa1[j]);
parl = PetscMax(parl, wa1[j] + wa2[j]);
paru = PetscMax(paru, -wa1[j] + wa2[j]);
}
parl = PetscMax(bnorm/delta - parl,pars);
parl = PetscMax(0.0,parl);
paru = PetscMax(0.0, bnorm/delta + paru);
/* If the input par lies outside of the interval (parl, paru),
set par to the closer endpoint. */
par = PetscMax(par,parl);
par = PetscMin(par,paru);
/* Special case: parl == paru */
paru = PetscMax(paru, (1.0 + rtol)*parl);
/* Beginning of an iteration */
info = 0;
for (iter=1;iter<=itmax;iter++) {
/* Safeguard par */
if (par <= pars && paru > 0) {
par = PetscMax(p001, PetscSqrtScalar(parl/paru)) * paru;
}
/* Copy the lower triangle of A into its upper triangle and
compute A + par*I */
for (j=0;j<n-1;j++) {
iblas = n - j - 1;
PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,&a[j+1 + j*lda], &blas1,&a[j + (j+1)*lda], &blaslda));
}
for (j=0;j<n;j++) {
a[j + j*lda] = wa1[j] + par;
}
/* Attempt the Cholesky factorization of A without referencing
the lower triangular part. */
PetscStackCallBLAS("LAPACKpotrf",LAPACKpotrf_("U",&blasn,a,&blaslda,&indef));
/* Case 1: A + par*I is pos. def. */
if (indef == 0) {
/* Compute an approximate solution x and save the
last value of par with A + par*I pos. def. */
parf = par;
PetscStackCallBLAS("BLAScopy",BLAScopy_(&blasn, b, &blas1, wa2, &blas1));
PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U","T","N",&blasn,&blas1,a,&blaslda,wa2,&blasn,&blasinfo));
rxnorm = BLASnrm2_(&blasn, wa2, &blas1);
PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U","N","N",&blasn,&blas1,a,&blaslda,wa2,&blasn,&blasinfo));
PetscStackCallBLAS("BLAScopy",BLAScopy_(&blasn, wa2, &blas1, x, &blas1));
PetscStackCallBLAS("BLASscal",BLASscal_(&blasn, &minusone, x, &blas1));
xnorm = BLASnrm2_(&blasn, x, &blas1);
CHKMEMQ;
/* Test for convergence */
if (PetscAbs(xnorm - delta) <= rtol*delta ||
(par == 0 && xnorm <= (1.0+rtol)*delta)) {
info = 1;
}
/* Compute a direction of negative curvature and use this
information to improve pars. */
iblas=blasn*blasn;
ierr = estsv(n,a,lda,&rznorm,z);CHKERRQ(ierr);
CHKMEMQ;
pars = PetscMax(pars, par-rznorm*rznorm);
/* Compute a negative curvature solution of the form
x + alpha*z, where norm(x+alpha*z)==delta */
rednc = 0;
if (xnorm < delta) {
/* Compute alpha */
prod = BLASdot_(&blasn, z, &blas1, x, &blas1) / delta;
temp = (delta - xnorm)*((delta + xnorm)/delta);
alpha = temp/(PetscAbs(prod) + PetscSqrtScalar(prod*prod + temp/delta));
if (prod >= 0) alpha = PetscAbs(alpha);
else alpha =-PetscAbs(alpha);
/* Test to decide if the negative curvature step
produces a larger reduction than with z=0 */
rznorm = PetscAbs(alpha) * rznorm;
if ((rznorm*rznorm + par*xnorm*xnorm)/(delta2) <= par) {
rednc = 1;
}
/* Test for convergence */
if (p5 * rznorm*rznorm / delta2 <= rtol*(1.0-p5*rtol)*(par + rxnorm*rxnorm/delta2)) {
info = 1;
} else if (info == 0 && (p5*(par + rxnorm*rxnorm/delta2) <= atol/delta2)) {
info = 2;
}
}
/* Compute the Newton correction parc to par. */
if (xnorm == 0) {
parc = -par;
} else {
PetscStackCallBLAS("BLAScopy",BLAScopy_(&blasn, x, &blas1, wa2, &blas1));
temp = 1.0/xnorm;
PetscStackCallBLAS("BLASscal",BLASscal_(&blasn, &temp, wa2, &blas1));
PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U","T","N",&blasn, &blas1, a, &blaslda, wa2, &blasn, &blasinfo));
temp = BLASnrm2_(&blasn, wa2, &blas1);
parc = (xnorm - delta)/(delta*temp*temp);
}
/* update parl or paru */
if (xnorm > delta) {
parl = PetscMax(parl, par);
} else if (xnorm < delta) {
paru = PetscMin(paru, par);
}
} else {
/* Case 2: A + par*I is not pos. def. */
/* Use the rank information from the Cholesky
decomposition to update par. */
if (indef > 1) {
/* Restore column indef to A + par*I. */
iblas = indef - 1;
PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,&a[indef-1 + 0*lda],&blaslda,&a[0 + (indef-1)*lda],&blas1));
a[indef-1 + (indef-1)*lda] = wa1[indef-1] + par;
/* compute parc. */
PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,&a[0 + (indef-1)*lda], &blas1, wa2, &blas1));
PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U","T","N",&iblas,&blas1,a,&blaslda,wa2,&blasn,&blasinfo));
PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,wa2,&blas1,&a[0 + (indef-1)*lda],&blas1));
temp = BLASnrm2_(&iblas,&a[0 + (indef-1)*lda],&blas1);
CHKMEMQ;
a[indef-1 + (indef-1)*lda] -= temp*temp;
PetscStackCallBLAS("LAPACKtrtr",LAPACKtrtrs_("U","N","N",&iblas,&blas1,a,&blaslda,wa2,&blasn,&blasinfo));
}
wa2[indef-1] = -1.0;
iblas = indef;
temp = BLASnrm2_(&iblas,wa2,&blas1);
parc = - a[indef-1 + (indef-1)*lda]/(temp*temp);
pars = PetscMax(pars,par+parc);
/* If necessary, increase paru slightly.
This is needed because in some exceptional situations
paru is the optimal value of par. */
paru = PetscMax(paru, (1.0+rtol)*pars);
}
/* Use pars to update parl */
parl = PetscMax(parl,pars);
/* Test for converged. */
if (info == 0) {
if (iter == itmax) info=4;
if (paru <= (1.0+p5*rtol)*pars) info=3;
if (paru == 0.0) info = 2;
}
/* If exiting, store the best approximation and restore
the upper triangle of A. */
if (info != 0) {
/* Compute the best current estimates for x and f. */
par = parf;
f = -p5 * (rxnorm*rxnorm + par*xnorm*xnorm);
if (rednc) {
f = -p5 * (rxnorm*rxnorm + par*delta*delta - rznorm*rznorm);
PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&blasn, &alpha, z, &blas1, x, &blas1));
}
/* Restore the upper triangle of A */
for (j = 0; j<n; j++) {
iblas = n - j - 1;
PetscStackCallBLAS("BLAScopy",BLAScopy_(&iblas,&a[j+1 + j*lda],&blas1, &a[j + (j+1)*lda],&blaslda));
}
iblas = lda+1;
PetscStackCallBLAS("BLAScopy",BLAScopy_(&blasn,wa1,&blas1,a,&iblas));
break;
}
par = PetscMax(parl,par+parc);
}
*retpar = par;
*retf = f;
*retinfo = info;
*retits = iter;
CHKMEMQ;
PetscFunctionReturn(0);
}
static PetscErrorCode KSPAGMRESBuildSoln(KSP ksp,PetscInt it)
{
KSP_AGMRES *agmres = (KSP_AGMRES*)ksp->data;
PetscErrorCode ierr;
PetscInt max_k = agmres->max_k; /* Size of the non-augmented Krylov basis */
PetscInt i, j;
PetscInt r = agmres->r; /* current number of augmented eigenvectors */
PetscBLASInt KspSize;
PetscBLASInt lC;
PetscBLASInt N;
PetscBLASInt ldH = N + 1;
PetscBLASInt lwork;
PetscBLASInt info, nrhs = 1;
PetscFunctionBegin;
ierr = PetscBLASIntCast(KSPSIZE,&KspSize);CHKERRQ(ierr);
ierr = PetscBLASIntCast(4 * (KspSize+1),&lwork);CHKERRQ(ierr);
ierr = PetscBLASIntCast(KspSize+1,&lC);CHKERRQ(ierr);
ierr = PetscBLASIntCast(MAXKSPSIZE + 1,&N);CHKERRQ(ierr);
ierr = PetscBLASIntCast(N + 1,&ldH);CHKERRQ(ierr);
/* Save a copy of the Hessenberg matrix */
for (j = 0; j < N-1; j++) {
for (i = 0; i < N; i++) {
*HS(i,j) = *H(i,j);
}
}
/* QR factorize the Hessenberg matrix */
#if defined(PETSC_MISSING_LAPACK_GEQRF)
SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GEQRF - Lapack routine is unavailable.");
#else
PetscStackCallBLAS("LAPACKgeqrf",LAPACKgeqrf_(&lC, &KspSize, agmres->hh_origin, &ldH, agmres->tau, agmres->work, &lwork, &info));
if (info) SETERRQ1(PetscObjectComm((PetscObject)ksp), PETSC_ERR_LIB,"Error in LAPACK routine XGEQRF INFO=%d", info);
#endif
/* Update the right hand side of the least square problem */
ierr = PetscMemzero(agmres->nrs, N*sizeof(PetscScalar));CHKERRQ(ierr);
agmres->nrs[0] = ksp->rnorm;
#if defined(PETSC_MISSING_LAPACK_ORMQR)
SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"GEQRF - Lapack routine is unavailable.");
#else
PetscStackCallBLAS("LAPACKormqr",LAPACKormqr_("L", "T", &lC, &nrhs, &KspSize, agmres->hh_origin, &ldH, agmres->tau, agmres->nrs, &N, agmres->work, &lwork, &info));
if (info) SETERRQ1(PetscObjectComm((PetscObject)ksp), PETSC_ERR_LIB,"Error in LAPACK routine XORMQR INFO=%d",info);
#endif
ksp->rnorm = PetscAbsScalar(agmres->nrs[KspSize]);
/* solve the least-square problem */
#if defined(PETSC_MISSING_LAPACK_TRTRS)
SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_SUP,"TRTRS - Lapack routine is unavailable.");
#else
PetscStackCallBLAS("LAPACKtrtrs",LAPACKtrtrs_("U", "N", "N", &KspSize, &nrhs, agmres->hh_origin, &ldH, agmres->nrs, &N, &info));
if (info) SETERRQ1(PetscObjectComm((PetscObject)ksp), PETSC_ERR_LIB,"Error in LAPACK routine XTRTRS INFO=%d",info);
#endif
/* Accumulate the correction to the solution of the preconditioned problem in VEC_TMP */
ierr = VecZeroEntries(VEC_TMP);CHKERRQ(ierr);
ierr = VecMAXPY(VEC_TMP, max_k, agmres->nrs, &VEC_V(0));CHKERRQ(ierr);
if (!agmres->DeflPrecond) { ierr = VecMAXPY(VEC_TMP, r, &agmres->nrs[max_k], agmres->U);CHKERRQ(ierr); }
if ((ksp->pc_side == PC_RIGHT) && agmres->r && agmres->DeflPrecond) {
ierr = KSPDGMRESApplyDeflation_DGMRES(ksp, VEC_TMP, VEC_TMP_MATOP);CHKERRQ(ierr);
ierr = VecCopy(VEC_TMP_MATOP, VEC_TMP);CHKERRQ(ierr);
}
ierr = KSPUnwindPreconditioner(ksp, VEC_TMP, VEC_TMP_MATOP);CHKERRQ(ierr);
/* add the solution to the previous one */
ierr = VecAXPY(ksp->vec_sol, 1.0, VEC_TMP);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
