Actual source code: genqmd.c

  1: #define PETSCMAT_DLL

  3: /* genqmd.f -- translated by f2c (version 19931217).*/

 5:  #include petsc.h

  7: /******************************************************************/
  8: /***********    GENQMD ..... QUOT MIN DEGREE ORDERING    **********/
  9: /******************************************************************/
 10: /*    PURPOSE - THIS ROUTINE IMPLEMENTS THE MINIMUM DEGREE        */
 11: /*       ALGORITHM.  IT MAKES USE OF THE IMPLICIT REPRESENT-      */
 12: /*       ATION OF THE ELIMINATION GRAPHS BY QUOTIENT GRAPHS,      */
 13: /*       AND THE NOTION OF INDISTINGUISHABLE NODES.               */
 14: /*       CAUTION - THE ADJACENCY VECTOR ADJNCY WILL BE            */
 15: /*       DESTROYED.                                               */
 16: /*                                                                */
 17: /*    INPUT PARAMETERS -                                          */
 18: /*       NEQNS - NUMBER OF EQUATIONS.                             */
 19: /*       (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE.                */
 20: /*                                                                */
 21: /*    OUTPUT PARAMETERS -                                         */
 22: /*       PERM - THE MINIMUM DEGREE ORDERING.                      */
 23: /*       INVP - THE INVERSE OF PERM.                              */
 24: /*                                                                */
 25: /*    WORKING PARAMETERS -                                        */
 26: /*       DEG - THE DEGREE VECTOR. DEG(I) IS NEGATIVE MEANS        */
 27: /*              NODE I HAS BEEN NUMBERED.                         */
 28: /*       MARKER - A MARKER VECTOR, WHERE MARKER(I) IS             */
 29: /*              NEGATIVE MEANS NODE I HAS BEEN MERGED WITH        */
 30: /*              ANOTHER NODE AND THUS CAN BE IGNORED.             */
 31: /*       RCHSET - VECTOR USED FOR THE REACHABLE SET.              */
 32: /*       NBRHD - VECTOR USED FOR THE NEIGHBORHOOD SET.            */
 33: /*       QSIZE - VECTOR USED TO STORE THE SIZE OF                 */
 34: /*              INDISTINGUISHABLE SUPERNODES.                     */
 35: /*       QLINK - VECTOR TO STORE INDISTINGUISHABLE NODES,         */
 36: /*              I, QLINK(I), QLINK(QLINK(I)) ... ARE THE          */
 37: /*              MEMBERS OF THE SUPERNODE REPRESENTED BY I.        */
 38: /*                                                                */
 39: /*    PROGRAM SUBROUTINES -                                       */
 40: /*       QMDRCH, QMDQT, QMDUPD.                                   */
 41: /*                                                                */
 42: /******************************************************************/
 43: /*                                                                */
 44: /*                                                                */
 47: PetscErrorCode SPARSEPACKgenqmd(PetscInt *neqns, PetscInt *xadj, PetscInt *adjncy, 
 48:         PetscInt *perm, PetscInt *invp, PetscInt *deg, PetscInt *marker, PetscInt *
 49:         rchset, PetscInt *nbrhd, PetscInt *qsize, PetscInt *qlink, PetscInt *nofsub)
 50: {
 51:     /* System generated locals */
 52:     PetscInt i__1;

 54:     /* Local variables */
 55:     PetscInt ndeg, irch, node, nump1, j, inode;
 56:     EXTERN PetscErrorCode SPARSEPACKqmdqt(PetscInt*, PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *);
 57:     PetscInt ip, np, mindeg, search;
 58:     EXTERN PetscErrorCode SPARSEPACKqmdrch(PetscInt*, PetscInt *, PetscInt *,
 59:               PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *),
 60:            SPARSEPACKqmdupd(PetscInt*, PetscInt *, PetscInt *, PetscInt *, PetscInt *,
 61:               PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *);
 62:     PetscInt nhdsze, nxnode, rchsze, thresh, num;

 64: /*       INITIALIZE DEGREE VECTOR AND OTHER WORKING VARIABLES.   */

 67:     /* Parameter adjustments */
 68:     --qlink;
 69:     --qsize;
 70:     --nbrhd;
 71:     --rchset;
 72:     --marker;
 73:     --deg;
 74:     --invp;
 75:     --perm;
 76:     --adjncy;
 77:     --xadj;

 79:     mindeg = *neqns;
 80:     *nofsub = 0;
 81:     i__1 = *neqns;
 82:     for (node = 1; node <= i__1; ++node) {
 83:         perm[node] = node;
 84:         invp[node] = node;
 85:         marker[node] = 0;
 86:         qsize[node] = 1;
 87:         qlink[node] = 0;
 88:         ndeg = xadj[node + 1] - xadj[node];
 89:         deg[node] = ndeg;
 90:         if (ndeg < mindeg) {
 91:             mindeg = ndeg;
 92:         }
 93:     }
 94:     num = 0;
 95: /*       PERFORM THRESHOLD SEARCH TO GET A NODE OF MIN DEGREE.   */
 96: /*       VARIABLE SEARCH POINTS TO WHERE SEARCH SHOULD START.    */
 97: L200:
 98:     search = 1;
 99:     thresh = mindeg;
100:     mindeg = *neqns;
101: L300:
102:     nump1 = num + 1;
103:     if (nump1 > search) {
104:         search = nump1;
105:     }
106:     i__1 = *neqns;
107:     for (j = search; j <= i__1; ++j) {
108:         node = perm[j];
109:         if (marker[node] < 0) {
110:             goto L400;
111:         }
112:         ndeg = deg[node];
113:         if (ndeg <= thresh) {
114:             goto L500;
115:         }
116:         if (ndeg < mindeg) {
117:             mindeg = ndeg;
118:         }
119: L400:
120:         ;
121:     }
122:     goto L200;
123: /*          NODE HAS MINIMUM DEGREE. FIND ITS REACHABLE SETS BY    */
124: /*          CALLING QMDRCH.                                        */
125: L500:
126:     search = j;
127:     *nofsub += deg[node];
128:     marker[node] = 1;
129:     SPARSEPACKqmdrch(&node, &xadj[1], &adjncy[1], &deg[1], &marker[1], &rchsze, &
130:             rchset[1], &nhdsze, &nbrhd[1]);
131: /*          ELIMINATE ALL NODES INDISTINGUISHABLE FROM NODE.       */
132: /*          THEY ARE GIVEN BY NODE, QLINK(NODE), ....              */
133:     nxnode = node;
134: L600:
135:     ++num;
136:     np = invp[nxnode];
137:     ip = perm[num];
138:     perm[np] = ip;
139:     invp[ip] = np;
140:     perm[num] = nxnode;
141:     invp[nxnode] = num;
142:     deg[nxnode] = -1;
143:     nxnode = qlink[nxnode];
144:     if (nxnode > 0) {
145:         goto L600;
146:     }
147:     if (rchsze <= 0) {
148:         goto L800;
149:     }
150: /*             UPDATE THE DEGREES OF THE NODES IN THE REACHABLE     */
151: /*             SET AND IDENTIFY INDISTINGUISHABLE NODES.            */
152:     SPARSEPACKqmdupd(&xadj[1], &adjncy[1], &rchsze, &rchset[1], &deg[1], &qsize[1], &
153:             qlink[1], &marker[1], &rchset[rchsze + 1], &nbrhd[nhdsze + 1]);
154: /*             RESET MARKER VALUE OF NODES IN REACH SET.            */
155: /*             UPDATE THRESHOLD VALUE FOR CYCLIC SEARCH.            */
156: /*             ALSO CALL QMDQT TO FORM NEW QUOTIENT GRAPH.          */
157:     marker[node] = 0;
158:     i__1 = rchsze;
159:     for (irch = 1; irch <= i__1; ++irch) {
160:         inode = rchset[irch];
161:         if (marker[inode] < 0) {
162:             goto L700;
163:         }
164:         marker[inode] = 0;
165:         ndeg = deg[inode];
166:         if (ndeg < mindeg) {
167:             mindeg = ndeg;
168:         }
169:         if (ndeg > thresh) {
170:             goto L700;
171:         }
172:         mindeg = thresh;
173:         thresh = ndeg;
174:         search = invp[inode];
175: L700:
176:         ;
177:     }
178:     if (nhdsze > 0) {
179:         SPARSEPACKqmdqt(&node, &xadj[1], &adjncy[1], &marker[1], &rchsze, &rchset[1], &
180:                 nbrhd[1]);
181:     }
182: L800:
183:     if (num < *neqns) {
184:         goto L300;
185:     }
186:     return(0);
187: }