/* Routine to compute eigenvalues */
int plarre(proc_t *procinfo, char *jobz, char *range, in_t *Dstruct,
val_t *Wstruct, tol_t *tolstruct, int *nzp, int *myfirstp)
{
/* input variables */
int pid = procinfo->pid;
int nproc = procinfo->nproc;
bool wantZ = (jobz[0] == 'V' || jobz[0] == 'v');
bool cntval = (jobz[0] == 'C' || jobz[0] == 'c');
int n = Dstruct->n;
double *restrict D = Dstruct->D;
double *restrict E = Dstruct->E;
int *restrict isplit = Dstruct->isplit;
double *vl = Wstruct->vl;
double *vu = Wstruct->vu;
int *il = Wstruct->il;
int *iu = Wstruct->iu;
double *restrict W = Wstruct->W;
double *restrict Werr = Wstruct->Werr;
double *restrict Wgap = Wstruct->Wgap;
int *restrict Windex = Wstruct->Windex;
int *restrict iblock = Wstruct->iblock;
double *restrict gersch = Wstruct->gersch;
/* constants */
int IZERO = 0, IONE = 1;
double DZERO = 0.0;
/* work space */
double *E2, *work;
int *iwork;
/* compute geschgorin disks and spectral diameter */
double gl, gu, bl_gu, eold, emax, eabs;
/* compute splitting points */
int bl_begin, bl_end;
/* distribute work among processes */
int ifirst, ilast, ifirst_tmp, ilast_tmp;
int chunk, isize, iil, iiu;
/* gather results */
int *rcount, *rdispl;
/* others */
int info, i, j, im, idummy, ind;
double tmp1, dummy;
enum range_enum {allrng=1, valrng=2, indrng=3} irange;
double intervals[2];
int negcounts[2];
double sigma;
if (range[0] == 'A' || range[0] == 'a') {
irange = allrng;
} else if (range[0] == 'V' || range[0] == 'v') {
irange = valrng;
} else if (range[0] == 'I' || range[0] == 'i') {
irange = indrng;
} else {
return(1);
}
/* allocate work space */
E2 = (double *) malloc( n * sizeof(double) );
assert(E2 != NULL);
work = (double *) malloc( 4*n * sizeof(double) );
assert(work != NULL);
iwork = (int *) malloc( 3*n * sizeof(int) );
assert(iwork != NULL);
rcount = (int *) malloc( nproc * sizeof(int) );
assert(rcount != NULL);
rdispl = (int *) malloc( nproc * sizeof(int) );
assert(rdispl != NULL);
/* Compute square of off-diagonal elements */
for (i=0; i<n-1; i++) {
E2[i] = E[i]*E[i];
}
/* compute geschgorin disks and spectral diameter */
gl = D[0];
gu = D[0];
eold = 0.0;
emax = 0.0;
E[n-1] = 0.0;
for (i=0; i<n; i++) {
eabs = fabs(E[i]);
if (eabs >= emax) emax = eabs;
tmp1 = eabs + eold;
gersch[2*i] = D[i] - tmp1;
gl = fmin(gl, gersch[2*i]);
gersch[2*i+1] = D[i] + tmp1;
gu = fmax(gu, gersch[2*i+1]);
eold = eabs;
}
/* min. pivot allowed in the Sturm sequence of T */
tolstruct->pivmin = DBL_MIN * fmax(1.0, emax*emax);
/* estimate of spectral diameter */
Dstruct->spdiam = gu - gl;
/* compute splitting points with threshold "split" */
LAPACK(dlarra)
(&n, D, E, E2, &tolstruct->split, &Dstruct->spdiam, &Dstruct->nsplit,
isplit, &info);
assert(info == 0);
if (irange == allrng || irange == indrng) {
*vl = gl;
*vu = gu;
}
/* set eigenvalue indices in case of all or subset by value has
* to be computed; thereby convert all problem to subset by index
* computation */
if (irange == allrng) {
*il = 1;
*iu = n;
} else if (irange == valrng) {
intervals[0] = *vl; intervals[1] = *vu;
/* find negcount at boundaries 'vl' and 'vu';
* needs work of dim(n) and iwork of dim(n) */
LAPACK(dlaebz)
(&IONE, &IZERO, &n, &IONE, &IONE, &IZERO, &DZERO, &DZERO,
&tolstruct->pivmin, D, E, E2, &idummy, intervals, &dummy, &idummy,
negcounts, work, iwork, &info);
assert(info == 0);
/* update negcounts of whole matrix with negcounts found for block */
*il = negcounts[0] + 1;
*iu = negcounts[1];
}
if (cntval && irange == valrng) {
/* clean up and return */
*nzp = iceil(*iu-*il+1, nproc);
clean_up_plarre(E2, work, iwork, rcount, rdispl);
return(0);
}
/* in case only eigenvalues are desired compute eigenvalues
* "il" to "iu"; otherwise compute all */
if (wantZ) {
iil = 1;
iiu = n;
} else {
iil = *il;
iiu = *iu;
}
/* each process computes a subset of the eigenvalues */
ifirst_tmp = iil;
for (i=0; i<nproc; i++) {
chunk = (iiu-iil+1)/nproc + (i < (iiu-iil+1)%nproc);
if (i == nproc-1) {
ilast_tmp = iiu;
} else {
ilast_tmp = ifirst_tmp + chunk - 1;
ilast_tmp = imin(ilast_tmp, iiu);
}
if (i == pid) {
ifirst = ifirst_tmp;
ilast = ilast_tmp;
isize = ilast - ifirst + 1;
*myfirstp = ifirst - iil;;
*nzp = isize;
}
rcount[i] = ilast_tmp - ifirst_tmp + 1;
rdispl[i] = ifirst_tmp - iil;
ifirst_tmp = ilast_tmp + 1;
ifirst_tmp = imin(ifirst_tmp, iiu + 1);
}
/* compute eigenvalues assigned to process */
if (isize != 0) {
info = eigval_subset_proc(procinfo, range, Dstruct, E2, ifirst, ilast,
tolstruct, Wstruct, work, iwork);
assert(info == 0);
}
if (wantZ) {
/* communicate results */
memcpy(work, W, isize * sizeof(double) );
MPI_Allgatherv(work, isize, MPI_DOUBLE, W, rcount, rdispl,
MPI_DOUBLE, procinfo->comm);
memcpy(work, Werr, isize * sizeof(double) );
MPI_Allgatherv(work, isize, MPI_DOUBLE, Werr, rcount, rdispl,
MPI_DOUBLE, procinfo->comm);
memcpy(iwork, Windex, isize * sizeof(int) );
MPI_Allgatherv(iwork, isize, MPI_INT, Windex, rcount, rdispl,
MPI_INT, procinfo->comm);
memcpy(iwork, iblock, isize * sizeof(int) );
MPI_Allgatherv(iwork, isize, MPI_INT, iblock, rcount, rdispl,
MPI_INT, procinfo->comm);
/* sort by block */
memcpy(&work[0], W, n*sizeof(double));
memcpy(&work[n], Werr, n*sizeof(double));
memcpy(&iwork[0], Windex, n*sizeof(int));
memcpy(&iwork[n], iblock, n*sizeof(int));
im = 0;
for (i=1; i<=Dstruct->nsplit; i++) {
for (j=0; j<n; j++) {
if (iwork[j+n] == i) { /* iblock == i */
W[im] = work[j];
Werr[im] = work[j+n];
Windex[im] = iwork[j];
iblock[im] = iwork[j+n];
im++;
}
}
}
/* recompute gap of blocks */
bl_begin = 0;
for (i=0; i < Dstruct->nsplit; i++) {
bl_end = isplit[i] - 1;
sigma = E[bl_end];
/* find outer bounds GU for block used for last gap */
bl_gu = D[bl_begin];
for (j = bl_begin; j <= bl_end; j++) {
bl_gu = fmax(bl_gu, gersch[2*j+1]);
}
/* recompute gaps within the blocks */
for (j = bl_begin; j < bl_end; j++) {
Wgap[j] = fmax(0.0, (W[j+1] - Werr[j+1]) - (W[j] + Werr[j]) );
}
Wgap[bl_end] = fmax(0.0, (bl_gu - sigma) - (W[bl_end] + Werr[bl_end]) );
bl_begin = bl_end + 1;
} /* end i */
} else {
/* compute UNSHIFTED eigenvalues */
for (i=0; i < isize; i++) {
ind = iblock[i] - 1;
bl_end = isplit[ind] - 1;
sigma = E[bl_end];
W[i] += sigma;
}
} /* if wantZ */
/* free memory */
clean_up_plarre(E2, work, iwork, rcount, rdispl);
return(0);
}
/* Routine to compute eigenvalues */
int plarre(proc_t *procinfo, char *jobz, char *range, in_t *Dstruct,
val_t *Wstruct, tol_t *tolstruct, int *nzp, int *offsetp)
{
/* input variables */
int nproc = procinfo->nproc;
bool wantZ = (jobz[0] == 'V' || jobz[0] == 'v');
bool cntval = (jobz[0] == 'C' || jobz[0] == 'c');
int n = Dstruct->n;
double *restrict D = Dstruct->D;
double *restrict E = Dstruct->E;
int *restrict isplit = Dstruct->isplit;
double *vl = Wstruct->vl;
double *vu = Wstruct->vu;
int *il = Wstruct->il;
int *iu = Wstruct->iu;
double *restrict W = Wstruct->W;
double *restrict Werr = Wstruct->Werr;
double *restrict Wgap = Wstruct->Wgap;
int *restrict Windex = Wstruct->Windex;
int *restrict iblock = Wstruct->iblock;
double *restrict gersch = Wstruct->gersch;
/* constants */
int IZERO = 0, IONE = 1;
double DZERO = 0.0;
/* work space */
double *E2;
double *work;
int *iwork;
/* compute geschgorin disks and spectral diameter */
double gl, gu, eold, emax, eabs;
/* compute splitting points */
int bl_begin, bl_end, bl_size;
/* distribute work among processes */
int ifirst, ilast, ifirst_tmp, ilast_tmp;
int chunk, isize, iil, iiu;
/* gather results */
int *rcount, *rdispl;
/* others */
int info, i, j, jbl, idummy;
double tmp1, dummy;
bool sorted;
enum range_enum {allrng=1, valrng=2, indrng=3} irange;
double intervals[2];
int negcounts[2];
double sigma;
if (range[0] == 'A' || range[0] == 'a') {
irange = allrng;
} else if (range[0] == 'V' || range[0] == 'v') {
irange = valrng;
} else if (range[0] == 'I' || range[0] == 'i') {
irange = indrng;
} else {
return 1;
}
/* allocate work space */
E2 = (double *) malloc( n * sizeof(double) );
assert(E2 != NULL);
work = (double *) malloc( 4*n * sizeof(double) );
assert(work != NULL);
iwork = (int *) malloc( 3*n * sizeof(int) );
assert(iwork != NULL);
rcount = (int *) malloc( nproc * sizeof(int) );
assert(rcount != NULL);
rdispl = (int *) malloc( nproc * sizeof(int) );
assert(rdispl != NULL);
/* Compute square of off-diagonal elements */
for (i=0; i<n-1; i++) {
E2[i] = E[i]*E[i];
}
/* compute geschgorin disks and spectral diameter */
gl = D[0];
gu = D[0];
eold = 0.0;
emax = 0.0;
E[n-1] = 0.0;
for (i=0; i<n; i++) {
eabs = fabs(E[i]);
if (eabs >= emax) emax = eabs;
tmp1 = eabs + eold;
gersch[2*i] = D[i] - tmp1;
gl = fmin(gl, gersch[2*i]);
gersch[2*i+1] = D[i] + tmp1;
gu = fmax(gu, gersch[2*i+1]);
eold = eabs;
}
/* min. pivot allowed in the Sturm sequence of T */
tolstruct->pivmin = DBL_MIN * fmax(1.0, emax*emax);
/* estimate of spectral diameter */
Dstruct->spdiam = gu - gl;
/* compute splitting points with threshold "split" */
odrra(&n, D, E, E2, &tolstruct->split, &Dstruct->spdiam,
&Dstruct->nsplit, isplit, &info);
assert(info == 0);
if (irange == allrng || irange == indrng) {
*vl = gl;
*vu = gu;
}
/* set eigenvalue indices in case of all or subset by value has
* to be computed; thereby convert all problem to subset by index
* computation */
if (irange == allrng) {
*il = 1;
*iu = n;
} else if (irange == valrng) {
intervals[0] = *vl; intervals[1] = *vu;
/* find negcount at boundaries 'vl' and 'vu';
* needs work of dim(n) and iwork of dim(n) */
odebz(&IONE, &IZERO, &n, &IONE, &IONE, &IZERO,
&DZERO, &DZERO, &tolstruct->pivmin, D, E, E2, &idummy,
intervals, &dummy, &idummy, negcounts, work, iwork, &info);
assert(info == 0);
/* update negcounts of whole matrix with negcounts found for block */
*il = negcounts[0] + 1;
*iu = negcounts[1];
}
if (cntval && irange == valrng) {
/* clean up and return */
*nzp = iceil(*iu-*il+1, nproc);
clean_up_plarre(E2, work, iwork, rcount, rdispl);
return 0;
}
/* loop over unreduced blocks */
bl_begin = 0;
for (jbl=0; jbl<Dstruct->nsplit; jbl++) {
bl_end = isplit[jbl] - 1;
bl_size = bl_end - bl_begin + 1;
/* deal with 1x1 block immediately */
if (bl_size == 1) {
E[bl_end] = 0.0;
W[bl_begin] = D[bl_begin];
Werr[bl_begin] = 0.0;
Werr[bl_begin] = 0.0;
iblock[bl_begin] = jbl + 1;
Windex[bl_begin] = 1;
bl_begin = bl_end + 1;
continue;
}
/* Indix range of block */
iil = 1;
iiu = bl_size;
/* each process computes a subset of the eigenvalues of the block */
ifirst_tmp = iil;
for (i=0; i<nproc; i++) {
chunk = (iiu-iil+1)/nproc + (i < (iiu-iil+1)%nproc);
if (i == nproc-1) {
ilast_tmp = iiu;
} else {
ilast_tmp = ifirst_tmp + chunk - 1;
ilast_tmp = imin(ilast_tmp, iiu);
}
if (i == procinfo->pid) {
ifirst = ifirst_tmp;
ilast = ilast_tmp;
isize = ilast - ifirst + 1;
*offsetp = ifirst - iil;
*nzp = isize;
}
rcount[i] = ilast_tmp - ifirst_tmp + 1;
rdispl[i] = ifirst_tmp - iil;
ifirst_tmp = ilast_tmp + 1;
ifirst_tmp = imin(ifirst_tmp, iiu + 1);
}
/* approximate eigenvalues of input assigned to process */
if (isize != 0) {
info = eigval_approx_proc(procinfo, ifirst, ilast,
bl_size, &D[bl_begin], &E[bl_begin], &E2[bl_begin],
&Windex[bl_begin], &iblock[bl_begin], &gersch[2*bl_begin],
tolstruct, &W[bl_begin], &Werr[bl_begin], &Wgap[bl_begin],
work, iwork);
assert(info == 0);
}
/* compute root representation of block */
info = eigval_root_proc(procinfo, ifirst, ilast,
bl_size, &D[bl_begin], &E[bl_begin], &E2[bl_begin],
&Windex[bl_begin], &iblock[bl_begin], &gersch[2*bl_begin],
tolstruct, &W[bl_begin], &Werr[bl_begin], &Wgap[bl_begin],
work, iwork);
assert(info == 0);
/* refine eigenvalues assigned to process w.r.t root */
if (isize != 0) {
info = eigval_refine_proc(procinfo, ifirst, ilast,
bl_size, &D[bl_begin], &E[bl_begin], &E2[bl_begin],
&Windex[bl_begin], &iblock[bl_begin], &gersch[2*bl_begin],
tolstruct, &W[bl_begin], &Werr[bl_begin], &Wgap[bl_begin],
work, iwork);
assert(info == 0);
}
memcpy(work, &W[bl_begin], isize * sizeof(double) );
MPI_Allgatherv(work, isize, MPI_DOUBLE, &W[bl_begin], rcount, rdispl,
MPI_DOUBLE, procinfo->comm);
memcpy(work, &Werr[bl_begin], isize * sizeof(double) );
MPI_Allgatherv(work, isize, MPI_DOUBLE, &Werr[bl_begin], rcount, rdispl,
MPI_DOUBLE, procinfo->comm);
memcpy(iwork, &Windex[bl_begin], isize * sizeof(int) );
MPI_Allgatherv(iwork, isize, MPI_INT, &Windex[bl_begin], rcount, rdispl,
MPI_INT, procinfo->comm);
/* Ensure that within block eigenvalues sorted */
sorted = false;
while (sorted == false) {
sorted = true;
for (j=bl_begin; j < bl_end; j++) {
if (W[j+1] < W[j]) {
sorted = false;
tmp1 = W[j];
W[j] = W[j+1];
W[j+1] = tmp1;
tmp1 = Werr[j];
Werr[j] = Werr[j+1];
Werr[j+1] = tmp1;
}
}
}
/* Set indices index correctly */
for (j=bl_begin; j <= bl_end; j++)
iblock[j] = jbl + 1;
/* Recompute gaps within the blocks */
for (j = bl_begin; j < bl_end; j++) {
Wgap[j] = fmax(0.0, (W[j+1] - Werr[j+1]) - (W[j] + Werr[j]) );
}
sigma = E[bl_end];
Wgap[bl_end] = fmax(0.0, (gu - sigma) - (W[bl_end] + Werr[bl_end]) );
/* Compute UNSHIFTED eigenvalues */
if (!wantZ) {
sigma = E[bl_end];
for (i=bl_begin; i<=bl_end; i++) {
W[i] += sigma;
}
}
/* Proceed with next block */
bl_begin = bl_end + 1;
}
/* end of loop over unreduced blocks */
/* free memory */
clean_up_plarre(E2, work, iwork, rcount, rdispl);
return 0;
}
