1 /* qmdrch.f -- translated by f2c (version 19931217).*/ 2 3 #include <petscsys.h> 4 #include <petsc/private/matorderimpl.h> 5 6 /*****************************************************************/ 7 /********** QMDRCH ..... QUOT MIN DEG REACH SET ***********/ 8 /*****************************************************************/ 9 10 /* PURPOSE - THIS SUBROUTINE DETERMINES THE REACHABLE SET OF*/ 11 /* A NODE THROUGH A GIVEN SUBSET. THE ADJACENCY STRUCTURE*/ 12 /* IS ASSUMED TO BE STORED IN A QUOTIENT GRAPH FORMAT.*/ 13 14 /* INPUT PARAMETERS -*/ 15 /* ROOT - THE GIVEN NODE NOT IN THE SUBSET.*/ 16 /* (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE PAIR.*/ 17 /* DEG - THE DEGREE VECTOR. DEG(I) LT 0 MEANS THE NODE*/ 18 /* BELONGS TO THE GIVEN SUBSET.*/ 19 20 /* OUTPUT PARAMETERS -*/ 21 /* (RCHSZE, RCHSET) - THE REACHABLE SET.*/ 22 /* (NHDSZE, NBRHD) - THE NEIGHBORHOOD SET.*/ 23 24 /* UPDATED PARAMETERS -*/ 25 /* MARKER - THE MARKER VECTOR FOR REACH AND NBRHD SETS.*/ 26 /* GT 0 MEANS THE NODE IS IN REACH SET.*/ 27 /* LT 0 MEANS THE NODE HAS BEEN MERGED WITH*/ 28 /* OTHERS IN THE QUOTIENT OR IT IS IN NBRHD SET.*/ 29 /*****************************************************************/ 30 PetscErrorCode SPARSEPACKqmdrch(const PetscInt *root, const PetscInt *xadj, const PetscInt *adjncy, PetscInt *deg, PetscInt *marker, PetscInt *rchsze, PetscInt *rchset, PetscInt *nhdsze, PetscInt *nbrhd) 31 { 32 /* System generated locals */ 33 PetscInt i__1, i__2; 34 35 /* Local variables */ 36 PetscInt node, i, j, nabor, istop, jstop, istrt, jstrt; 37 38 /* LOOP THROUGH THE NEIGHBORS OF ROOT IN THE*/ 39 /* QUOTIENT GRAPH.*/ 40 41 PetscFunctionBegin; 42 /* Parameter adjustments */ 43 --nbrhd; 44 --rchset; 45 --marker; 46 --deg; 47 --adjncy; 48 --xadj; 49 50 *nhdsze = 0; 51 *rchsze = 0; 52 istrt = xadj[*root]; 53 istop = xadj[*root + 1] - 1; 54 if (istop < istrt) PetscFunctionReturn(PETSC_SUCCESS); 55 i__1 = istop; 56 for (i = istrt; i <= i__1; ++i) { 57 nabor = adjncy[i]; 58 if (!nabor) PetscFunctionReturn(PETSC_SUCCESS); 59 if (marker[nabor] != 0) goto L600; 60 if (deg[nabor] < 0) goto L200; 61 62 /* INCLUDE NABOR INTO THE REACHABLE SET.*/ 63 ++(*rchsze); 64 rchset[*rchsze] = nabor; 65 marker[nabor] = 1; 66 goto L600; 67 /* NABOR HAS BEEN ELIMINATED. FIND NODES*/ 68 /* REACHABLE FROM IT.*/ 69 L200: 70 marker[nabor] = -1; 71 ++(*nhdsze); 72 nbrhd[*nhdsze] = nabor; 73 L300: 74 jstrt = xadj[nabor]; 75 jstop = xadj[nabor + 1] - 1; 76 i__2 = jstop; 77 for (j = jstrt; j <= i__2; ++j) { 78 node = adjncy[j]; 79 nabor = -node; 80 if (node < 0) goto L300; 81 else if (!node) goto L600; 82 else goto L400; 83 L400: 84 if (marker[node] != 0) goto L500; 85 ++(*rchsze); 86 rchset[*rchsze] = node; 87 marker[node] = 1; 88 L500:; 89 } 90 L600:; 91 } 92 PetscFunctionReturn(PETSC_SUCCESS); 93 } 94