1 /* genqmd.f -- translated by f2c (version 19931217).*/
2
3 #include <petscsys.h>
4 #include <petsc/private/matorderimpl.h>
5
6 /******************************************************************/
7 /*********** GENQMD ..... QUOT MIN DEGREE ORDERING **********/
8 /******************************************************************/
9 /* PURPOSE - THIS ROUTINE IMPLEMENTS THE MINIMUM DEGREE */
10 /* ALGORITHM. IT MAKES USE OF THE IMPLICIT REPRESENT- */
11 /* ATION OF THE ELIMINATION GRAPHS BY QUOTIENT GRAPHS, */
12 /* AND THE NOTION OF INDISTINGUISHABLE NODES. */
13 /* CAUTION - THE ADJACENCY VECTOR ADJNCY WILL BE */
14 /* DESTROYED. */
15 /* */
16 /* INPUT PARAMETERS - */
17 /* NEQNS - NUMBER OF EQUATIONS. */
18 /* (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. */
19 /* */
20 /* OUTPUT PARAMETERS - */
21 /* PERM - THE MINIMUM DEGREE ORDERING. */
22 /* INVP - THE INVERSE OF PERM. */
23 /* */
24 /* WORKING PARAMETERS - */
25 /* DEG - THE DEGREE VECTOR. DEG(I) IS NEGATIVE MEANS */
26 /* NODE I HAS BEEN NUMBERED. */
27 /* MARKER - A MARKER VECTOR, WHERE MARKER(I) IS */
28 /* NEGATIVE MEANS NODE I HAS BEEN MERGED WITH */
29 /* ANOTHER NODE AND THUS CAN BE IGNORED. */
30 /* RCHSET - VECTOR USED FOR THE REACHABLE SET. */
31 /* NBRHD - VECTOR USED FOR THE NEIGHBORHOOD SET. */
32 /* QSIZE - VECTOR USED TO STORE THE SIZE OF */
33 /* INDISTINGUISHABLE SUPERNODES. */
34 /* QLINK - VECTOR TO STORE INDISTINGUISHABLE NODES, */
35 /* I, QLINK(I), QLINK(QLINK(I)) ... ARE THE */
36 /* MEMBERS OF THE SUPERNODE REPRESENTED BY I. */
37 /* */
38 /* PROGRAM SUBROUTINES - */
39 /* QMDRCH, QMDQT, QMDUPD. */
40 /* */
41 /******************************************************************/
42 /* */
43 /* */
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)44 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)
45 {
46 /* System generated locals */
47 PetscInt i__1;
48
49 /* Local variables */
50 PetscInt ndeg, irch, node, nump1, j, inode;
51 PetscInt ip, np, mindeg, search;
52 PetscInt nhdsze, nxnode, rchsze, thresh, num;
53
54 /* INITIALIZE DEGREE VECTOR AND OTHER WORKING VARIABLES. */
55
56 PetscFunctionBegin;
57 /* Parameter adjustments */
58 --qlink;
59 --qsize;
60 --nbrhd;
61 --rchset;
62 --marker;
63 --deg;
64 --invp;
65 --perm;
66 --adjncy;
67 --xadj;
68
69 mindeg = *neqns;
70 *nofsub = 0;
71 i__1 = *neqns;
72 for (node = 1; node <= i__1; ++node) {
73 perm[node] = node;
74 invp[node] = node;
75 marker[node] = 0;
76 qsize[node] = 1;
77 qlink[node] = 0;
78 ndeg = xadj[node + 1] - xadj[node];
79 deg[node] = ndeg;
80 if (ndeg < mindeg) mindeg = ndeg;
81 }
82 num = 0;
83 /* PERFORM THRESHOLD SEARCH TO GET A NODE OF MIN DEGREE. */
84 /* VARIABLE SEARCH POINTS TO WHERE SEARCH SHOULD START. */
85 L200:
86 search = 1;
87 thresh = mindeg;
88 mindeg = *neqns;
89 L300:
90 nump1 = num + 1;
91 if (nump1 > search) search = nump1;
92 i__1 = *neqns;
93 for (j = search; j <= i__1; ++j) {
94 node = perm[j];
95 if (marker[node] < 0) goto L400;
96 ndeg = deg[node];
97 if (ndeg <= thresh) goto L500;
98 if (ndeg < mindeg) mindeg = ndeg;
99 L400:;
100 }
101 goto L200;
102 /* NODE HAS MINIMUM DEGREE. FIND ITS REACHABLE SETS BY */
103 /* CALLING QMDRCH. */
104 L500:
105 search = j;
106 *nofsub += deg[node];
107 marker[node] = 1;
108 PetscCall(SPARSEPACKqmdrch(&node, &xadj[1], &adjncy[1], °[1], &marker[1], &rchsze, &rchset[1], &nhdsze, &nbrhd[1]));
109 /* ELIMINATE ALL NODES INDISTINGUISHABLE FROM NODE. */
110 /* THEY ARE GIVEN BY NODE, QLINK(NODE), .... */
111 nxnode = node;
112 L600:
113 ++num;
114 np = invp[nxnode];
115 ip = perm[num];
116 perm[np] = ip;
117 invp[ip] = np;
118 perm[num] = nxnode;
119 invp[nxnode] = num;
120 deg[nxnode] = -1;
121 nxnode = qlink[nxnode];
122 if (nxnode > 0) goto L600;
123 if (rchsze <= 0) goto L800;
124
125 /* UPDATE THE DEGREES OF THE NODES IN THE REACHABLE */
126 /* SET AND IDENTIFY INDISTINGUISHABLE NODES. */
127 PetscCall(SPARSEPACKqmdupd(&xadj[1], &adjncy[1], &rchsze, &rchset[1], °[1], &qsize[1], &qlink[1], &marker[1], &rchset[rchsze + 1], &nbrhd[nhdsze + 1]));
128
129 /* RESET MARKER VALUE OF NODES IN REACH SET. */
130 /* UPDATE THRESHOLD VALUE FOR CYCLIC SEARCH. */
131 /* ALSO CALL QMDQT TO FORM NEW QUOTIENT GRAPH. */
132 marker[node] = 0;
133 i__1 = rchsze;
134 for (irch = 1; irch <= i__1; ++irch) {
135 inode = rchset[irch];
136 if (marker[inode] < 0) goto L700;
137
138 marker[inode] = 0;
139 ndeg = deg[inode];
140 if (ndeg < mindeg) mindeg = ndeg;
141 if (ndeg > thresh) goto L700;
142 mindeg = thresh;
143 thresh = ndeg;
144 search = invp[inode];
145 L700:;
146 }
147 if (nhdsze > 0) PetscCall(SPARSEPACKqmdqt(&node, &xadj[1], &adjncy[1], &marker[1], &rchsze, &rchset[1], &nbrhd[1]));
148 L800:
149 if (num < *neqns) goto L300;
150 PetscFunctionReturn(PETSC_SUCCESS);
151 }
152