Actual source code: qmdmrg.c
2: /* qmdmrg.f -- translated by f2c (version 19931217).*/
4: #include <petscsys.h>
6: /******************************************************************/
7: /*********** QMDMRG ..... QUOT MIN DEG MERGE ************/
8: /******************************************************************/
9: /* PURPOSE - THIS ROUTINE MERGES INDISTINGUISHABLE NODES IN */
10: /* THE MINIMUM DEGREE ORDERING ALGORITHM. */
11: /* IT ALSO COMPUTES THE NEW DEGREES OF THESE */
12: /* NEW SUPERNODES. */
13: /* */
14: /* INPUT PARAMETERS - */
15: /* (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. */
16: /* DEG0 - THE NUMBER OF NODES IN THE GIVEN SET. */
17: /* (NHDSZE, NBRHD) - THE SET OF ELIMINATED SUPERNODES */
18: /* ADJACENT TO SOME NODES IN THE SET. */
19: /* */
20: /* UPDATED PARAMETERS - */
21: /* DEG - THE DEGREE VECTOR. */
22: /* QSIZE - SIZE OF INDISTINGUISHABLE NODES. */
23: /* QLINK - LINKED LIST FOR INDISTINGUISHABLE NODES. */
24: /* MARKER - THE GIVEN SET IS GIVEN BY THOSE NODES WITH */
25: /* MARKER VALUE SET TO 1. THOSE NODES WITH DEGREE */
26: /* UPDATED WILL HAVE MARKER VALUE SET TO 2. */
27: /* */
28: /* WORKING PARAMETERS - */
29: /* RCHSET - THE REACHABLE SET. */
30: /* OVRLP - TEMP VECTOR TO STORE THE INTERSECTION OF TWO */
31: /* REACHABLE SETS. */
32: /* */
33: /*****************************************************************/
36: PetscErrorCode SPARSEPACKqmdmrg(PetscInt *xadj, PetscInt *adjncy, PetscInt *deg,
37: PetscInt *qsize, PetscInt *qlink, PetscInt *marker, PetscInt *deg0,
38: PetscInt *nhdsze, PetscInt *nbrhd, PetscInt *rchset, PetscInt *ovrlp)
39: {
40: /* System generated locals */
41: PetscInt i__1, i__2, i__3;
43: /* Local variables */
44: PetscInt head, inhd, irch, node, mark, ilink, root, j, lnode, nabor,
45: jstop, jstrt, rchsze, mrgsze, novrlp, iov, deg1;
48: /* Parameter adjustments */
49: --ovrlp;
50: --rchset;
51: --nbrhd;
52: --marker;
53: --qlink;
54: --qsize;
55: --deg;
56: --adjncy;
57: --xadj;
59: if (*nhdsze <= 0) {
60: return(0);
61: }
62: i__1 = *nhdsze;
63: for (inhd = 1; inhd <= i__1; ++inhd) {
64: root = nbrhd[inhd];
65: marker[root] = 0;
66: }
67: /* LOOP THROUGH EACH ELIMINATED SUPERNODE IN THE SET */
68: /* (NHDSZE, NBRHD). */
69: i__1 = *nhdsze;
70: for (inhd = 1; inhd <= i__1; ++inhd) {
71: root = nbrhd[inhd];
72: marker[root] = -1;
73: rchsze = 0;
74: novrlp = 0;
75: deg1 = 0;
76: L200:
77: jstrt = xadj[root];
78: jstop = xadj[root + 1] - 1;
79: /* DETERMINE THE REACHABLE SET AND ITS PETSCINTERSECT- */
80: /* ION WITH THE INPUT REACHABLE SET. */
81: i__2 = jstop;
82: for (j = jstrt; j <= i__2; ++j) {
83: nabor = adjncy[j];
84: root = -nabor;
85: if (nabor < 0) {
86: goto L200;
87: } else if (!nabor) {
88: goto L700;
89: } else {
90: goto L300;
91: }
92: L300:
93: mark = marker[nabor];
94: if (mark < 0) {
95: goto L600;
96: } else if (!mark) {
97: goto L400;
98: } else {
99: goto L500;
100: }
101: L400:
102: ++rchsze;
103: rchset[rchsze] = nabor;
104: deg1 += qsize[nabor];
105: marker[nabor] = 1;
106: goto L600;
107: L500:
108: if (mark > 1) {
109: goto L600;
110: }
111: ++novrlp;
112: ovrlp[novrlp] = nabor;
113: marker[nabor] = 2;
114: L600:
115: ;
116: }
117: /* FROM THE OVERLAPPED SET, DETERMINE THE NODES */
118: /* THAT CAN BE MERGED TOGETHER. */
119: L700:
120: head = 0;
121: mrgsze = 0;
122: i__2 = novrlp;
123: for (iov = 1; iov <= i__2; ++iov) {
124: node = ovrlp[iov];
125: jstrt = xadj[node];
126: jstop = xadj[node + 1] - 1;
127: i__3 = jstop;
128: for (j = jstrt; j <= i__3; ++j) {
129: nabor = adjncy[j];
130: if (marker[nabor] != 0) {
131: goto L800;
132: }
133: marker[node] = 1;
134: goto L1100;
135: L800:
136: ;
137: }
138: /* NODE BELONGS TO THE NEW MERGED SUPERNODE. */
139: /* UPDATE THE VECTORS QLINK AND QSIZE. */
140: mrgsze += qsize[node];
141: marker[node] = -1;
142: lnode = node;
143: L900:
144: ilink = qlink[lnode];
145: if (ilink <= 0) {
146: goto L1000;
147: }
148: lnode = ilink;
149: goto L900;
150: L1000:
151: qlink[lnode] = head;
152: head = node;
153: L1100:
154: ;
155: }
156: if (head <= 0) {
157: goto L1200;
158: }
159: qsize[head] = mrgsze;
160: deg[head] = *deg0 + deg1 - 1;
161: marker[head] = 2;
162: /* RESET MARKER VALUES. */
163: L1200:
164: root = nbrhd[inhd];
165: marker[root] = 0;
166: if (rchsze <= 0) {
167: goto L1400;
168: }
169: i__2 = rchsze;
170: for (irch = 1; irch <= i__2; ++irch) {
171: node = rchset[irch];
172: marker[node] = 0;
173: }
174: L1400:
175: ;
176: }
177: return(0);
178: }