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: }