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