int
aprod_ (
long *lnvtxs,
double *x,
double *y,
double *dA,
double *vwsqrt,
double *work,
double *dorthlist /* vectors to orthogonalize against */
)
{
int nvtxs; /* int copy of long_nvtxs */
struct vtx_data **A;
struct orthlink *orthlist; /* vectors to orthogonalize against */
void splarax(), orthog1(), orthogvec(), orthogonalize();
nvtxs = (int) *lnvtxs;
A = (struct vtx_data **) dA;
orthlist = (struct orthlink *) dorthlist;
/* The offset on x and y is because the arrays come originally from Fortran
declarations which index from 1 */
splarax(y - 1, A, nvtxs, x - 1, vwsqrt, work - 1);
/* Now orthogonalize against lower eigenvectors. */
if (vwsqrt == NULL)
orthog1(y - 1, 1, nvtxs);
else
orthogvec(y - 1, 1, nvtxs, vwsqrt);
orthogonalize(y - 1, nvtxs, orthlist);
return (0);
}
void
orthogonalize (
double *vec, /* vector to be orthogonalized */
int n, /* length of the columns of orth */
struct orthlink *orthlist /* set of vectors to orthogonalize against */
)
{
struct orthlink *curlnk;
void orthogvec();
curlnk = orthlist;
while (curlnk != NULL) {
orthogvec(vec, 1, n, curlnk->vec);
curlnk = curlnk->pntr;
}
}
void
coarsen (
/* Coarsen until nvtxs <= vmax, compute and uncoarsen. */
struct vtx_data **graph, /* array of vtx data for graph */
int nvtxs, /* number of vertices in graph */
int nedges, /* number of edges in graph */
int using_vwgts, /* are vertices weights being used? */
int using_ewgts, /* are edge weights being used? */
float *term_wgts[], /* terminal weights */
int igeom, /* dimension for geometric information */
float **coords, /* coordinates for vertices */
double **yvecs, /* eigenvectors returned */
int ndims, /* number of eigenvectors to calculate */
int solver_flag, /* which eigensolver to use */
int vmax, /* largest subgraph to stop coarsening */
double eigtol, /* tolerence in eigen calculation */
int nstep, /* number of coarsenings between RQI steps */
int step, /* current step number */
int give_up /* has coarsening bogged down? */
)
{
extern FILE *Output_File; /* output file or null */
extern int DEBUG_COARSEN; /* debug flag for coarsening */
extern int PERTURB; /* was matrix perturbed in Lanczos? */
extern double COARSEN_RATIO_MIN; /* min vtx reduction for coarsening */
extern int COARSEN_VWGTS; /* use vertex weights while coarsening? */
extern int COARSEN_EWGTS; /* use edge weights while coarsening? */
extern double refine_time; /* time for RQI/Symmlq iterative refinement */
struct vtx_data **cgraph; /* array of vtx data for coarsened graph */
struct orthlink *orthlist; /* list of lower evecs to suppress */
struct orthlink *newlink; /* lower evec to suppress */
double *cyvecs[MAXDIMS + 1]; /* eigenvectors for subgraph */
double evals[MAXDIMS + 1]; /* eigenvalues returned */
double goal[MAXSETS]; /* needed for convergence mode = 1 */
double *r1, *r2, *work; /* space needed by symmlq/RQI */
double *v, *w, *x, *y; /* space needed by symmlq/RQI */
double *gvec; /* rhs vector in extended eigenproblem */
double evalest; /* eigenvalue estimate returned by RQI */
double maxdeg; /* maximum weighted degree of a vertex */
float **ccoords; /* coordinates for coarsened graph */
float *cterm_wgts[MAXSETS]; /* coarse graph terminal weights */
float *new_term_wgts[MAXSETS]; /* terminal weights for Bui's method*/
float **real_term_wgts; /* one of the above */
float *twptr; /* loops through term_wgts */
float *twptr_save; /* copy of twptr */
float *ctwptr; /* loops through cterm_wgts */
double *vwsqrt = NULL; /* square root of vertex weights */
double norm, alpha; /* values used for orthogonalization */
double initshift; /* initial shift for RQI */
double total_vwgt; /* sum of all the vertex weights */
double w1, w2; /* weights of two sets */
double sigma; /* norm of rhs in extended eigenproblem */
double term_tot; /* sum of all terminal weights */
int *space; /* room for assignment in Lanczos */
int *morespace; /* room for assignment in Lanczos */
int *v2cv; /* mapping from vertices to coarse vtxs */
int vwgt_max; /* largest vertex weight */
int oldperturb; /* saves PERTURB value */
int cnvtxs; /* number of vertices in coarsened graph */
int cnedges; /* number of edges in coarsened graph */
int nextstep; /* next step in RQI test */
int nsets; /* number of sets being created */
int i, j; /* loop counters */
double time; /* time marker */
double dot(), ch_normalize(), find_maxdeg(), seconds();
struct orthlink *makeorthlnk();
void makevwsqrt(), eigensolve(), coarsen1(), orthogvec(), rqi_ext();
void ch_interpolate(), orthog1(), rqi(), scadd(), free_graph();
if (DEBUG_COARSEN > 0) {
printf("<Entering coarsen, step=%d, nvtxs=%d, nedges=%d, vmax=%d>\n",
step, nvtxs, nedges, vmax);
}
nsets = 1 << ndims;
/* Is problem small enough to solve? */
if (nvtxs <= vmax || give_up) {
if (using_vwgts) {
vwsqrt = smalloc((nvtxs + 1) * sizeof(double));
makevwsqrt(vwsqrt, graph, nvtxs);
}
else
vwsqrt = NULL;
maxdeg = find_maxdeg(graph, nvtxs, using_ewgts, (float *) NULL);
if (using_vwgts) {
vwgt_max = 0;
total_vwgt = 0;
for (i = 1; i <= nvtxs; i++) {
if (graph[i]->vwgt > vwgt_max)
vwgt_max = graph[i]->vwgt;
total_vwgt += graph[i]->vwgt;
}
}
else {
vwgt_max = 1;
total_vwgt = nvtxs;
}
for (i = 0; i < nsets; i++)
goal[i] = total_vwgt / nsets;
space = smalloc((nvtxs + 1) * sizeof(int));
/* If not coarsening ewgts, then need care with term_wgts. */
if (!using_ewgts && term_wgts[1] != NULL && step != 0) {
twptr = smalloc((nvtxs + 1) * (nsets - 1) * sizeof(float));
twptr_save = twptr;
for (j = 1; j < nsets; j++) {
new_term_wgts[j] = twptr;
twptr += nvtxs + 1;
}
for (j = 1; j < nsets; j++) {
twptr = term_wgts[j];
ctwptr = new_term_wgts[j];
for (i = 1; i <= nvtxs; i++) {
if (twptr[i] > .5) ctwptr[i] = 1;
else if (twptr[i] < -.5) ctwptr[i] = -1;
else ctwptr[i] = 0;
}
}
real_term_wgts = new_term_wgts;
}
else {
real_term_wgts = term_wgts;
new_term_wgts[1] = NULL;
}
eigensolve(graph, nvtxs, nedges, maxdeg, vwgt_max, vwsqrt,
using_vwgts, using_ewgts, real_term_wgts, igeom, coords,
yvecs, evals, 0, space, goal,
solver_flag, FALSE, 0, ndims, 3, eigtol);
if (real_term_wgts != term_wgts && new_term_wgts[1] != NULL) {
sfree(real_term_wgts[1]);
}
sfree(space);
if (vwsqrt != NULL)
sfree(vwsqrt);
return;
}
/* Otherwise I have to coarsen. */
if (coords != NULL) {
ccoords = smalloc(igeom * sizeof(float *));
}
else {
ccoords = NULL;
}
coarsen1(graph, nvtxs, nedges, &cgraph, &cnvtxs, &cnedges,
&v2cv, igeom, coords, ccoords, using_ewgts);
/* If coarsening isn't working very well, give up and partition. */
give_up = FALSE;
if (nvtxs * COARSEN_RATIO_MIN < cnvtxs && cnvtxs > vmax ) {
printf("WARNING: Coarsening not making enough progress, nvtxs = %d, cnvtxs = %d.\n",
nvtxs, cnvtxs);
printf(" Recursive coarsening being stopped prematurely.\n");
if (Output_File != NULL) {
fprintf(Output_File,
"WARNING: Coarsening not making enough progress, nvtxs = %d, cnvtxs = %d.\n",
nvtxs, cnvtxs);
fprintf(Output_File,
" Recursive coarsening being stopped prematurely.\n");
}
give_up = TRUE;
}
/* Create space for subgraph yvecs. */
for (i = 1; i <= ndims; i++) {
cyvecs[i] = smalloc((cnvtxs + 1) * sizeof(double));
}
/* Make coarse version of terminal weights. */
if (term_wgts[1] != NULL) {
twptr = smalloc((cnvtxs + 1) * (nsets - 1) * sizeof(float));
twptr_save = twptr;
for (i = (cnvtxs + 1) * (nsets - 1); i ; i--) {
*twptr++ = 0;
}
twptr = twptr_save;
for (j = 1; j < nsets; j++) {
cterm_wgts[j] = twptr;
twptr += cnvtxs + 1;
}
for (j = 1; j < nsets; j++) {
ctwptr = cterm_wgts[j];
twptr = term_wgts[j];
for (i = 1; i < nvtxs; i++){
ctwptr[v2cv[i]] += twptr[i];
}
}
}
else {
cterm_wgts[1] = NULL;
}
/* Now recurse on coarse subgraph. */
nextstep = step + 1;
coarsen(cgraph, cnvtxs, cnedges, COARSEN_VWGTS, COARSEN_EWGTS, cterm_wgts,
igeom, ccoords, cyvecs, ndims, solver_flag, vmax, eigtol,
nstep, nextstep, give_up);
ch_interpolate(yvecs, cyvecs, ndims, graph, nvtxs, v2cv, using_ewgts);
sfree(cterm_wgts[1]);
sfree(v2cv);
/* I need to do Rayleigh Quotient Iteration each nstep stages. */
time = seconds();
if (!(step % nstep)) {
oldperturb = PERTURB;
PERTURB = FALSE;
/* Should I do some orthogonalization here against vwsqrt? */
if (using_vwgts) {
vwsqrt = smalloc((nvtxs + 1) * sizeof(double));
makevwsqrt(vwsqrt, graph, nvtxs);
for (i = 1; i <= ndims; i++)
orthogvec(yvecs[i], 1, nvtxs, vwsqrt);
}
else
for (i = 1; i <= ndims; i++)
orthog1(yvecs[i], 1, nvtxs);
/* Allocate space that will be needed in RQI. */
r1 = smalloc(7 * (nvtxs + 1) * sizeof(double));
r2 = &r1[nvtxs + 1];
v = &r1[2 * (nvtxs + 1)];
w = &r1[3 * (nvtxs + 1)];
x = &r1[4 * (nvtxs + 1)];
y = &r1[5 * (nvtxs + 1)];
work = &r1[6 * (nvtxs + 1)];
if (using_vwgts) {
vwgt_max = 0;
total_vwgt = 0;
for (i = 1; i <= nvtxs; i++) {
if (graph[i]->vwgt > vwgt_max)
vwgt_max = graph[i]->vwgt;
total_vwgt += graph[i]->vwgt;
}
}
else {
vwgt_max = 1;
total_vwgt = nvtxs;
}
for (i = 0; i < nsets; i++)
goal[i] = total_vwgt / nsets;
space = smalloc((nvtxs + 1) * sizeof(int));
morespace = smalloc((nvtxs) * sizeof(int));
initshift = 0;
orthlist = NULL;
for (i = 1; i < ndims; i++) {
ch_normalize(yvecs[i], 1, nvtxs);
rqi(graph, yvecs, i, nvtxs, r1, r2, v, w, x, y, work,
eigtol, initshift, &evalest, vwsqrt, orthlist,
0, nsets, space, morespace, 3, goal, vwgt_max, ndims);
/* Now orthogonalize higher yvecs against this one. */
norm = dot(yvecs[i], 1, nvtxs, yvecs[i]);
for (j = i + 1; j <= ndims; j++) {
alpha = -dot(yvecs[j], 1, nvtxs, yvecs[i]) / norm;
scadd(yvecs[j], 1, nvtxs, alpha, yvecs[i]);
}
/* Now prepare for next pass through loop. */
initshift = evalest;
newlink = makeorthlnk();
newlink->vec = yvecs[i];
newlink->pntr = orthlist;
orthlist = newlink;
}
ch_normalize(yvecs[ndims], 1, nvtxs);
if (term_wgts[1] != NULL && ndims == 1) {
/* Solve extended eigen problem */
/* If not coarsening ewgts, then need care with term_wgts. */
if (!using_ewgts && term_wgts[1] != NULL && step != 0) {
twptr = smalloc((nvtxs + 1) * (nsets - 1) * sizeof(float));
twptr_save = twptr;
for (j = 1; j < nsets; j++) {
new_term_wgts[j] = twptr;
twptr += nvtxs + 1;
}
for (j = 1; j < nsets; j++) {
twptr = term_wgts[j];
ctwptr = new_term_wgts[j];
for (i = 1; i <= nvtxs; i++) {
if (twptr[i] > .5) ctwptr[i] = 1;
else if (twptr[i] < -.5) ctwptr[i] = -1;
else ctwptr[i] = 0;
}
}
real_term_wgts = new_term_wgts;
}
else {
real_term_wgts = term_wgts;
new_term_wgts[1] = NULL;
}
/* Following only works for bisection. */
w1 = goal[0];
w2 = goal[1];
sigma = sqrt(4*w1*w2/(w1+w2));
gvec = smalloc((nvtxs+1)*sizeof(double));
term_tot = sigma; /* Avoids lint warning for now. */
term_tot = 0;
for (j=1; j<=nvtxs; j++) term_tot += (real_term_wgts[1])[j];
term_tot /= (w1+w2);
if (using_vwgts) {
for (j=1; j<=nvtxs; j++) {
gvec[j] = (real_term_wgts[1])[j]/graph[j]->vwgt - term_tot;
}
}
else {
for (j=1; j<=nvtxs; j++) {
gvec[j] = (real_term_wgts[1])[j] - term_tot;
}
}
rqi_ext();
sfree(gvec);
if (real_term_wgts != term_wgts && new_term_wgts[1] != NULL) {
sfree(new_term_wgts[1]);
}
}
else {
rqi(graph, yvecs, ndims, nvtxs, r1, r2, v, w, x, y, work,
eigtol, initshift, &evalest, vwsqrt, orthlist,
0, nsets, space, morespace, 3, goal, vwgt_max, ndims);
}
refine_time += seconds() - time;
/* Free the space allocated for RQI. */
sfree(morespace);
sfree(space);
while (orthlist != NULL) {
newlink = orthlist->pntr;
sfree(orthlist);
orthlist = newlink;
}
sfree(r1);
if (vwsqrt != NULL)
sfree(vwsqrt);
PERTURB = oldperturb;
}
if (DEBUG_COARSEN > 0) {
printf(" Leaving coarsen, step=%d\n", step);
}
/* Free the space that was allocated. */
if (ccoords != NULL) {
for (i = 0; i < igeom; i++)
sfree(ccoords[i]);
sfree(ccoords);
}
for (i = ndims; i > 0; i--)
sfree(cyvecs[i]);
free_graph(cgraph);
}
void
lanczos_FO (
struct vtx_data **A, /* graph data structure */
int n, /* number of rows/colums in matrix */
int d, /* problem dimension = # evecs to find */
double **y, /* columns of y are eigenvectors of A */
double *lambda, /* ritz approximation to eigenvals of A */
double *bound, /* on ritz pair approximations to eig pairs of A */
double eigtol, /* tolerance on eigenvectors */
double *vwsqrt, /* square root of vertex weights */
double maxdeg, /* maximum degree of graph */
int version /* 1 = standard mode, 2 = inverse operator mode */
)
{
extern FILE *Output_File; /* output file or NULL */
extern int DEBUG_EVECS; /* print debugging output? */
extern int DEBUG_TRACE; /* trace main execution path */
extern int WARNING_EVECS; /* print warning messages? */
extern int LANCZOS_MAXITNS; /* maximum Lanczos iterations allowed */
extern double BISECTION_SAFETY; /* safety factor for bisection algorithm */
extern double SRESTOL; /* resid tol for T evec comp */
extern double DOUBLE_MAX; /* Warning on inaccurate computation of evec of T */
extern double splarax_time; /* time matvecs */
extern double orthog_time; /* time orthogonalization work */
extern double tevec_time; /* time tridiagonal eigvec work */
extern double evec_time; /* time to generate eigenvectors */
extern double ql_time; /* time tridiagonal eigval work */
extern double blas_time; /* time for blas (not assembly coded) */
extern double init_time; /* time for allocating memory, etc. */
extern double scan_time; /* time for scanning bounds list */
extern double debug_time; /* time for debug computations and output */
int i, j; /* indicies */
int maxj; /* maximum number of Lanczos iterations */
double *u, *r; /* Lanczos vectors */
double *Aq; /* sparse matrix-vector product vector */
double *alpha, *beta; /* the Lanczos scalars from each step */
double *ritz; /* copy of alpha for tqli */
double *workj; /* work vector (eg. for tqli) */
double *workn; /* work vector (eg. for checkeig) */
double *s; /* eigenvector of T */
double **q; /* columns of q = Lanczos basis vectors */
double *bj; /* beta(j)*(last element of evecs of T) */
double bis_safety; /* real safety factor for bisection algorithm */
double Sres; /* how well Tevec calculated eigvecs */
double Sres_max; /* Maximum value of Sres */
int inc_bis_safety; /* need to increase bisection safety */
double *Ares; /* how well Lanczos calculated each eigpair */
double *inv_lambda; /* eigenvalues of inverse operator */
int *index; /* the Ritz index of an eigenpair */
struct orthlink *orthlist = NULL; /* vectors to orthogonalize against in Lanczos */
struct orthlink *orthlist2 = NULL; /* vectors to orthogonalize against in Symmlq */
struct orthlink *temp; /* for expanding orthogonalization list */
double *ritzvec=NULL; /* ritz vector for current iteration */
double *zeros=NULL; /* vector of all zeros */
double *ones=NULL; /* vector of all ones */
struct scanlink *scanlist; /* list of fields for min ritz vals */
struct scanlink *curlnk; /* for traversing the scanlist */
double bji_tol; /* tol on bji estimate of A e-residual */
int converged; /* has the iteration converged? */
double time; /* current clock time */
double shift, rtol; /* symmlq input */
long precon, goodb, nout; /* symmlq input */
long checka, intlim; /* symmlq input */
double anorm, acond; /* symmlq output */
double rnorm, ynorm; /* symmlq output */
long istop, itn; /* symmlq output */
double macheps; /* machine precision calculated by symmlq */
double normxlim; /* a stopping criteria for symmlq */
long itnmin; /* enforce minimum number of iterations */
int symmlqitns; /* # symmlq itns */
double *wv1=NULL, *wv2=NULL, *wv3=NULL; /* Symmlq work space */
double *wv4=NULL, *wv5=NULL, *wv6=NULL; /* Symmlq work space */
long long_n; /* long int copy of n for symmlq */
int ritzval_flag = 0; /* status flag for ql() */
double Anorm; /* Norm estimate of the Laplacian matrix */
int left, right; /* ranges on the search for ritzvals */
int memory_ok; /* TRUE as long as don't run out of memory */
double *mkvec(); /* allocates space for a vector */
double *mkvec_ret(); /* mkvec() which returns error code */
double dot(); /* standard dot product routine */
struct orthlink *makeorthlnk(); /* make space for entry in orthog. set */
double ch_norm(); /* vector norm */
double Tevec(); /* calc evec of T by linear recurrence */
struct scanlink *mkscanlist(); /* make scan list for min ritz vecs */
double lanc_seconds(); /* current clock timer */
int symmlq_(), get_ritzvals();
void setvec(), vecscale(), update(), vecran(), strout();
void splarax(), scanmin(), scanmax(), frvec(), orthogonalize();
void orthog1(), orthogvec(), bail(), warnings(), mkeigvecs();
if (DEBUG_TRACE > 0) {
printf("<Entering lanczos_FO>\n");
}
if (DEBUG_EVECS > 0) {
if (version == 1) {
printf("Full orthogonalization Lanczos, matrix size = %d\n", n);
}
else {
printf("Full orthogonalization Lanczos, inverted operator, matrix size = %d\n", n);
}
}
/* Initialize time. */
time = lanc_seconds();
if (n < d + 1) {
bail("ERROR: System too small for number of eigenvalues requested.",1);
/* d+1 since don't use zero eigenvalue pair */
}
/* Allocate Lanczos space. */
maxj = LANCZOS_MAXITNS;
u = mkvec(1, n);
r = mkvec(1, n);
Aq = mkvec(1, n);
ritzvec = mkvec(1, n);
zeros = mkvec(1, n);
setvec(zeros, 1, n, 0.0);
workn = mkvec(1, n);
Ares = mkvec(1, d);
inv_lambda = mkvec(1, d);
index = smalloc((d + 1) * sizeof(int));
alpha = mkvec(1, maxj);
beta = mkvec(1, maxj + 1);
ritz = mkvec(1, maxj);
s = mkvec(1, maxj);
bj = mkvec(1, maxj);
workj = mkvec(1, maxj + 1);
q = smalloc((maxj + 1) * sizeof(double *));
scanlist = mkscanlist(d);
if (version == 2) {
/* Allocate Symmlq space all in one chunk. */
wv1 = smalloc(6 * (n + 1) * sizeof(double));
wv2 = &wv1[(n + 1)];
wv3 = &wv1[2 * (n + 1)];
wv4 = &wv1[3 * (n + 1)];
wv5 = &wv1[4 * (n + 1)];
wv6 = &wv1[5 * (n + 1)];
/* Set invariant symmlq parameters */
precon = FALSE; /* FALSE until we figure out a good way */
goodb = FALSE; /* should be FALSE for this application */
checka = FALSE; /* if don't know by now, too bad */
intlim = n; /* set to enforce a maximum number of Symmlq itns */
itnmin = 0; /* set to enforce a minimum number of Symmlq itns */
shift = 0.0; /* since just solving rather than doing RQI */
symmlqitns = 0; /* total number of Symmlq iterations */
nout = 0; /* Effectively disabled - see notes in symmlq.f */
rtol = 1.0e-5; /* requested residual tolerance */
normxlim = DOUBLE_MAX; /* Effectively disables ||x|| termination criterion */
long_n = n; /* copy to long for linting */
}
/* Initialize. */
vecran(r, 1, n);
if (vwsqrt == NULL) {
/* whack one's direction from initial vector */
orthog1(r, 1, n);
/* list the ones direction for later use in Symmlq */
if (version == 2) {
orthlist2 = makeorthlnk();
ones = mkvec(1, n);
setvec(ones, 1, n, 1.0);
orthlist2->vec = ones;
orthlist2->pntr = NULL;
}
}
else {
/* whack vwsqrt direction from initial vector */
orthogvec(r, 1, n, vwsqrt);
if (version == 2) {
/* list the vwsqrt direction for later use in Symmlq */
orthlist2 = makeorthlnk();
orthlist2->vec = vwsqrt;
orthlist2->pntr = NULL;
}
}
beta[1] = ch_norm(r, 1, n);
q[0] = zeros;
bji_tol = eigtol;
orthlist = NULL;
Sres_max = 0.0;
Anorm = 2 * maxdeg; /* Gershgorin estimate for ||A|| */
bis_safety = BISECTION_SAFETY;
inc_bis_safety = FALSE;
init_time += lanc_seconds() - time;
/* Main Lanczos loop. */
j = 1;
converged = FALSE;
memory_ok = TRUE;
while ((j <= maxj) && (converged == FALSE) && memory_ok) {
time = lanc_seconds();
/* Allocate next Lanczos vector. If fail, back up one step and compute approx. eigvec. */
q[j] = mkvec_ret(1, n);
if (q[j] == NULL) {
memory_ok = FALSE;
if (DEBUG_EVECS > 0 || WARNING_EVECS > 0) {
strout("WARNING: Lanczos out of memory; computing best approximation available.\n");
}
if (j <= 2) {
bail("ERROR: Sorry, can't salvage Lanczos.",1);
/* ... save yourselves, men. */
}
j--;
}
vecscale(q[j], 1, n, 1.0 / beta[j], r);
blas_time += lanc_seconds() - time;
time = lanc_seconds();
if (version == 1) {
splarax(Aq, A, n, q[j], vwsqrt, workn);
}
else {
symmlq_(&long_n, &(q[j][1]), &wv1[1], &wv2[1], &wv3[1], &wv4[1], &Aq[1], &wv5[1],
&wv6[1], &checka, &goodb, &precon, &shift, &nout,
&intlim, &rtol, &istop, &itn, &anorm, &acond,
&rnorm, &ynorm, (double *) A, vwsqrt, (double *) orthlist2,
&macheps, &normxlim, &itnmin);
symmlqitns += itn;
if (DEBUG_EVECS > 2) {
printf("Symmlq report: rtol %g\n", rtol);
printf(" system norm %g, solution norm %g\n", anorm, ynorm);
printf(" system condition %g, residual %g\n", acond, rnorm);
printf(" termination condition %2ld, iterations %3ld\n", istop, itn);
}
}
splarax_time += lanc_seconds() - time;
time = lanc_seconds();
update(u, 1, n, Aq, -beta[j], q[j - 1]);
alpha[j] = dot(u, 1, n, q[j]);
update(r, 1, n, u, -alpha[j], q[j]);
blas_time += lanc_seconds() - time;
time = lanc_seconds();
if (vwsqrt == NULL) {
orthog1(r, 1, n);
}
else {
orthogvec(r, 1, n, vwsqrt);
}
orthogonalize(r, n, orthlist);
temp = orthlist;
orthlist = makeorthlnk();
orthlist->vec = q[j];
orthlist->pntr = temp;
beta[j + 1] = ch_norm(r, 1, n);
orthog_time += lanc_seconds() - time;
time = lanc_seconds();
left = j/2;
right = j - left + 1;
if (inc_bis_safety) {
bis_safety *= 10;
inc_bis_safety = FALSE;
}
ritzval_flag = get_ritzvals(alpha, beta+1, j, Anorm, workj+1,
ritz, d, left, right, eigtol, bis_safety);
/* ... have to off-set beta and workj since full orthogonalization
indexes these from 1 to maxj+1 whereas selective orthog.
indexes them from 0 to maxj */
if (ritzval_flag != 0) {
bail("ERROR: Both Sturm bisection and QL failed.",1);
/* ... give up. */
}
ql_time += lanc_seconds() - time;
/* Convergence check using Paige bji estimates. */
time = lanc_seconds();
for (i = 1; i <= j; i++) {
Sres = Tevec(alpha, beta, j, ritz[i], s);
if (Sres > Sres_max) {
Sres_max = Sres;
}
if (Sres > SRESTOL) {
inc_bis_safety = TRUE;
}
bj[i] = s[j] * beta[j + 1];
}
tevec_time += lanc_seconds() - time;
time = lanc_seconds();
if (version == 1) {
scanmin(ritz, 1, j, &scanlist);
}
else {
scanmax(ritz, 1, j, &scanlist);
}
converged = TRUE;
if (j < d)
converged = FALSE;
else {
curlnk = scanlist;
while (curlnk != NULL) {
if (bj[curlnk->indx] > bji_tol) {
converged = FALSE;
}
curlnk = curlnk->pntr;
}
}
scan_time += lanc_seconds() - time;
j++;
}
j--;
/* Collect eigenvalue and bound information. */
time = lanc_seconds();
mkeigvecs(scanlist,lambda,bound,index,bj,d,&Sres_max,alpha,beta+1,j,s,y,n,q);
evec_time += lanc_seconds() - time;
/* Analyze computation for and report additional problems */
time = lanc_seconds();
if (DEBUG_EVECS>0 && version == 2) {
printf("\nTotal Symmlq iterations %3d\n", symmlqitns);
}
if (version == 2) {
for (i = 1; i <= d; i++) {
lambda[i] = 1.0/lambda[i];
}
}
warnings(workn, A, y, n, lambda, vwsqrt, Ares, bound, index,
d, j, maxj, Sres_max, eigtol, u, Anorm, Output_File);
debug_time += lanc_seconds() - time;
/* Free any memory allocated in this routine. */
time = lanc_seconds();
frvec(u, 1);
frvec(r, 1);
frvec(Aq, 1);
frvec(ritzvec, 1);
frvec(zeros, 1);
if (vwsqrt == NULL && version == 2) {
frvec(ones, 1);
}
frvec(workn, 1);
frvec(Ares, 1);
frvec(inv_lambda, 1);
sfree(index);
frvec(alpha, 1);
frvec(beta, 1);
frvec(ritz, 1);
frvec(s, 1);
frvec(bj, 1);
frvec(workj, 1);
if (version == 2) {
frvec(wv1, 0);
}
while (scanlist != NULL) {
curlnk = scanlist->pntr;
sfree(scanlist);
scanlist = curlnk;
}
for (i = 1; i <= j; i++) {
frvec(q[i], 1);
}
while (orthlist != NULL) {
temp = orthlist->pntr;
sfree(orthlist);
orthlist = temp;
}
while (version == 2 && orthlist2 != NULL) {
temp = orthlist2->pntr;
sfree(orthlist2);
orthlist2 = temp;
}
sfree(q);
init_time += lanc_seconds() - time;
}
int lanczos_ext(struct vtx_data **A, /* sparse matrix in row linked list format */
int n, /* problem size */
int d, /* problem dimension = number of eigvecs to find */
double ** y, /* columns of y are eigenvectors of A */
double eigtol, /* tolerance on eigenvectors */
double * vwsqrt, /* square roots of vertex weights */
double maxdeg, /* maximum degree of graph */
int version, /* flags which version of sel. orth. to use */
double * gvec, /* the rhs n-vector in the extended eigen problem */
double sigma /* specifies the norm constraint on extended
eigenvector */
)
{
extern FILE * Output_File; /* output file or null */
extern int LANCZOS_SO_INTERVAL; /* interval between orthogonalizations */
extern int LANCZOS_MAXITNS; /* maximum Lanczos iterations allowed */
extern int DEBUG_EVECS; /* print debugging output? */
extern int DEBUG_TRACE; /* trace main execution path */
extern int WARNING_EVECS; /* print warning messages? */
extern double BISECTION_SAFETY; /* safety for T bisection algorithm */
extern double SRESTOL; /* resid tol for T evec comp */
extern double DOUBLE_EPSILON; /* machine precision */
extern double DOUBLE_MAX; /* largest double value */
extern double splarax_time; /* time matvec */
extern double orthog_time; /* time orthogonalization work */
extern double evec_time; /* time to generate eigenvectors */
extern double ql_time; /* time tridiagonal eigenvalue work */
extern double blas_time; /* time for blas. linear algebra */
extern double init_time; /* time to allocate, intialize variables */
extern double scan_time; /* time for scanning eval and bound lists */
extern double debug_time; /* time for (some of) debug computations */
extern double ritz_time; /* time to generate ritz vectors */
extern double pause_time; /* time to compute whether to pause */
int i, j, k; /* indicies */
int maxj; /* maximum number of Lanczos iterations */
double * u, *r; /* Lanczos vectors */
double * alpha, *beta; /* the Lanczos scalars from each step */
double * ritz; /* copy of alpha for ql */
double * workj; /* work vector, e.g. copy of beta for ql */
double * workn; /* work vector, e.g. product Av for checkeig */
double * s; /* eigenvector of T */
double ** q; /* columns of q are Lanczos basis vectors */
double * bj; /* beta(j)*(last el. of corr. eigvec s of T) */
double Sres; /* how well Tevec calculated eigvec s */
double Sres_max; /* Max value of Sres */
int inc_bis_safety; /* has Sres increased? */
double * Ares; /* how well Lanczos calc. eigpair lambda,y */
int * index; /* the Ritz index of an eigenpair */
struct orthlink **solist; /* vec. of structs with vecs. to orthog. against */
struct scanlink * scanlist; /* linked list of fields to do with min ritz vals */
struct scanlink * curlnk; /* for traversing the scanlist */
double bis_safety; /* real safety for T bisection algorithm */
int converged; /* has the iteration converged? */
double goodtol; /* error tolerance for a good Ritz vector */
int ngood; /* total number of good Ritz pairs at current step */
int maxngood; /* biggest val of ngood through current step */
int left_ngood; /* number of good Ritz pairs on left end */
int lastpause; /* Most recent step with good ritz vecs */
int nopauses; /* Have there been any pauses? */
int interval; /* number of steps between pauses */
double time; /* Current clock time */
int left_goodlim; /* number of ritz pairs checked on left end */
double Anorm; /* Norm estimate of the Laplacian matrix */
int pausemode; /* which Lanczos pausing criterion to use */
int pause; /* whether to pause */
int temp; /* used to prevent redundant index computations */
double * extvec; /* n-vector solving the extended A eigenproblem */
double * v; /* j-vector solving the extended T eigenproblem */
double extval = 0.0; /* computed extended eigenvalue (of both A and T) */
double * work1, *work2; /* work vectors */
double check; /* to check an orthogonality condition */
double numerical_zero; /* used for zero in presense of round-off */
int ritzval_flag; /* status flag for get_ritzvals() */
int memory_ok; /* TRUE until memory runs out */
double * mkvec(); /* allocates space for a vector */
double * mkvec_ret(); /* mkvec() which returns error code */
double dot(); /* standard dot product routine */
struct orthlink *makeorthlnk(); /* makes space for new entry in orthog. set */
double ch_norm(); /* vector norm */
double Tevec(); /* calc eigenvector of T by linear recurrence */
struct scanlink *mkscanlist(); /* init scan list for min ritz vecs */
double lanc_seconds(); /* switcheable timer */
/* free allocated memory safely */
int lanpause(); /* figure when to pause Lanczos iteration */
int get_ritzvals(); /* compute eigenvalues of T */
void setvec(); /* initialize a vector */
void vecscale(); /* scale a vector */
void splarax(); /* matrix vector multiply */
void update(); /* add scalar multiple of a vector to another */
void sorthog(); /* orthogonalize vector against list of others */
void bail(); /* our exit routine */
void scanmin(); /* store small values of vector in linked list */
void frvec(); /* free vector */
void scadd(); /* add scalar multiple of vector to another */
void cpvec(); /* copy a vector */
void orthog1(); /* efficiently orthog. against vector of ones */
void solistout(); /* print out orthogonalization list */
void doubleout(); /* print a double precision number */
void orthogvec(); /* orthogonalize one vector against another */
void get_extval(); /* find extended Ritz values */
void scale_diag(); /* scale vector by diagonal matrix */
void strout(); /* print string to screen and file */
double checkeig_ext(); /* check extended eigenpair residual directly */
if (DEBUG_TRACE > 0) {
printf("<Entering lanczos_ext>\n");
}
if (DEBUG_EVECS > 0) {
printf("Selective orthogonalization Lanczos for extended eigenproblem, matrix size = %d.\n", n);
}
/* Initialize time. */
time = lanc_seconds();
if (d != 1) {
bail("ERROR: Extended Lanczos only available for bisection.", 1);
/* ... something must be wrong upstream. */
}
if (n < d + 1) {
bail("ERROR: System too small for number of eigenvalues requested.", 1);
/* ... d+1 since don't use zero eigenvalue pair */
}
/* Allocate space. */
maxj = LANCZOS_MAXITNS;
u = mkvec(1, n);
r = mkvec(1, n);
workn = mkvec(1, n);
Ares = mkvec(0, d);
index = smalloc((d + 1) * sizeof(int));
alpha = mkvec(1, maxj);
beta = mkvec(0, maxj);
ritz = mkvec(1, maxj);
s = mkvec(1, maxj);
bj = mkvec(1, maxj);
workj = mkvec(0, maxj);
q = smalloc((maxj + 1) * sizeof(double *));
solist = smalloc((maxj + 1) * sizeof(struct orthlink *));
scanlist = mkscanlist(d);
extvec = mkvec(1, n);
v = mkvec(1, maxj);
work1 = mkvec(1, maxj);
work2 = mkvec(1, maxj);
/* Set some constants governing orthogonalization */
ngood = 0;
maxngood = 0;
Anorm = 2 * maxdeg; /* Gershgorin estimate for ||A|| */
goodtol = Anorm * sqrt(DOUBLE_EPSILON); /* Parlett & Scott's bound, p.224 */
interval = 2 + (int)min(LANCZOS_SO_INTERVAL - 2, n / (2 * LANCZOS_SO_INTERVAL));
bis_safety = BISECTION_SAFETY;
numerical_zero = 1.0e-13;
if (DEBUG_EVECS > 0) {
printf(" maxdeg %g\n", maxdeg);
printf(" goodtol %g\n", goodtol);
printf(" interval %d\n", interval);
printf(" maxj %d\n", maxj);
}
/* Initialize space. */
cpvec(r, 1, n, gvec);
if (vwsqrt != NULL) {
scale_diag(r, 1, n, vwsqrt);
}
check = ch_norm(r, 1, n);
if (vwsqrt == NULL) {
orthog1(r, 1, n);
}
else {
orthogvec(r, 1, n, vwsqrt);
}
check = fabs(check - ch_norm(r, 1, n));
if (check > 10 * numerical_zero && WARNING_EVECS > 0) {
strout("WARNING: In terminal propagation, rhs should have no component in the");
printf(" nullspace of the Laplacian, so check val %g should be negligible.\n", check);
if (Output_File != NULL) {
fprintf(Output_File,
" nullspace of the Laplacian, so check val %g should be negligible.\n",
check);
}
}
beta[0] = ch_norm(r, 1, n);
q[0] = mkvec(1, n);
setvec(q[0], 1, n, 0.0);
setvec(bj, 1, maxj, DOUBLE_MAX);
if (beta[0] < numerical_zero) {
/* The rhs vector, Dg, of the transformed problem is numerically zero or is
in the null space of the Laplacian, so this is not a well posed extended
eigenproblem. Set maxj to zero to force a quick exit but still clean-up
memory and return(1) to indicate to eigensolve that it should call the
default eigensolver routine for the standard eigenproblem. */
maxj = 0;
}
/* Main Lanczos loop. */
j = 1;
lastpause = 0;
pausemode = 1;
left_ngood = 0;
left_goodlim = 0;
converged = FALSE;
Sres_max = 0.0;
inc_bis_safety = FALSE;
nopauses = TRUE;
memory_ok = TRUE;
init_time += lanc_seconds() - time;
while ((j <= maxj) && (!converged) && memory_ok) {
time = lanc_seconds();
/* Allocate next Lanczos vector. If fail, back up to last pause. */
q[j] = mkvec_ret(1, n);
if (q[j] == NULL) {
memory_ok = FALSE;
if (DEBUG_EVECS > 0 || WARNING_EVECS > 0) {
strout("WARNING: Lanczos_ext out of memory; computing best approximation available.\n");
}
if (nopauses) {
bail("ERROR: Sorry, can't salvage Lanczos_ext.", 1);
/* ... save yourselves, men. */
}
for (i = lastpause + 1; i <= j - 1; i++) {
frvec(q[i], 1);
}
j = lastpause;
}
/* Basic Lanczos iteration */
vecscale(q[j], 1, n, 1.0 / beta[j - 1], r);
blas_time += lanc_seconds() - time;
time = lanc_seconds();
splarax(u, A, n, q[j], vwsqrt, workn);
splarax_time += lanc_seconds() - time;
time = lanc_seconds();
update(r, 1, n, u, -beta[j - 1], q[j - 1]);
alpha[j] = dot(r, 1, n, q[j]);
update(r, 1, n, r, -alpha[j], q[j]);
blas_time += lanc_seconds() - time;
/* Selective orthogonalization */
time = lanc_seconds();
if (vwsqrt == NULL) {
orthog1(r, 1, n);
}
else {
orthogvec(r, 1, n, vwsqrt);
}
if ((j == (lastpause + 1)) || (j == (lastpause + 2))) {
sorthog(r, n, solist, ngood);
}
orthog_time += lanc_seconds() - time;
beta[j] = ch_norm(r, 1, n);
time = lanc_seconds();
pause = lanpause(j, lastpause, interval, q, n, &pausemode, version, beta[j]);
pause_time += lanc_seconds() - time;
if (pause) {
nopauses = FALSE;
lastpause = j;
/* Compute limits for checking Ritz pair convergence. */
if (version == 2) {
if (left_ngood + 2 > left_goodlim) {
left_goodlim = left_ngood + 2;
}
}
/* Special case: need at least d Ritz vals on left. */
left_goodlim = max(left_goodlim, d);
/* Special case: can't find more than j total Ritz vals. */
if (left_goodlim > j) {
left_goodlim = min(left_goodlim, j);
}
/* Find Ritz vals using faster of Sturm bisection or ql. */
time = lanc_seconds();
if (inc_bis_safety) {
bis_safety *= 10;
inc_bis_safety = FALSE;
}
ritzval_flag =
get_ritzvals(alpha, beta, j, Anorm, workj, ritz, d, left_goodlim, 0, eigtol, bis_safety);
ql_time += lanc_seconds() - time;
if (ritzval_flag != 0) {
bail("ERROR: Lanczos_ext failed in computing eigenvalues of T.", 1);
/* ... we recover from this in lanczos_SO, but don't worry here. */
}
/* Scan for minimum evals of tridiagonal. */
time = lanc_seconds();
scanmin(ritz, 1, j, &scanlist);
scan_time += lanc_seconds() - time;
/* Compute Ritz pair bounds at left end. */
time = lanc_seconds();
setvec(bj, 1, j, 0.0);
for (i = 1; i <= left_goodlim; i++) {
Sres = Tevec(alpha, beta - 1, j, ritz[i], s);
if (Sres > Sres_max) {
Sres_max = Sres;
}
if (Sres > SRESTOL) {
inc_bis_safety = TRUE;
}
bj[i] = s[j] * beta[j];
}
ritz_time += lanc_seconds() - time;
/* Show portion of spectrum checked for Ritz convergence. */
if (DEBUG_EVECS > 2) {
time = lanc_seconds();
printf("\nindex Ritz vals bji bounds\n");
for (i = 1; i <= left_goodlim; i++) {
printf(" %3d", i);
doubleout(ritz[i], 1);
doubleout(bj[i], 1);
printf("\n");
}
printf("\n");
curlnk = scanlist;
while (curlnk != NULL) {
temp = curlnk->indx;
if ((temp > left_goodlim) && (temp < j)) {
printf(" %3d", temp);
doubleout(ritz[temp], 1);
doubleout(bj[temp], 1);
printf("\n");
}
curlnk = curlnk->pntr;
}
printf(" -------------------\n");
printf(" goodtol: %19.16f\n\n", goodtol);
debug_time += lanc_seconds() - time;
}
get_extval(alpha, beta, j, ritz[1], s, eigtol, beta[0], sigma, &extval, v, work1, work2);
/* Check convergence of iteration. */
if (fabs(beta[j] * v[j]) < eigtol) {
converged = TRUE;
}
else {
converged = FALSE;
}
if (!converged) {
ngood = 0;
left_ngood = 0; /* for setting left_goodlim on next loop */
/* Compute converged Ritz pairs on left end */
time = lanc_seconds();
for (i = 1; i <= left_goodlim; i++) {
if (bj[i] <= goodtol) {
ngood += 1;
left_ngood += 1;
if (ngood > maxngood) {
maxngood = ngood;
solist[ngood] = makeorthlnk();
(solist[ngood])->vec = mkvec(1, n);
}
(solist[ngood])->index = i;
Sres = Tevec(alpha, beta - 1, j, ritz[i], s);
if (Sres > Sres_max) {
Sres_max = Sres;
}
if (Sres > SRESTOL) {
inc_bis_safety = TRUE;
}
setvec((solist[ngood])->vec, 1, n, 0.0);
for (k = 1; k <= j; k++) {
scadd((solist[ngood])->vec, 1, n, s[k], q[k]);
}
}
}
ritz_time += lanc_seconds() - time;
if (DEBUG_EVECS > 2) {
time = lanc_seconds();
/* Show some info on the orthogonalization. */
printf(" j %3d; goodlim lft %2d, rgt %2d; list ", j, left_goodlim, 0);
solistout(solist, ngood, j);
/* Assemble current approx. eigenvector, check residual directly. */
setvec(y[1], 1, n, 0.0);
for (k = 1; k <= j; k++) {
scadd(y[1], 1, n, v[k], q[k]);
}
printf(" extended eigenvalue %g\n", extval);
printf(" est. extended residual %g\n", fabs(v[j] * beta[j]));
checkeig_ext(workn, u, A, y[1], n, extval, vwsqrt, gvec, eigtol, FALSE);
printf("---------------------end of iteration---------------------\n\n");
debug_time += lanc_seconds() - time;
}
}
}
j++;
}
j--;
if (DEBUG_EVECS > 0) {
time = lanc_seconds();
if (maxj == 0) {
printf("Not extended eigenproblem -- calling ordinary eigensolver.\n");
}
else {
printf(" Lanczos_ext itns: %d\n", j);
printf(" extended eigenvalue: %g\n", extval);
if (j == maxj) {
strout("WARNING: Maximum number of Lanczos iterations reached.\n");
}
}
debug_time += lanc_seconds() - time;
}
if (maxj != 0) {
/* Compute (scaled) extended eigenvector. */
time = lanc_seconds();
setvec(y[1], 1, n, 0.0);
for (k = 1; k <= j; k++) {
scadd(y[1], 1, n, v[k], q[k]);
}
evec_time += lanc_seconds() - time;
/* Note: assign() will scale this y vector back to x (since y = Dx) */
/* Compute and check residual directly. */
if (DEBUG_EVECS > 0 || WARNING_EVECS > 0) {
time = lanc_seconds();
checkeig_ext(workn, u, A, y[1], n, extval, vwsqrt, gvec, eigtol, TRUE);
debug_time += lanc_seconds() - time;
}
}
/* free up memory */
time = lanc_seconds();
frvec(u, 1);
frvec(r, 1);
frvec(workn, 1);
frvec(Ares, 0);
sfree(index);
frvec(alpha, 1);
frvec(beta, 0);
frvec(ritz, 1);
frvec(s, 1);
frvec(bj, 1);
frvec(workj, 0);
for (i = 0; i <= j; i++) {
frvec(q[i], 1);
}
sfree(q);
while (scanlist != NULL) {
curlnk = scanlist->pntr;
sfree(scanlist);
scanlist = curlnk;
}
for (i = 1; i <= maxngood; i++) {
frvec((solist[i])->vec, 1);
sfree(solist[i]);
}
sfree(solist);
frvec(extvec, 1);
frvec(v, 1);
frvec(work1, 1);
frvec(work2, 1);
init_time += lanc_seconds() - time;
if (maxj == 0)
return (1); /* see note on beta[0] and maxj above */
else
return (0);
}
