PetscErrorCode SPARSEPACKgenqmd(const PetscInt *neqns,const PetscInt *xadj,const PetscInt *adjncy,
PetscInt *perm, PetscInt *invp, PetscInt *deg, PetscInt *marker,
PetscInt *rchset, PetscInt *nbrhd, PetscInt *qsize, PetscInt *qlink, PetscInt *nofsub)
{
/* System generated locals */
PetscInt i__1;
/* Local variables */
PetscInt ndeg, irch, node, nump1, j, inode;
PetscInt ip, np, mindeg, search;
PetscInt nhdsze, nxnode, rchsze, thresh, num;
/* INITIALIZE DEGREE VECTOR AND OTHER WORKING VARIABLES. */
PetscFunctionBegin;
/* Parameter adjustments */
--qlink;
--qsize;
--nbrhd;
--rchset;
--marker;
--deg;
--invp;
--perm;
--adjncy;
--xadj;
mindeg = *neqns;
*nofsub = 0;
i__1 = *neqns;
for (node = 1; node <= i__1; ++node) {
perm[node] = node;
invp[node] = node;
marker[node] = 0;
qsize[node] = 1;
qlink[node] = 0;
ndeg = xadj[node + 1] - xadj[node];
deg[node] = ndeg;
if (ndeg < mindeg) {
mindeg = ndeg;
}
}
num = 0;
/* PERFORM THRESHOLD SEARCH TO GET A NODE OF MIN DEGREE. */
/* VARIABLE SEARCH POINTS TO WHERE SEARCH SHOULD START. */
L200:
search = 1;
thresh = mindeg;
mindeg = *neqns;
L300:
nump1 = num + 1;
if (nump1 > search) {
search = nump1;
}
i__1 = *neqns;
for (j = search; j <= i__1; ++j) {
node = perm[j];
if (marker[node] < 0) {
goto L400;
}
ndeg = deg[node];
if (ndeg <= thresh) {
goto L500;
}
if (ndeg < mindeg) {
mindeg = ndeg;
}
L400:
;
}
goto L200;
/* NODE HAS MINIMUM DEGREE. FIND ITS REACHABLE SETS BY */
/* CALLING QMDRCH. */
L500:
search = j;
*nofsub += deg[node];
marker[node] = 1;
SPARSEPACKqmdrch(&node, &xadj[1], &adjncy[1], °[1], &marker[1], &rchsze, &
rchset[1], &nhdsze, &nbrhd[1]);
/* ELIMINATE ALL NODES INDISTINGUISHABLE FROM NODE. */
/* THEY ARE GIVEN BY NODE, QLINK(NODE), .... */
nxnode = node;
L600:
++num;
np = invp[nxnode];
ip = perm[num];
perm[np] = ip;
invp[ip] = np;
perm[num] = nxnode;
invp[nxnode] = num;
deg[nxnode] = -1;
nxnode = qlink[nxnode];
if (nxnode > 0) {
goto L600;
}
if (rchsze <= 0) {
goto L800;
}
/* UPDATE THE DEGREES OF THE NODES IN THE REACHABLE */
/* SET AND IDENTIFY INDISTINGUISHABLE NODES. */
SPARSEPACKqmdupd(&xadj[1], &adjncy[1], &rchsze, &rchset[1], °[1], &qsize[1], &
qlink[1], &marker[1], &rchset[rchsze + 1], &nbrhd[nhdsze + 1]);
/* RESET MARKER VALUE OF NODES IN REACH SET. */
/* UPDATE THRESHOLD VALUE FOR CYCLIC SEARCH. */
/* ALSO CALL QMDQT TO FORM NEW QUOTIENT GRAPH. */
marker[node] = 0;
i__1 = rchsze;
for (irch = 1; irch <= i__1; ++irch) {
inode = rchset[irch];
if (marker[inode] < 0) {
goto L700;
}
marker[inode] = 0;
ndeg = deg[inode];
if (ndeg < mindeg) {
mindeg = ndeg;
}
if (ndeg > thresh) {
goto L700;
}
mindeg = thresh;
thresh = ndeg;
search = invp[inode];
L700:
;
}
if (nhdsze > 0) {
SPARSEPACKqmdqt(&node, &xadj[1], &adjncy[1], &marker[1], &rchsze, &rchset[1], &
nbrhd[1]);
}
L800:
if (num < *neqns) {
goto L300;
}
PetscFunctionReturn(0);
}
PetscErrorCode SPARSEPACKqmdupd(PetscInt *xadj, PetscInt *adjncy, PetscInt *nlist,
PetscInt *list, PetscInt *deg, PetscInt *qsize, PetscInt *qlink, PetscInt *
marker, PetscInt *rchset, PetscInt *nbrhd)
{
/* System generated locals */
PetscInt i__1, i__2;
/* Local variables */
PetscInt inhd, irch, node, mark, j, inode, nabor, jstop, jstrt, il;
extern PetscErrorCode SPARSEPACKqmdrch(PetscInt*, PetscInt *, PetscInt *,
PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *),
SPARSEPACKqmdmrg(PetscInt*, PetscInt *, PetscInt *, PetscInt *, PetscInt *,
PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *);
PetscInt nhdsze, rchsze, deg0, deg1;
/* FIND ALL ELIMINATED SUPERNODES THAT ARE ADJACENT*/
/* TO SOME NODES IN THE GIVEN LIST. PUT THEM INTO.*/
/* (NHDSZE, NBRHD). DEG0 CONTAINS THE NUMBER OF*/
/* NODES IN THE LIST.*/
PetscFunctionBegin;
/* Parameter adjustments */
--nbrhd;
--rchset;
--marker;
--qlink;
--qsize;
--deg;
--list;
--adjncy;
--xadj;
if (*nlist <= 0) {
PetscFunctionReturn(0);
}
deg0 = 0;
nhdsze = 0;
i__1 = *nlist;
for (il = 1; il <= i__1; ++il) {
node = list[il];
deg0 += qsize[node];
jstrt = xadj[node];
jstop = xadj[node + 1] - 1;
i__2 = jstop;
for (j = jstrt; j <= i__2; ++j) {
nabor = adjncy[j];
if (marker[nabor] != 0 || deg[nabor] >= 0) {
goto L100;
}
marker[nabor] = -1;
++nhdsze;
nbrhd[nhdsze] = nabor;
L100:
;
}
}
/* MERGE INDISTINGUISHABLE NODES IN THE LIST BY*/
/* CALLING THE SUBROUTINE QMDMRG.*/
if (nhdsze > 0) {
SPARSEPACKqmdmrg(&xadj[1], &adjncy[1], °[1], &qsize[1], &qlink[1], &marker[
1], °0, &nhdsze, &nbrhd[1], &rchset[1], &nbrhd[nhdsze + 1]);
}
/* FIND THE NEW DEGREES OF THE NODES THAT HAVE NOT BEEN*/
/* MERGED.*/
i__1 = *nlist;
for (il = 1; il <= i__1; ++il) {
node = list[il];
mark = marker[node];
if (mark > 1 || mark < 0) {
goto L600;
}
marker[node] = 2;
SPARSEPACKqmdrch(&node, &xadj[1], &adjncy[1], °[1], &marker[1], &rchsze, &
rchset[1], &nhdsze, &nbrhd[1]);
deg1 = deg0;
if (rchsze <= 0) {
goto L400;
}
i__2 = rchsze;
for (irch = 1; irch <= i__2; ++irch) {
inode = rchset[irch];
deg1 += qsize[inode];
marker[inode] = 0;
}
L400:
deg[node] = deg1 - 1;
if (nhdsze <= 0) {
goto L600;
}
i__2 = nhdsze;
for (inhd = 1; inhd <= i__2; ++inhd) {
inode = nbrhd[inhd];
marker[inode] = 0;
}
L600:
;
}
PetscFunctionReturn(0);
}
