PetscErrorCode VecNorm_Seq(Vec xin,NormType type,PetscReal *z)
{
const PetscScalar *xx;
PetscErrorCode ierr;
PetscInt n = xin->map->n;
PetscBLASInt one = 1, bn;
PetscFunctionBegin;
ierr = PetscBLASIntCast(n,&bn);CHKERRQ(ierr);
if (type == NORM_2 || type == NORM_FROBENIUS) {
ierr = VecGetArrayRead(xin,&xx);CHKERRQ(ierr);
#if defined(PETSC_USE_REAL___FP16)
*z = BLASnrm2_(&bn,xx,&one);
#else
*z = PetscRealPart(BLASdot_(&bn,xx,&one,xx,&one));
*z = PetscSqrtReal(*z);
#endif
ierr = VecRestoreArrayRead(xin,&xx);CHKERRQ(ierr);
ierr = PetscLogFlops(PetscMax(2.0*n-1,0.0));CHKERRQ(ierr);
} else if (type == NORM_INFINITY) {
PetscInt i;
PetscReal max = 0.0,tmp;
ierr = VecGetArrayRead(xin,&xx);CHKERRQ(ierr);
for (i=0; i<n; i++) {
if ((tmp = PetscAbsScalar(*xx)) > max) max = tmp;
/* check special case of tmp == NaN */
if (tmp != tmp) {max = tmp; break;}
xx++;
}
ierr = VecRestoreArrayRead(xin,&xx);CHKERRQ(ierr);
*z = max;
} else if (type == NORM_1) {
#if defined(PETSC_USE_COMPLEX)
PetscReal tmp = 0.0;
PetscInt i;
#endif
ierr = VecGetArrayRead(xin,&xx);CHKERRQ(ierr);
#if defined(PETSC_USE_COMPLEX)
/* BLASasum() returns the nonstandard 1 norm of the 1 norm of the complex entries so we provide a custom loop instead */
for (i=0; i<n; i++) {
tmp += PetscAbsScalar(xx[i]);
}
*z = tmp;
#else
PetscStackCallBLAS("BLASasum",*z = BLASasum_(&bn,xx,&one));
#endif
ierr = VecRestoreArrayRead(xin,&xx);CHKERRQ(ierr);
ierr = PetscLogFlops(PetscMax(n-1.0,0.0));CHKERRQ(ierr);
} else if (type == NORM_1_AND_2) {
ierr = VecNorm_Seq(xin,NORM_1,z);CHKERRQ(ierr);
ierr = VecNorm_Seq(xin,NORM_2,z+1);CHKERRQ(ierr);
}
PetscFunctionReturn(0);
}
/**************************************xyt.c***********************************/
static PetscErrorCode do_xyt_solve(xyt_ADT xyt_handle, PetscScalar *uc)
{
PetscInt off, len, *iptr;
PetscInt level =xyt_handle->level;
PetscInt n =xyt_handle->info->n;
PetscInt m =xyt_handle->info->m;
PetscInt *stages =xyt_handle->info->stages;
PetscInt *xcol_indices=xyt_handle->info->xcol_indices;
PetscInt *ycol_indices=xyt_handle->info->ycol_indices;
PetscScalar *x_ptr, *y_ptr, *uu_ptr;
PetscScalar *solve_uu=xyt_handle->info->solve_uu;
PetscScalar *solve_w =xyt_handle->info->solve_w;
PetscScalar *x =xyt_handle->info->x;
PetscScalar *y =xyt_handle->info->y;
PetscBLASInt i1 = 1,dlen;
PetscErrorCode ierr;
PetscFunctionBegin;
uu_ptr=solve_uu;
PCTFS_rvec_zero(uu_ptr,m);
/* x = X.Y^T.b */
/* uu = Y^T.b */
for (y_ptr=y,iptr=ycol_indices; *iptr!=-1; y_ptr+=len)
{
off =*iptr++;
len =*iptr++;
ierr = PetscBLASIntCast(len,&dlen);CHKERRQ(ierr);
PetscStackCall("BLASdot",*uu_ptr++ = BLASdot_(&dlen,uc+off,&i1,y_ptr,&i1));
}
/* comunication of beta */
uu_ptr=solve_uu;
if (level) PCTFS_ssgl_radd(uu_ptr, solve_w, level, stages);
PCTFS_rvec_zero(uc,n);
/* x = X.uu */
for (x_ptr=x,iptr=xcol_indices; *iptr!=-1; x_ptr+=len) {
off =*iptr++;
len =*iptr++;
ierr = PetscBLASIntCast(len,&dlen);CHKERRQ(ierr);
PetscStackCall("BLASaxpy",BLASaxpy_(&dlen,uu_ptr++,x_ptr,&i1,uc+off,&i1));
}
PetscFunctionReturn(0);
}
PetscErrorCode VecNorm_MPI(Vec xin,NormType type,PetscReal *z)
{
PetscReal sum,work = 0.0;
const PetscScalar *xx;
PetscErrorCode ierr;
PetscInt n = xin->map->n;
PetscBLASInt one = 1,bn;
PetscFunctionBegin;
ierr = PetscBLASIntCast(n,&bn);CHKERRQ(ierr);
if (type == NORM_2 || type == NORM_FROBENIUS) {
ierr = VecGetArrayRead(xin,&xx);CHKERRQ(ierr);
work = PetscRealPart(BLASdot_(&bn,xx,&one,xx,&one));
ierr = VecRestoreArrayRead(xin,&xx);CHKERRQ(ierr);
ierr = MPIU_Allreduce(&work,&sum,1,MPIU_REAL,MPIU_SUM,PetscObjectComm((PetscObject)xin));CHKERRQ(ierr);
*z = PetscSqrtReal(sum);
ierr = PetscLogFlops(2.0*xin->map->n);CHKERRQ(ierr);
} else if (type == NORM_1) {
/* Find the local part */
ierr = VecNorm_Seq(xin,NORM_1,&work);CHKERRQ(ierr);
/* Find the global max */
ierr = MPIU_Allreduce(&work,z,1,MPIU_REAL,MPIU_SUM,PetscObjectComm((PetscObject)xin));CHKERRQ(ierr);
} else if (type == NORM_INFINITY) {
/* Find the local max */
ierr = VecNorm_Seq(xin,NORM_INFINITY,&work);CHKERRQ(ierr);
/* Find the global max */
ierr = MPIU_Allreduce(&work,z,1,MPIU_REAL,MPIU_MAX,PetscObjectComm((PetscObject)xin));CHKERRQ(ierr);
} else if (type == NORM_1_AND_2) {
PetscReal temp[2];
ierr = VecNorm_Seq(xin,NORM_1,temp);CHKERRQ(ierr);
ierr = VecNorm_Seq(xin,NORM_2,temp+1);CHKERRQ(ierr);
temp[1] = temp[1]*temp[1];
ierr = MPIU_Allreduce(temp,z,2,MPIU_REAL,MPIU_SUM,PetscObjectComm((PetscObject)xin));CHKERRQ(ierr);
z[1] = PetscSqrtReal(z[1]);
}
PetscFunctionReturn(0);
}
/**************************************xyt.c***********************************/
static PetscInt xyt_generate(xyt_ADT xyt_handle)
{
PetscInt i,j,k,idx;
PetscInt dim, col;
PetscScalar *u, *uu, *v, *z, *w, alpha, alpha_w;
PetscInt *segs;
PetscInt op[] = {GL_ADD,0};
PetscInt off, len;
PetscScalar *x_ptr, *y_ptr;
PetscInt *iptr, flag;
PetscInt start =0, end, work;
PetscInt op2[] = {GL_MIN,0};
PCTFS_gs_ADT PCTFS_gs_handle;
PetscInt *nsep, *lnsep, *fo;
PetscInt a_n =xyt_handle->mvi->n;
PetscInt a_m =xyt_handle->mvi->m;
PetscInt *a_local2global=xyt_handle->mvi->local2global;
PetscInt level;
PetscInt n, m;
PetscInt *xcol_sz, *xcol_indices, *stages;
PetscScalar **xcol_vals, *x;
PetscInt *ycol_sz, *ycol_indices;
PetscScalar **ycol_vals, *y;
PetscInt n_global;
PetscInt xt_nnz =0, xt_max_nnz=0;
PetscInt yt_nnz =0, yt_max_nnz=0;
PetscInt xt_zero_nnz =0;
PetscInt xt_zero_nnz_0=0;
PetscInt yt_zero_nnz =0;
PetscInt yt_zero_nnz_0=0;
PetscBLASInt i1 = 1,dlen;
PetscScalar dm1 = -1.0;
PetscErrorCode ierr;
n =xyt_handle->mvi->n;
nsep =xyt_handle->info->nsep;
lnsep =xyt_handle->info->lnsep;
fo =xyt_handle->info->fo;
end =lnsep[0];
level =xyt_handle->level;
PCTFS_gs_handle=xyt_handle->mvi->PCTFS_gs_handle;
/* is there a null space? */
/* LATER add in ability to detect null space by checking alpha */
for (i=0, j=0; i<=level; i++) j+=nsep[i];
m = j-xyt_handle->ns;
if (m!=j) {
ierr = PetscPrintf(PETSC_COMM_WORLD,"xyt_generate() :: null space exists %D %D %D\n",m,j,xyt_handle->ns);CHKERRQ(ierr);
}
ierr = PetscInfo2(0,"xyt_generate() :: X(%D,%D)\n",n,m);CHKERRQ(ierr);
/* get and initialize storage for x local */
/* note that x local is nxm and stored by columns */
xcol_sz = (PetscInt*) malloc(m*sizeof(PetscInt));
xcol_indices = (PetscInt*) malloc((2*m+1)*sizeof(PetscInt));
xcol_vals = (PetscScalar**) malloc(m*sizeof(PetscScalar*));
for (i=j=0; i<m; i++, j+=2) {
xcol_indices[j]=xcol_indices[j+1]=xcol_sz[i]=-1;
xcol_vals[i] = NULL;
}
xcol_indices[j]=-1;
/* get and initialize storage for y local */
/* note that y local is nxm and stored by columns */
ycol_sz = (PetscInt*) malloc(m*sizeof(PetscInt));
ycol_indices = (PetscInt*) malloc((2*m+1)*sizeof(PetscInt));
ycol_vals = (PetscScalar**) malloc(m*sizeof(PetscScalar*));
for (i=j=0; i<m; i++, j+=2) {
ycol_indices[j]=ycol_indices[j+1]=ycol_sz[i]=-1;
ycol_vals[i] = NULL;
}
ycol_indices[j]=-1;
/* size of separators for each sub-hc working from bottom of tree to top */
/* this looks like nsep[]=segments */
stages = (PetscInt*) malloc((level+1)*sizeof(PetscInt));
segs = (PetscInt*) malloc((level+1)*sizeof(PetscInt));
PCTFS_ivec_zero(stages,level+1);
PCTFS_ivec_copy(segs,nsep,level+1);
for (i=0; i<level; i++) segs[i+1] += segs[i];
stages[0] = segs[0];
/* temporary vectors */
u = (PetscScalar*) malloc(n*sizeof(PetscScalar));
z = (PetscScalar*) malloc(n*sizeof(PetscScalar));
v = (PetscScalar*) malloc(a_m*sizeof(PetscScalar));
uu = (PetscScalar*) malloc(m*sizeof(PetscScalar));
w = (PetscScalar*) malloc(m*sizeof(PetscScalar));
/* extra nnz due to replication of vertices across separators */
for (i=1, j=0; i<=level; i++) j+=nsep[i];
/* storage for sparse x values */
n_global = xyt_handle->info->n_global;
xt_max_nnz = yt_max_nnz = (PetscInt)(2.5*PetscPowReal(1.0*n_global,1.6667) + j*n/2)/PCTFS_num_nodes;
x = (PetscScalar*) malloc(xt_max_nnz*sizeof(PetscScalar));
y = (PetscScalar*) malloc(yt_max_nnz*sizeof(PetscScalar));
/* LATER - can embed next sep to fire in gs */
/* time to make the donuts - generate X factor */
for (dim=i=j=0; i<m; i++) {
/* time to move to the next level? */
while (i==segs[dim]) {
if (dim==level) SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"dim about to exceed level\n");
stages[dim++]=i;
end +=lnsep[dim];
}
stages[dim]=i;
/* which column are we firing? */
/* i.e. set v_l */
/* use new seps and do global min across hc to determine which one to fire */
(start<end) ? (col=fo[start]) : (col=INT_MAX);
PCTFS_giop_hc(&col,&work,1,op2,dim);
/* shouldn't need this */
if (col==INT_MAX) {
ierr = PetscInfo(0,"hey ... col==INT_MAX??\n");CHKERRQ(ierr);
continue;
}
/* do I own it? I should */
PCTFS_rvec_zero(v,a_m);
if (col==fo[start]) {
start++;
idx=PCTFS_ivec_linear_search(col, a_local2global, a_n);
if (idx!=-1) {
v[idx] = 1.0;
j++;
} else SETERRQ(PETSC_COMM_SELF,PETSC_ERR_PLIB,"NOT FOUND!\n");
} else {
idx=PCTFS_ivec_linear_search(col, a_local2global, a_m);
if (idx!=-1) v[idx] = 1.0;
}
/* perform u = A.v_l */
PCTFS_rvec_zero(u,n);
do_matvec(xyt_handle->mvi,v,u);
/* uu = X^T.u_l (local portion) */
/* technically only need to zero out first i entries */
/* later turn this into an XYT_solve call ? */
PCTFS_rvec_zero(uu,m);
y_ptr=y;
iptr = ycol_indices;
for (k=0; k<i; k++) {
off = *iptr++;
len = *iptr++;
ierr = PetscBLASIntCast(len,&dlen);CHKERRQ(ierr);
PetscStackCall("BLASdot",uu[k] = BLASdot_(&dlen,u+off,&i1,y_ptr,&i1));
y_ptr+=len;
}
/* uu = X^T.u_l (comm portion) */
PCTFS_ssgl_radd (uu, w, dim, stages);
/* z = X.uu */
PCTFS_rvec_zero(z,n);
x_ptr=x;
iptr = xcol_indices;
for (k=0; k<i; k++) {
off = *iptr++;
len = *iptr++;
ierr = PetscBLASIntCast(len,&dlen);CHKERRQ(ierr);
PetscStackCall("BLASaxpy",BLASaxpy_(&dlen,&uu[k],x_ptr,&i1,z+off,&i1));
x_ptr+=len;
}
/* compute v_l = v_l - z */
PCTFS_rvec_zero(v+a_n,a_m-a_n);
ierr = PetscBLASIntCast(n,&dlen);CHKERRQ(ierr);
PetscStackCall("BLASaxpy",BLASaxpy_(&dlen,&dm1,z,&i1,v,&i1));
/* compute u_l = A.v_l */
if (a_n!=a_m) PCTFS_gs_gop_hc(PCTFS_gs_handle,v,"+\0",dim);
PCTFS_rvec_zero(u,n);
do_matvec(xyt_handle->mvi,v,u);
/* compute sqrt(alpha) = sqrt(u_l^T.u_l) - local portion */
ierr = PetscBLASIntCast(n,&dlen);CHKERRQ(ierr);
PetscStackCall("BLASdot",alpha = BLASdot_(&dlen,u,&i1,u,&i1));
/* compute sqrt(alpha) = sqrt(u_l^T.u_l) - comm portion */
PCTFS_grop_hc(&alpha, &alpha_w, 1, op, dim);
alpha = (PetscScalar) PetscSqrtReal((PetscReal)alpha);
/* check for small alpha */
/* LATER use this to detect and determine null space */
if (fabs(alpha)<1.0e-14) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_PLIB,"bad alpha! %g\n",alpha);
/* compute v_l = v_l/sqrt(alpha) */
PCTFS_rvec_scale(v,1.0/alpha,n);
PCTFS_rvec_scale(u,1.0/alpha,n);
/* add newly generated column, v_l, to X */
flag = 1;
off =len=0;
for (k=0; k<n; k++) {
if (v[k]!=0.0) {
len=k;
if (flag) {off=k; flag=0;}
}
}
len -= (off-1);
if (len>0) {
if ((xt_nnz+len)>xt_max_nnz) {
ierr = PetscInfo(0,"increasing space for X by 2x!\n");CHKERRQ(ierr);
xt_max_nnz *= 2;
x_ptr = (PetscScalar*) malloc(xt_max_nnz*sizeof(PetscScalar));
PCTFS_rvec_copy(x_ptr,x,xt_nnz);
free(x);
x = x_ptr;
x_ptr+=xt_nnz;
}
xt_nnz += len;
PCTFS_rvec_copy(x_ptr,v+off,len);
/* keep track of number of zeros */
if (dim) {
for (k=0; k<len; k++) {
if (x_ptr[k]==0.0) xt_zero_nnz++;
}
} else {
for (k=0; k<len; k++) {
if (x_ptr[k]==0.0) xt_zero_nnz_0++;
}
}
xcol_indices[2*i] = off;
xcol_sz[i] = xcol_indices[2*i+1] = len;
xcol_vals[i] = x_ptr;
} else {
xcol_indices[2*i] = 0;
xcol_sz[i] = xcol_indices[2*i+1] = 0;
xcol_vals[i] = x_ptr;
}
/* add newly generated column, u_l, to Y */
flag = 1;
off =len=0;
for (k=0; k<n; k++) {
if (u[k]!=0.0) {
len=k;
if (flag) { off=k; flag=0; }
}
}
len -= (off-1);
if (len>0) {
if ((yt_nnz+len)>yt_max_nnz) {
ierr = PetscInfo(0,"increasing space for Y by 2x!\n");CHKERRQ(ierr);
yt_max_nnz *= 2;
y_ptr = (PetscScalar*) malloc(yt_max_nnz*sizeof(PetscScalar));
PCTFS_rvec_copy(y_ptr,y,yt_nnz);
free(y);
y = y_ptr;
y_ptr+=yt_nnz;
}
yt_nnz += len;
PCTFS_rvec_copy(y_ptr,u+off,len);
/* keep track of number of zeros */
if (dim) {
for (k=0; k<len; k++) {
if (y_ptr[k]==0.0) yt_zero_nnz++;
}
} else {
for (k=0; k<len; k++) {
if (y_ptr[k]==0.0) yt_zero_nnz_0++;
}
}
ycol_indices[2*i] = off;
ycol_sz[i] = ycol_indices[2*i+1] = len;
ycol_vals[i] = y_ptr;
} else {
ycol_indices[2*i] = 0;
ycol_sz[i] = ycol_indices[2*i+1] = 0;
ycol_vals[i] = y_ptr;
}
}
/* close off stages for execution phase */
while (dim!=level) {
stages[dim++]=i;
ierr = PetscInfo2(0,"disconnected!!! dim(%D)!=level(%D)\n",dim,level);CHKERRQ(ierr);
}
stages[dim]=i;
xyt_handle->info->n =xyt_handle->mvi->n;
xyt_handle->info->m =m;
xyt_handle->info->nnz =xt_nnz + yt_nnz;
xyt_handle->info->max_nnz =xt_max_nnz + yt_max_nnz;
xyt_handle->info->msg_buf_sz =stages[level]-stages[0];
xyt_handle->info->solve_uu = (PetscScalar*) malloc(m*sizeof(PetscScalar));
xyt_handle->info->solve_w = (PetscScalar*) malloc(m*sizeof(PetscScalar));
xyt_handle->info->x =x;
xyt_handle->info->xcol_vals =xcol_vals;
xyt_handle->info->xcol_sz =xcol_sz;
xyt_handle->info->xcol_indices=xcol_indices;
xyt_handle->info->stages =stages;
xyt_handle->info->y =y;
xyt_handle->info->ycol_vals =ycol_vals;
xyt_handle->info->ycol_sz =ycol_sz;
xyt_handle->info->ycol_indices=ycol_indices;
free(segs);
free(u);
free(v);
free(uu);
free(z);
free(w);
return(0);
}
static PetscErrorCode KSPSolve_BCGSL(KSP ksp)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL*) ksp->data;
PetscScalar alpha, beta, omega, sigma;
PetscScalar rho0, rho1;
PetscReal kappa0, kappaA, kappa1;
PetscReal ghat;
PetscReal zeta, zeta0, rnmax_computed, rnmax_true, nrm0;
PetscBool bUpdateX;
PetscInt maxit;
PetscInt h, i, j, k, vi, ell;
PetscBLASInt ldMZ,bierr;
PetscScalar utb;
PetscReal max_s, pinv_tol;
PetscErrorCode ierr;
PetscFunctionBegin;
/* set up temporary vectors */
vi = 0;
ell = bcgsl->ell;
bcgsl->vB = ksp->work[vi]; vi++;
bcgsl->vRt = ksp->work[vi]; vi++;
bcgsl->vTm = ksp->work[vi]; vi++;
bcgsl->vvR = ksp->work+vi; vi += ell+1;
bcgsl->vvU = ksp->work+vi; vi += ell+1;
bcgsl->vXr = ksp->work[vi]; vi++;
ierr = PetscBLASIntCast(ell+1,&ldMZ);CHKERRQ(ierr);
/* Prime the iterative solver */
ierr = KSPInitialResidual(ksp, VX, VTM, VB, VVR[0], ksp->vec_rhs);CHKERRQ(ierr);
ierr = VecNorm(VVR[0], NORM_2, &zeta0);CHKERRQ(ierr);
rnmax_computed = zeta0;
rnmax_true = zeta0;
ierr = (*ksp->converged)(ksp, 0, zeta0, &ksp->reason, ksp->cnvP);CHKERRQ(ierr);
if (ksp->reason) {
ierr = PetscObjectAMSTakeAccess((PetscObject)ksp);CHKERRQ(ierr);
ksp->its = 0;
ksp->rnorm = zeta0;
ierr = PetscObjectAMSGrantAccess((PetscObject)ksp);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
ierr = VecSet(VVU[0],0.0);CHKERRQ(ierr);
alpha = 0.;
rho0 = omega = 1;
if (bcgsl->delta>0.0) {
ierr = VecCopy(VX, VXR);CHKERRQ(ierr);
ierr = VecSet(VX,0.0);CHKERRQ(ierr);
ierr = VecCopy(VVR[0], VB);CHKERRQ(ierr);
} else {
ierr = VecCopy(ksp->vec_rhs, VB);CHKERRQ(ierr);
}
/* Life goes on */
ierr = VecCopy(VVR[0], VRT);CHKERRQ(ierr);
zeta = zeta0;
ierr = KSPGetTolerances(ksp, NULL, NULL, NULL, &maxit);CHKERRQ(ierr);
for (k=0; k<maxit; k += bcgsl->ell) {
ksp->its = k;
ksp->rnorm = zeta;
ierr = KSPLogResidualHistory(ksp, zeta);CHKERRQ(ierr);
ierr = KSPMonitor(ksp, ksp->its, zeta);CHKERRQ(ierr);
ierr = (*ksp->converged)(ksp, k, zeta, &ksp->reason, ksp->cnvP);CHKERRQ(ierr);
if (ksp->reason < 0) PetscFunctionReturn(0);
else if (ksp->reason) break;
/* BiCG part */
rho0 = -omega*rho0;
nrm0 = zeta;
for (j=0; j<bcgsl->ell; j++) {
/* rho1 <- r_j' * r_tilde */
ierr = VecDot(VVR[j], VRT, &rho1);CHKERRQ(ierr);
if (rho1 == 0.0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN_BICG;
PetscFunctionReturn(0);
}
beta = alpha*(rho1/rho0);
rho0 = rho1;
for (i=0; i<=j; i++) {
/* u_i <- r_i - beta*u_i */
ierr = VecAYPX(VVU[i], -beta, VVR[i]);CHKERRQ(ierr);
}
/* u_{j+1} <- inv(K)*A*u_j */
ierr = KSP_PCApplyBAorAB(ksp, VVU[j], VVU[j+1], VTM);CHKERRQ(ierr);
ierr = VecDot(VVU[j+1], VRT, &sigma);CHKERRQ(ierr);
if (sigma == 0.0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN_BICG;
PetscFunctionReturn(0);
}
alpha = rho1/sigma;
/* x <- x + alpha*u_0 */
ierr = VecAXPY(VX, alpha, VVU[0]);CHKERRQ(ierr);
for (i=0; i<=j; i++) {
/* r_i <- r_i - alpha*u_{i+1} */
ierr = VecAXPY(VVR[i], -alpha, VVU[i+1]);CHKERRQ(ierr);
}
/* r_{j+1} <- inv(K)*A*r_j */
ierr = KSP_PCApplyBAorAB(ksp, VVR[j], VVR[j+1], VTM);CHKERRQ(ierr);
ierr = VecNorm(VVR[0], NORM_2, &nrm0);CHKERRQ(ierr);
if (bcgsl->delta>0.0) {
if (rnmax_computed<nrm0) rnmax_computed = nrm0;
if (rnmax_true<nrm0) rnmax_true = nrm0;
}
/* NEW: check for early exit */
ierr = (*ksp->converged)(ksp, k+j, nrm0, &ksp->reason, ksp->cnvP);CHKERRQ(ierr);
if (ksp->reason) {
ierr = PetscObjectAMSTakeAccess((PetscObject)ksp);CHKERRQ(ierr);
ksp->its = k+j;
ksp->rnorm = nrm0;
ierr = PetscObjectAMSGrantAccess((PetscObject)ksp);CHKERRQ(ierr);
if (ksp->reason < 0) PetscFunctionReturn(0);
}
}
/* Polynomial part */
for (i = 0; i <= bcgsl->ell; ++i) {
ierr = VecMDot(VVR[i], i+1, VVR, &MZa[i*ldMZ]);CHKERRQ(ierr);
}
/* Symmetrize MZa */
for (i = 0; i <= bcgsl->ell; ++i) {
for (j = i+1; j <= bcgsl->ell; ++j) {
MZa[i*ldMZ+j] = MZa[j*ldMZ+i] = PetscConj(MZa[j*ldMZ+i]);
}
}
/* Copy MZa to MZb */
ierr = PetscMemcpy(MZb,MZa,ldMZ*ldMZ*sizeof(PetscScalar));CHKERRQ(ierr);
if (!bcgsl->bConvex || bcgsl->ell==1) {
PetscBLASInt ione = 1,bell;
ierr = PetscBLASIntCast(bcgsl->ell,&bell);CHKERRQ(ierr);
AY0c[0] = -1;
if (bcgsl->pinv) {
#if defined(PETSC_MISSING_LAPACK_GESVD)
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"GESVD - Lapack routine is unavailable.");
#else
# if defined(PETSC_USE_COMPLEX)
PetscStackCall("LAPACKgesvd",LAPACKgesvd_("A","A",&bell,&bell,&MZa[1+ldMZ],&ldMZ,bcgsl->s,bcgsl->u,&bell,bcgsl->v,&bell,bcgsl->work,&bcgsl->lwork,bcgsl->realwork,&bierr));
# else
PetscStackCall("LAPACKgesvd",LAPACKgesvd_("A","A",&bell,&bell,&MZa[1+ldMZ],&ldMZ,bcgsl->s,bcgsl->u,&bell,bcgsl->v,&bell,bcgsl->work,&bcgsl->lwork,&bierr));
# endif
#endif
if (bierr!=0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
PetscFunctionReturn(0);
}
/* Apply pseudo-inverse */
max_s = bcgsl->s[0];
for (i=1; i<bell; i++) {
if (bcgsl->s[i] > max_s) {
max_s = bcgsl->s[i];
}
}
/* tolerance is hardwired to bell*max(s)*PETSC_MACHINE_EPSILON */
pinv_tol = bell*max_s*PETSC_MACHINE_EPSILON;
ierr = PetscMemzero(&AY0c[1],bell*sizeof(PetscScalar));CHKERRQ(ierr);
for (i=0; i<bell; i++) {
if (bcgsl->s[i] >= pinv_tol) {
utb=0.;
for (j=0; j<bell; j++) {
utb += MZb[1+j]*bcgsl->u[i*bell+j];
}
for (j=0; j<bell; j++) {
AY0c[1+j] += utb/bcgsl->s[i]*bcgsl->v[j*bell+i];
}
}
}
} else {
#if defined(PETSC_MISSING_LAPACK_POTRF)
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"POTRF - Lapack routine is unavailable.");
#else
PetscStackCall("LAPACKpotrf",LAPACKpotrf_("Lower", &bell, &MZa[1+ldMZ], &ldMZ, &bierr));
#endif
if (bierr!=0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
PetscFunctionReturn(0);
}
ierr = PetscMemcpy(&AY0c[1],&MZb[1],bcgsl->ell*sizeof(PetscScalar));CHKERRQ(ierr);
PetscStackCall("LAPACKpotrs",LAPACKpotrs_("Lower", &bell, &ione, &MZa[1+ldMZ], &ldMZ, &AY0c[1], &ldMZ, &bierr));
}
} else {
PetscBLASInt ione = 1;
PetscScalar aone = 1.0, azero = 0.0;
PetscBLASInt neqs;
ierr = PetscBLASIntCast(bcgsl->ell-1,&neqs);CHKERRQ(ierr);
#if defined(PETSC_MISSING_LAPACK_POTRF)
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"POTRF - Lapack routine is unavailable.");
#else
PetscStackCall("LAPACKpotrf",LAPACKpotrf_("Lower", &neqs, &MZa[1+ldMZ], &ldMZ, &bierr));
#endif
if (bierr!=0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
PetscFunctionReturn(0);
}
ierr = PetscMemcpy(&AY0c[1],&MZb[1],(bcgsl->ell-1)*sizeof(PetscScalar));CHKERRQ(ierr);
PetscStackCall("LAPACKpotrs",LAPACKpotrs_("Lower", &neqs, &ione, &MZa[1+ldMZ], &ldMZ, &AY0c[1], &ldMZ, &bierr));
AY0c[0] = -1;
AY0c[bcgsl->ell] = 0.;
ierr = PetscMemcpy(&AYlc[1],&MZb[1+ldMZ*(bcgsl->ell)],(bcgsl->ell-1)*sizeof(PetscScalar));CHKERRQ(ierr);
PetscStackCall("LAPACKpotrs",LAPACKpotrs_("Lower", &neqs, &ione, &MZa[1+ldMZ], &ldMZ, &AYlc[1], &ldMZ, &bierr));
AYlc[0] = 0.;
AYlc[bcgsl->ell] = -1;
PetscStackCall("BLASgemv",BLASgemv_("NoTr", &ldMZ, &ldMZ, &aone, MZb, &ldMZ, AY0c, &ione, &azero, AYtc, &ione));
kappa0 = PetscRealPart(BLASdot_(&ldMZ, AY0c, &ione, AYtc, &ione));
/* round-off can cause negative kappa's */
if (kappa0<0) kappa0 = -kappa0;
kappa0 = PetscSqrtReal(kappa0);
kappaA = PetscRealPart(BLASdot_(&ldMZ, AYlc, &ione, AYtc, &ione));
PetscStackCall("BLASgemv",BLASgemv_("noTr", &ldMZ, &ldMZ, &aone, MZb, &ldMZ, AYlc, &ione, &azero, AYtc, &ione));
kappa1 = PetscRealPart(BLASdot_(&ldMZ, AYlc, &ione, AYtc, &ione));
if (kappa1<0) kappa1 = -kappa1;
kappa1 = PetscSqrtReal(kappa1);
if (kappa0!=0.0 && kappa1!=0.0) {
if (kappaA<0.7*kappa0*kappa1) {
ghat = (kappaA<0.0) ? -0.7*kappa0/kappa1 : 0.7*kappa0/kappa1;
} else {
ghat = kappaA/(kappa1*kappa1);
}
for (i=0; i<=bcgsl->ell; i++) {
AY0c[i] = AY0c[i] - ghat* AYlc[i];
}
}
}
omega = AY0c[bcgsl->ell];
for (h=bcgsl->ell; h>0 && omega==0.0; h--) omega = AY0c[h];
if (omega==0.0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
PetscFunctionReturn(0);
}
ierr = VecMAXPY(VX, bcgsl->ell,AY0c+1, VVR);CHKERRQ(ierr);
for (i=1; i<=bcgsl->ell; i++) AY0c[i] *= -1.0;
ierr = VecMAXPY(VVU[0], bcgsl->ell,AY0c+1, VVU+1);CHKERRQ(ierr);
ierr = VecMAXPY(VVR[0], bcgsl->ell,AY0c+1, VVR+1);CHKERRQ(ierr);
for (i=1; i<=bcgsl->ell; i++) AY0c[i] *= -1.0;
ierr = VecNorm(VVR[0], NORM_2, &zeta);CHKERRQ(ierr);
/* Accurate Update */
if (bcgsl->delta>0.0) {
if (rnmax_computed<zeta) rnmax_computed = zeta;
if (rnmax_true<zeta) rnmax_true = zeta;
bUpdateX = (PetscBool) (zeta<bcgsl->delta*zeta0 && zeta0<=rnmax_computed);
if ((zeta<bcgsl->delta*rnmax_true && zeta0<=rnmax_true) || bUpdateX) {
/* r0 <- b-inv(K)*A*X */
ierr = KSP_PCApplyBAorAB(ksp, VX, VVR[0], VTM);CHKERRQ(ierr);
ierr = VecAYPX(VVR[0], -1.0, VB);CHKERRQ(ierr);
rnmax_true = zeta;
if (bUpdateX) {
ierr = VecAXPY(VXR,1.0,VX);CHKERRQ(ierr);
ierr = VecSet(VX,0.0);CHKERRQ(ierr);
ierr = VecCopy(VVR[0], VB);CHKERRQ(ierr);
rnmax_computed = zeta;
}
}
}
}
if (bcgsl->delta>0.0) {
ierr = VecAXPY(VX,1.0,VXR);CHKERRQ(ierr);
}
ierr = (*ksp->converged)(ksp, k, zeta, &ksp->reason, ksp->cnvP);CHKERRQ(ierr);
if (!ksp->reason) ksp->reason = KSP_DIVERGED_ITS;
PetscFunctionReturn(0);
}
/*
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);
}
PetscErrorCode KSPAGMRESRodvec(KSP ksp, PetscInt nvec, PetscScalar *In, Vec Out)
{
KSP_AGMRES *agmres = (KSP_AGMRES*) ksp->data;
MPI_Comm comm;
PetscScalar *Qloc = agmres->Qloc;
PetscScalar *sgn = agmres->sgn;
PetscScalar *tloc = agmres->tloc;
PetscMPIInt rank = agmres->rank;
PetscMPIInt First = agmres->First, Last = agmres->Last;
PetscMPIInt Iright = agmres->Iright, Ileft = agmres->Ileft;
PetscScalar *y, *zloc;
PetscErrorCode ierr;
PetscInt nloc,tag,d, len, i, j;
PetscInt dpt,pas;
PetscReal c, s, rho, zp, zq, yd, tt;
MPI_Status status;
PetscFunctionBegin;
ierr = PetscObjectGetComm((PetscObject)ksp,&comm);CHKERRQ(ierr);
tag = 0x666;
pas = 1;
ierr = VecGetLocalSize(VEC_V(0), &nloc);CHKERRQ(ierr);
ierr = PetscMalloc1(nvec, &y);CHKERRQ(ierr);
ierr = PetscMemcpy(y, In, nvec*sizeof(PetscScalar));CHKERRQ(ierr);
ierr = VecGetArray(Out, &zloc);CHKERRQ(ierr);
if (rank == Last) {
for (i = 0; i < nvec; i++) y[i] = sgn[i] * y[i];
}
for (i = 0; i < nloc; i++) zloc[i] = 0.0;
if (agmres->size == 1) PetscStackCallBLAS("BLAScopy",BLAScopy_(&nvec, y, &pas, &(zloc[0]), &pas));
else {
for (d = nvec - 1; d >= 0; d--) {
if (rank == First) {
ierr = MPI_Recv(&(zloc[d]), 1, MPIU_SCALAR, Iright, tag, comm, &status);CHKERRQ(ierr);
} else {
for (j = nvec - 1; j >= d + 1; j--) {
i = j - d;
ierr = KSPAGMRESRoddecGivens(&c, &s, &(Qloc[j * nloc + i]), 0);
zp = zloc[i-1];
zq = zloc[i];
zloc[i-1] = c * zp + s * zq;
zloc[i] = -s * zp + c * zq;
}
ierr = KSPAGMRESRoddecGivens(&c, &s, &(Qloc[d * nloc]), 0);
if (rank == Last) {
zp = y[d];
zq = zloc[0];
y[d] = c * zp + s * zq;
zloc[0] = -s * zp + c * zq;
ierr = MPI_Send(&(y[d]), 1, MPIU_SCALAR, Ileft, tag, comm);CHKERRQ(ierr);
} else {
ierr = MPI_Recv(&yd, 1, MPIU_SCALAR, Iright, tag, comm, &status);CHKERRQ(ierr);
zp = yd;
zq = zloc[0];
yd = c * zp + s * zq;
zloc[0] = -s * zp + c * zq;
ierr = MPI_Send(&yd, 1, MPIU_SCALAR, Ileft, tag, comm);CHKERRQ(ierr);
}
}
}
}
for (j = nvec - 1; j >= 0; j--) {
dpt = j * nloc + j;
if (tloc[j] != 0.0) {
len = nloc - j;
rho = Qloc[dpt];
Qloc[dpt] = 1.0;
tt = tloc[j] * (BLASdot_(&len, &(Qloc[dpt]), &pas, &(zloc[j]), &pas));
PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&len, &tt, &(Qloc[dpt]), &pas, &(zloc[j]), &pas));
Qloc[dpt] = rho;
}
}
ierr = VecRestoreArray(Out, &zloc);CHKERRQ(ierr);
ierr = PetscFree(y);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode KSPAGMRESRoddec(KSP ksp, PetscInt nvec)
{
KSP_AGMRES *agmres = (KSP_AGMRES*) ksp->data;
MPI_Comm comm;
PetscScalar *Qloc = agmres->Qloc;
PetscScalar *sgn = agmres->sgn;
PetscScalar *tloc = agmres->tloc;
PetscErrorCode ierr;
PetscReal *wbufptr = agmres->wbufptr;
PetscMPIInt rank = agmres->rank;
PetscMPIInt First = agmres->First;
PetscMPIInt Last = agmres->Last;
PetscBLASInt nloc,pas,len;
PetscInt d, i, j, k;
PetscInt pos,tag;
PetscReal c, s, rho, Ajj, val, tt, old;
PetscScalar *col;
MPI_Status status;
PetscBLASInt N = MAXKSPSIZE + 1;
PetscFunctionBegin;
ierr = PetscObjectGetComm((PetscObject)ksp,&comm);CHKERRQ(ierr);
tag = 0x666;
ierr = PetscLogEventBegin(KSP_AGMRESRoddec,ksp,0,0,0);CHKERRQ(ierr);
ierr = PetscMemzero(agmres->Rloc, N*N*sizeof(PetscScalar));CHKERRQ(ierr);
/* check input arguments */
if (nvec < 1) SETERRQ(PetscObjectComm((PetscObject)ksp),PETSC_ERR_ARG_OUTOFRANGE, "The number of input vectors shoud be positive");
ierr = VecGetLocalSize(VEC_V(0), &nloc);CHKERRQ(ierr);
if (nvec > nloc) SETERRQ(PetscObjectComm((PetscObject)ksp), PETSC_ERR_ARG_WRONG, "In QR factorization, the number of local rows should be greater or equal to the number of columns");
pas = 1;
k = 0;
/* Copy the vectors of the basis */
for (j = 0; j < nvec; j++) {
ierr = VecGetArray(VEC_V(j), &col);CHKERRQ(ierr);
PetscStackCallBLAS("BLAScopy",BLAScopy_(&nloc, col, &pas, &Qloc[j*nloc], &pas));
ierr = VecRestoreArray(VEC_V(j), &col);CHKERRQ(ierr);
}
/* Each process performs a local QR on its own block */
for (j = 0; j < nvec; j++) {
len = nloc - j;
Ajj = Qloc[j*nloc+j];
rho = -PetscSign(Ajj) * BLASnrm2_(&len, &(Qloc[j*nloc+j]), &pas);
if (rho == 0.0) tloc[j] = 0.0;
else {
tloc[j] = (Ajj - rho) / rho;
len = len - 1;
val = 1.0 / (Ajj - rho);
PetscStackCallBLAS("BLASscal",BLASscal_(&len, &val, &(Qloc[j*nloc+j+1]), &pas));
Qloc[j*nloc+j] = 1.0;
len = len + 1;
for (k = j + 1; k < nvec; k++) {
PetscStackCallBLAS("BLASdot",tt = tloc[j] * BLASdot_(&len, &(Qloc[j*nloc+j]), &pas, &(Qloc[k*nloc+j]), &pas));
PetscStackCallBLAS("BLASaxpy",BLASaxpy_(&len, &tt, &(Qloc[j*nloc+j]), &pas, &(Qloc[k*nloc+j]), &pas));
}
Qloc[j*nloc+j] = rho;
}
}
/*annihilate undesirable Rloc, diagonal by diagonal*/
for (d = 0; d < nvec; d++) {
len = nvec - d;
if (rank == First) {
PetscStackCallBLAS("BLAScopy",BLAScopy_(&len, &(Qloc[d*nloc+d]), &nloc, &(wbufptr[d]), &pas));
ierr = MPI_Send(&(wbufptr[d]), len, MPIU_SCALAR, rank + 1, tag, comm);CHKERRQ(ierr);
} else {
ierr = MPI_Recv(&(wbufptr[d]), len, MPIU_SCALAR, rank - 1, tag, comm, &status);CHKERRQ(ierr);
/*Elimination of Rloc(1,d)*/
c = wbufptr[d];
s = Qloc[d*nloc];
ierr = KSPAGMRESRoddecGivens(&c, &s, &rho, 1);
/*Apply Givens Rotation*/
for (k = d; k < nvec; k++) {
old = wbufptr[k];
wbufptr[k] = c * old - s * Qloc[k*nloc];
Qloc[k*nloc] = s * old + c * Qloc[k*nloc];
}
Qloc[d*nloc] = rho;
if (rank != Last) {
ierr = MPI_Send(& (wbufptr[d]), len, MPIU_SCALAR, rank + 1, tag, comm);CHKERRQ(ierr);
}
/* zero-out the d-th diagonal of Rloc ...*/
for (j = d + 1; j < nvec; j++) {
/* elimination of Rloc[i][j]*/
i = j - d;
c = Qloc[j*nloc+i-1];
s = Qloc[j*nloc+i];
ierr = KSPAGMRESRoddecGivens(&c, &s, &rho, 1);CHKERRQ(ierr);
for (k = j; k < nvec; k++) {
old = Qloc[k*nloc+i-1];
Qloc[k*nloc+i-1] = c * old - s * Qloc[k*nloc+i];
Qloc[k*nloc+i] = s * old + c * Qloc[k*nloc+i];
}
Qloc[j*nloc+i] = rho;
}
if (rank == Last) {
PetscStackCallBLAS("BLAScopy",BLAScopy_(&len, &(wbufptr[d]), &pas, RLOC(d,d), &N));
for (k = d + 1; k < nvec; k++) *RLOC(k,d) = 0.0;
}
}
}
if (rank == Last) {
for (d = 0; d < nvec; d++) {
pos = nvec - d;
sgn[d] = PetscSign(*RLOC(d,d));
PetscStackCallBLAS("BLASscal",BLASscal_(&pos, &(sgn[d]), RLOC(d,d), &N));
}
}
/*BroadCast Rloc to all other processes
* NWD : should not be needed
*/
ierr = MPI_Bcast(agmres->Rloc,N*N,MPIU_SCALAR,Last,comm);CHKERRQ(ierr);
ierr = PetscLogEventEnd(KSP_AGMRESRoddec,ksp,0,0,0);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
static PetscErrorCode KSPSolve_BCGSL(KSP ksp)
{
KSP_BCGSL *bcgsl = (KSP_BCGSL *) ksp->data;
PetscScalar alpha, beta, omega, sigma;
PetscScalar rho0, rho1;
PetscReal kappa0, kappaA, kappa1;
PetscReal ghat, epsilon, abstol;
PetscReal zeta, zeta0, rnmax_computed, rnmax_true, nrm0;
PetscTruth bUpdateX;
PetscTruth bBombed = PETSC_FALSE;
PetscInt maxit;
PetscInt h, i, j, k, vi, ell;
PetscBLASInt ldMZ,bierr;
PetscErrorCode ierr;
PetscFunctionBegin;
if (ksp->normtype == KSP_NORM_NATURAL) SETERRQ(PETSC_ERR_SUP,"Cannot use natural norm with KSPBCGSL");
if (ksp->normtype == KSP_NORM_PRECONDITIONED && ksp->pc_side != PC_LEFT) SETERRQ(PETSC_ERR_SUP,"Use -ksp_norm_type unpreconditioned for right preconditioning and KSPBCGSL");
if (ksp->normtype == KSP_NORM_UNPRECONDITIONED && ksp->pc_side != PC_RIGHT) SETERRQ(PETSC_ERR_SUP,"Use -ksp_norm_type preconditioned for left preconditioning and KSPBCGSL");
/* set up temporary vectors */
vi = 0;
ell = bcgsl->ell;
bcgsl->vB = ksp->work[vi];
vi++;
bcgsl->vRt = ksp->work[vi];
vi++;
bcgsl->vTm = ksp->work[vi];
vi++;
bcgsl->vvR = ksp->work+vi;
vi += ell+1;
bcgsl->vvU = ksp->work+vi;
vi += ell+1;
bcgsl->vXr = ksp->work[vi];
vi++;
ldMZ = PetscBLASIntCast(ell+1);
/* Prime the iterative solver */
ierr = KSPInitialResidual(ksp, VX, VTM, VB, VVR[0], ksp->vec_rhs);
CHKERRQ(ierr);
ierr = VecNorm(VVR[0], NORM_2, &zeta0);
CHKERRQ(ierr);
rnmax_computed = zeta0;
rnmax_true = zeta0;
ierr = (*ksp->converged)(ksp, 0, zeta0, &ksp->reason, ksp->cnvP);
CHKERRQ(ierr);
if (ksp->reason) {
ierr = PetscObjectTakeAccess(ksp);
CHKERRQ(ierr);
ksp->its = 0;
ksp->rnorm = zeta0;
ierr = PetscObjectGrantAccess(ksp);
CHKERRQ(ierr);
PetscFunctionReturn(0);
}
ierr = VecSet(VVU[0],0.0);
CHKERRQ(ierr);
alpha = 0.;
rho0 = omega = 1;
if (bcgsl->delta>0.0) {
ierr = VecCopy(VX, VXR);
CHKERRQ(ierr);
ierr = VecSet(VX,0.0);
CHKERRQ(ierr);
ierr = VecCopy(VVR[0], VB);
CHKERRQ(ierr);
} else {
ierr = VecCopy(ksp->vec_rhs, VB);
CHKERRQ(ierr);
}
/* Life goes on */
ierr = VecCopy(VVR[0], VRT);
CHKERRQ(ierr);
zeta = zeta0;
ierr = KSPGetTolerances(ksp, &epsilon, &abstol, PETSC_NULL, &maxit);
CHKERRQ(ierr);
for (k=0; k<maxit; k += bcgsl->ell) {
ksp->its = k;
ksp->rnorm = zeta;
KSPLogResidualHistory(ksp, zeta);
KSPMonitor(ksp, ksp->its, zeta);
ierr = (*ksp->converged)(ksp, k, zeta, &ksp->reason, ksp->cnvP);
CHKERRQ(ierr);
if (ksp->reason) break;
/* BiCG part */
rho0 = -omega*rho0;
nrm0 = zeta;
for (j=0; j<bcgsl->ell; j++) {
/* rho1 <- r_j' * r_tilde */
ierr = VecDot(VVR[j], VRT, &rho1);
CHKERRQ(ierr);
if (rho1 == 0.0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN_BICG;
bBombed = PETSC_TRUE;
break;
}
beta = alpha*(rho1/rho0);
rho0 = rho1;
for (i=0; i<=j; i++) {
/* u_i <- r_i - beta*u_i */
ierr = VecAYPX(VVU[i], -beta, VVR[i]);
CHKERRQ(ierr);
}
/* u_{j+1} <- inv(K)*A*u_j */
ierr = KSP_PCApplyBAorAB(ksp, VVU[j], VVU[j+1], VTM);
CHKERRQ(ierr);
ierr = VecDot(VVU[j+1], VRT, &sigma);
CHKERRQ(ierr);
if (sigma == 0.0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN_BICG;
bBombed = PETSC_TRUE;
break;
}
alpha = rho1/sigma;
/* x <- x + alpha*u_0 */
ierr = VecAXPY(VX, alpha, VVU[0]);
CHKERRQ(ierr);
for (i=0; i<=j; i++) {
/* r_i <- r_i - alpha*u_{i+1} */
ierr = VecAXPY(VVR[i], -alpha, VVU[i+1]);
CHKERRQ(ierr);
}
/* r_{j+1} <- inv(K)*A*r_j */
ierr = KSP_PCApplyBAorAB(ksp, VVR[j], VVR[j+1], VTM);
CHKERRQ(ierr);
ierr = VecNorm(VVR[0], NORM_2, &nrm0);
CHKERRQ(ierr);
if (bcgsl->delta>0.0) {
if (rnmax_computed<nrm0) rnmax_computed = nrm0;
if (rnmax_true<nrm0) rnmax_true = nrm0;
}
/* NEW: check for early exit */
ierr = (*ksp->converged)(ksp, k+j, nrm0, &ksp->reason, ksp->cnvP);
CHKERRQ(ierr);
if (ksp->reason) {
ierr = PetscObjectTakeAccess(ksp);
CHKERRQ(ierr);
ksp->its = k+j;
ksp->rnorm = nrm0;
ierr = PetscObjectGrantAccess(ksp);
CHKERRQ(ierr);
break;
}
}
if (bBombed==PETSC_TRUE) break;
/* Polynomial part */
for(i = 0; i <= bcgsl->ell; ++i) {
ierr = VecMDot(VVR[i], i+1, VVR, &MZa[i*ldMZ]);
CHKERRQ(ierr);
}
/* Symmetrize MZa */
for(i = 0; i <= bcgsl->ell; ++i) {
for(j = i+1; j <= bcgsl->ell; ++j) {
MZa[i*ldMZ+j] = MZa[j*ldMZ+i] = PetscConj(MZa[j*ldMZ+i]);
}
}
/* Copy MZa to MZb */
ierr = PetscMemcpy(MZb,MZa,ldMZ*ldMZ*sizeof(PetscScalar));
CHKERRQ(ierr);
if (!bcgsl->bConvex || bcgsl->ell==1) {
PetscBLASInt ione = 1,bell = PetscBLASIntCast(bcgsl->ell);
AY0c[0] = -1;
LAPACKpotrf_("Lower", &bell, &MZa[1+ldMZ], &ldMZ, &bierr);
if (ierr!=0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
bBombed = PETSC_TRUE;
break;
}
ierr = PetscMemcpy(&AY0c[1],&MZb[1],bcgsl->ell*sizeof(PetscScalar));
CHKERRQ(ierr);
LAPACKpotrs_("Lower", &bell, &ione, &MZa[1+ldMZ], &ldMZ, &AY0c[1], &ldMZ, &bierr);
} else {
PetscBLASInt ione = 1;
PetscScalar aone = 1.0, azero = 0.0;
PetscBLASInt neqs = PetscBLASIntCast(bcgsl->ell-1);
LAPACKpotrf_("Lower", &neqs, &MZa[1+ldMZ], &ldMZ, &bierr);
if (ierr!=0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
bBombed = PETSC_TRUE;
break;
}
ierr = PetscMemcpy(&AY0c[1],&MZb[1],(bcgsl->ell-1)*sizeof(PetscScalar));
CHKERRQ(ierr);
LAPACKpotrs_("Lower", &neqs, &ione, &MZa[1+ldMZ], &ldMZ, &AY0c[1], &ldMZ, &bierr);
AY0c[0] = -1;
AY0c[bcgsl->ell] = 0.;
ierr = PetscMemcpy(&AYlc[1],&MZb[1+ldMZ*(bcgsl->ell)],(bcgsl->ell-1)*sizeof(PetscScalar));
CHKERRQ(ierr);
LAPACKpotrs_("Lower", &neqs, &ione, &MZa[1+ldMZ], &ldMZ, &AYlc[1], &ldMZ, &bierr);
AYlc[0] = 0.;
AYlc[bcgsl->ell] = -1;
BLASgemv_("NoTr", &ldMZ, &ldMZ, &aone, MZb, &ldMZ, AY0c, &ione, &azero, AYtc, &ione);
kappa0 = BLASdot_(&ldMZ, AY0c, &ione, AYtc, &ione);
/* round-off can cause negative kappa's */
if (kappa0<0) kappa0 = -kappa0;
kappa0 = sqrt(kappa0);
kappaA = BLASdot_(&ldMZ, AYlc, &ione, AYtc, &ione);
BLASgemv_("noTr", &ldMZ, &ldMZ, &aone, MZb, &ldMZ, AYlc, &ione, &azero, AYtc, &ione);
kappa1 = BLASdot_(&ldMZ, AYlc, &ione, AYtc, &ione);
if (kappa1<0) kappa1 = -kappa1;
kappa1 = sqrt(kappa1);
if (kappa0!=0.0 && kappa1!=0.0) {
if (kappaA<0.7*kappa0*kappa1) {
ghat = (kappaA<0.0) ? -0.7*kappa0/kappa1 : 0.7*kappa0/kappa1;
} else {
ghat = kappaA/(kappa1*kappa1);
}
for (i=0; i<=bcgsl->ell; i++) {
AY0c[i] = AY0c[i] - ghat* AYlc[i];
}
}
}
omega = AY0c[bcgsl->ell];
for (h=bcgsl->ell; h>0 && omega==0.0; h--) {
omega = AY0c[h];
}
if (omega==0.0) {
ksp->reason = KSP_DIVERGED_BREAKDOWN;
break;
}
ierr = VecMAXPY(VX, bcgsl->ell,AY0c+1, VVR);
CHKERRQ(ierr);
for (i=1; i<=bcgsl->ell; i++) {
AY0c[i] *= -1.0;
}
ierr = VecMAXPY(VVU[0], bcgsl->ell,AY0c+1, VVU+1);
CHKERRQ(ierr);
ierr = VecMAXPY(VVR[0], bcgsl->ell,AY0c+1, VVR+1);
CHKERRQ(ierr);
for (i=1; i<=bcgsl->ell; i++) {
AY0c[i] *= -1.0;
}
ierr = VecNorm(VVR[0], NORM_2, &zeta);
CHKERRQ(ierr);
/* Accurate Update */
if (bcgsl->delta>0.0) {
if (rnmax_computed<zeta) rnmax_computed = zeta;
if (rnmax_true<zeta) rnmax_true = zeta;
bUpdateX = (PetscTruth) (zeta<bcgsl->delta*zeta0 && zeta0<=rnmax_computed);
if ((zeta<bcgsl->delta*rnmax_true && zeta0<=rnmax_true) || bUpdateX) {
/* r0 <- b-inv(K)*A*X */
ierr = KSP_PCApplyBAorAB(ksp, VX, VVR[0], VTM);
CHKERRQ(ierr);
ierr = VecAYPX(VVR[0], -1.0, VB);
CHKERRQ(ierr);
rnmax_true = zeta;
if (bUpdateX) {
ierr = VecAXPY(VXR,1.0,VX);
CHKERRQ(ierr);
ierr = VecSet(VX,0.0);
CHKERRQ(ierr);
ierr = VecCopy(VVR[0], VB);
CHKERRQ(ierr);
rnmax_computed = zeta;
}
}
}
}
if (bcgsl->delta>0.0) {
ierr = VecAXPY(VX,1.0,VXR);
CHKERRQ(ierr);
}
ierr = (*ksp->converged)(ksp, k, zeta, &ksp->reason, ksp->cnvP);
CHKERRQ(ierr);
if (!ksp->reason) ksp->reason = KSP_DIVERGED_ITS;
PetscFunctionReturn(0);
}
