PetscErrorCode EPSSolve_Lanczos(EPS eps)
{
EPS_LANCZOS *lanczos = (EPS_LANCZOS*)eps->data;
PetscErrorCode ierr;
PetscInt nconv,i,j,k,l,x,n,*perm,restart,ncv=eps->ncv,r,ld;
Vec vi,vj,w;
Mat U;
PetscScalar *Y,*ritz,stmp;
PetscReal *d,*e,*bnd,anorm,beta,norm,rtmp,resnorm;
PetscBool breakdown;
char *conv,ctmp;
PetscFunctionBegin;
ierr = DSGetLeadingDimension(eps->ds,&ld);CHKERRQ(ierr);
ierr = PetscMalloc4(ncv,&ritz,ncv,&bnd,ncv,&perm,ncv,&conv);CHKERRQ(ierr);
/* The first Lanczos vector is the normalized initial vector */
ierr = EPSGetStartVector(eps,0,NULL);CHKERRQ(ierr);
anorm = -1.0;
nconv = 0;
/* Restart loop */
while (eps->reason == EPS_CONVERGED_ITERATING) {
eps->its++;
/* Compute an ncv-step Lanczos factorization */
n = PetscMin(nconv+eps->mpd,ncv);
ierr = DSGetArrayReal(eps->ds,DS_MAT_T,&d);CHKERRQ(ierr);
e = d + ld;
ierr = EPSBasicLanczos(eps,d,e,nconv,&n,&breakdown,anorm);CHKERRQ(ierr);
beta = e[n-1];
ierr = DSRestoreArrayReal(eps->ds,DS_MAT_T,&d);CHKERRQ(ierr);
ierr = DSSetDimensions(eps->ds,n,0,nconv,0);CHKERRQ(ierr);
ierr = DSSetState(eps->ds,DS_STATE_INTERMEDIATE);CHKERRQ(ierr);
ierr = BVSetActiveColumns(eps->V,nconv,n);CHKERRQ(ierr);
/* Solve projected problem */
ierr = DSSolve(eps->ds,ritz,NULL);CHKERRQ(ierr);
ierr = DSSort(eps->ds,ritz,NULL,NULL,NULL,NULL);CHKERRQ(ierr);
/* Estimate ||A|| */
for (i=nconv;i<n;i++)
anorm = PetscMax(anorm,PetscAbsReal(PetscRealPart(ritz[i])));
/* Compute residual norm estimates as beta*abs(Y(m,:)) + eps*||A|| */
ierr = DSGetArray(eps->ds,DS_MAT_Q,&Y);CHKERRQ(ierr);
for (i=nconv;i<n;i++) {
resnorm = beta*PetscAbsScalar(Y[n-1+i*ld]) + PETSC_MACHINE_EPSILON*anorm;
ierr = (*eps->converged)(eps,ritz[i],eps->eigi[i],resnorm,&bnd[i],eps->convergedctx);CHKERRQ(ierr);
if (bnd[i]<eps->tol) conv[i] = 'C';
else conv[i] = 'N';
}
ierr = DSRestoreArray(eps->ds,DS_MAT_Q,&Y);CHKERRQ(ierr);
/* purge repeated ritz values */
if (lanczos->reorthog == EPS_LANCZOS_REORTHOG_LOCAL) {
for (i=nconv+1;i<n;i++) {
if (conv[i] == 'C' && PetscAbsScalar((ritz[i]-ritz[i-1])/ritz[i]) < eps->tol) conv[i] = 'R';
}
}
/* Compute restart vector */
if (breakdown) {
ierr = PetscInfo2(eps,"Breakdown in Lanczos method (it=%D norm=%g)\n",eps->its,(double)beta);CHKERRQ(ierr);
} else {
restart = nconv;
while (restart<n && conv[restart] != 'N') restart++;
if (restart >= n) {
breakdown = PETSC_TRUE;
} else {
for (i=restart+1;i<n;i++) {
if (conv[i] == 'N') {
ierr = SlepcSCCompare(eps->sc,ritz[restart],0.0,ritz[i],0.0,&r);CHKERRQ(ierr);
if (r>0) restart = i;
}
}
ierr = DSGetArray(eps->ds,DS_MAT_Q,&Y);CHKERRQ(ierr);
ierr = BVMultColumn(eps->V,1.0,0.0,n,Y+restart*ld+nconv);CHKERRQ(ierr);
ierr = DSRestoreArray(eps->ds,DS_MAT_Q,&Y);CHKERRQ(ierr);
}
}
/* Count and put converged eigenvalues first */
for (i=nconv;i<n;i++) perm[i] = i;
for (k=nconv;k<n;k++) {
if (conv[perm[k]] != 'C') {
j = k + 1;
while (j<n && conv[perm[j]] != 'C') j++;
if (j>=n) break;
l = perm[k]; perm[k] = perm[j]; perm[j] = l;
}
}
/* Sort eigenvectors according to permutation */
ierr = DSGetArray(eps->ds,DS_MAT_Q,&Y);CHKERRQ(ierr);
for (i=nconv;i<k;i++) {
x = perm[i];
if (x != i) {
j = i + 1;
while (perm[j] != i) j++;
/* swap eigenvalues i and j */
stmp = ritz[x]; ritz[x] = ritz[i]; ritz[i] = stmp;
rtmp = bnd[x]; bnd[x] = bnd[i]; bnd[i] = rtmp;
ctmp = conv[x]; conv[x] = conv[i]; conv[i] = ctmp;
perm[j] = x; perm[i] = i;
/* swap eigenvectors i and j */
for (l=0;l<n;l++) {
stmp = Y[l+x*ld]; Y[l+x*ld] = Y[l+i*ld]; Y[l+i*ld] = stmp;
}
}
}
ierr = DSRestoreArray(eps->ds,DS_MAT_Q,&Y);CHKERRQ(ierr);
/* compute converged eigenvectors */
ierr = DSGetMat(eps->ds,DS_MAT_Q,&U);CHKERRQ(ierr);
ierr = BVMultInPlace(eps->V,U,nconv,k);CHKERRQ(ierr);
ierr = MatDestroy(&U);CHKERRQ(ierr);
/* purge spurious ritz values */
if (lanczos->reorthog == EPS_LANCZOS_REORTHOG_LOCAL) {
for (i=nconv;i<k;i++) {
ierr = BVGetColumn(eps->V,i,&vi);CHKERRQ(ierr);
ierr = VecNorm(vi,NORM_2,&norm);CHKERRQ(ierr);
ierr = VecScale(vi,1.0/norm);CHKERRQ(ierr);
w = eps->work[0];
ierr = STApply(eps->st,vi,w);CHKERRQ(ierr);
ierr = VecAXPY(w,-ritz[i],vi);CHKERRQ(ierr);
ierr = BVRestoreColumn(eps->V,i,&vi);CHKERRQ(ierr);
ierr = VecNorm(w,NORM_2,&norm);CHKERRQ(ierr);
ierr = (*eps->converged)(eps,ritz[i],eps->eigi[i],norm,&bnd[i],eps->convergedctx);CHKERRQ(ierr);
if (bnd[i]>=eps->tol) conv[i] = 'S';
}
for (i=nconv;i<k;i++) {
if (conv[i] != 'C') {
j = i + 1;
while (j<k && conv[j] != 'C') j++;
if (j>=k) break;
/* swap eigenvalues i and j */
stmp = ritz[j]; ritz[j] = ritz[i]; ritz[i] = stmp;
rtmp = bnd[j]; bnd[j] = bnd[i]; bnd[i] = rtmp;
ctmp = conv[j]; conv[j] = conv[i]; conv[i] = ctmp;
/* swap eigenvectors i and j */
ierr = BVGetColumn(eps->V,i,&vi);CHKERRQ(ierr);
ierr = BVGetColumn(eps->V,j,&vj);CHKERRQ(ierr);
ierr = VecSwap(vi,vj);CHKERRQ(ierr);
ierr = BVRestoreColumn(eps->V,i,&vi);CHKERRQ(ierr);
ierr = BVRestoreColumn(eps->V,j,&vj);CHKERRQ(ierr);
}
}
k = i;
}
/* store ritz values and estimated errors */
for (i=nconv;i<n;i++) {
eps->eigr[i] = ritz[i];
eps->errest[i] = bnd[i];
}
ierr = EPSMonitor(eps,eps->its,nconv,eps->eigr,eps->eigi,eps->errest,n);CHKERRQ(ierr);
nconv = k;
if (eps->its >= eps->max_it) eps->reason = EPS_DIVERGED_ITS;
if (nconv >= eps->nev) eps->reason = EPS_CONVERGED_TOL;
if (eps->reason == EPS_CONVERGED_ITERATING) { /* copy restart vector */
ierr = BVCopyColumn(eps->V,n,nconv);CHKERRQ(ierr);
if (lanczos->reorthog == EPS_LANCZOS_REORTHOG_LOCAL && !breakdown) {
/* Reorthonormalize restart vector */
ierr = BVOrthogonalizeColumn(eps->V,nconv,NULL,&norm,&breakdown);CHKERRQ(ierr);
ierr = BVScaleColumn(eps->V,nconv,1.0/norm);CHKERRQ(ierr);
}
if (breakdown) {
/* Use random vector for restarting */
ierr = PetscInfo(eps,"Using random vector for restart\n");CHKERRQ(ierr);
ierr = EPSGetStartVector(eps,nconv,&breakdown);CHKERRQ(ierr);
}
if (breakdown) { /* give up */
eps->reason = EPS_DIVERGED_BREAKDOWN;
ierr = PetscInfo(eps,"Unable to generate more start vectors\n");CHKERRQ(ierr);
}
}
}
eps->nconv = nconv;
ierr = PetscFree4(ritz,bnd,perm,conv);CHKERRQ(ierr);
PetscFunctionReturn(0);
}
PetscErrorCode DSSort_NHEP_Total(DS ds,PetscScalar *wr,PetscScalar *wi)
{
#if defined(SLEPC_MISSING_LAPACK_TREXC)
PetscFunctionBegin;
SETERRQ(PETSC_COMM_SELF,PETSC_ERR_SUP,"TREXC - Lapack routine is unavailable");
#else
PetscErrorCode ierr;
PetscScalar re;
PetscInt i,j,pos,result;
PetscBLASInt ifst,ilst,info,n,ld;
PetscScalar *T = ds->mat[DS_MAT_A];
PetscScalar *Q = ds->mat[DS_MAT_Q];
#if !defined(PETSC_USE_COMPLEX)
PetscScalar *work,im;
#endif
PetscFunctionBegin;
ierr = PetscBLASIntCast(ds->n,&n);CHKERRQ(ierr);
ierr = PetscBLASIntCast(ds->ld,&ld);CHKERRQ(ierr);
#if !defined(PETSC_USE_COMPLEX)
ierr = DSAllocateWork_Private(ds,ld,0,0);CHKERRQ(ierr);
work = ds->work;
#endif
/* selection sort */
for (i=ds->l;i<n-1;i++) {
re = wr[i];
#if !defined(PETSC_USE_COMPLEX)
im = wi[i];
#endif
pos = 0;
j=i+1; /* j points to the next eigenvalue */
#if !defined(PETSC_USE_COMPLEX)
if (im != 0) j=i+2;
#endif
/* find minimum eigenvalue */
for (;j<n;j++) {
#if !defined(PETSC_USE_COMPLEX)
ierr = SlepcSCCompare(ds->sc,re,im,wr[j],wi[j],&result);CHKERRQ(ierr);
#else
ierr = SlepcSCCompare(ds->sc,re,0.0,wr[j],0.0,&result);CHKERRQ(ierr);
#endif
if (result > 0) {
re = wr[j];
#if !defined(PETSC_USE_COMPLEX)
im = wi[j];
#endif
pos = j;
}
#if !defined(PETSC_USE_COMPLEX)
if (wi[j] != 0) j++;
#endif
}
if (pos) {
/* interchange blocks */
ierr = PetscBLASIntCast(pos+1,&ifst);CHKERRQ(ierr);
ierr = PetscBLASIntCast(i+1,&ilst);CHKERRQ(ierr);
#if !defined(PETSC_USE_COMPLEX)
PetscStackCallBLAS("LAPACKtrexc",LAPACKtrexc_("V",&n,T,&ld,Q,&ld,&ifst,&ilst,work,&info));
#else
PetscStackCallBLAS("LAPACKtrexc",LAPACKtrexc_("V",&n,T,&ld,Q,&ld,&ifst,&ilst,&info));
#endif
if (info) SETERRQ1(PETSC_COMM_SELF,PETSC_ERR_LIB,"Error in Lapack xTREXC %d",info);
/* recover original eigenvalues from T matrix */
for (j=i;j<n;j++) {
wr[j] = T[j+j*ld];
#if !defined(PETSC_USE_COMPLEX)
if (j<n-1 && T[j+1+j*ld] != 0.0) {
/* complex conjugate eigenvalue */
wi[j] = PetscSqrtReal(PetscAbsReal(T[j+1+j*ld])) *
PetscSqrtReal(PetscAbsReal(T[j+(j+1)*ld]));
wr[j+1] = wr[j];
wi[j+1] = -wi[j];
j++;
} else {
wi[j] = 0.0;
}
#endif
}
}
#if !defined(PETSC_USE_COMPLEX)
if (wi[i] != 0) i++;
#endif
}
PetscFunctionReturn(0);
#endif
}
