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; }
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); }
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); }