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 /* */ 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