/* ordmmd.f -- translated by f2c (version 19951025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ #include typedef mwSignedIndex integer; /* removed "long" */ /* *********************************************************************** */ /* *********************************************************************** */ /* Version: 0.3 */ /* Last modified: December 27, 1994 */ /* Authors: Esmond G. Ng and Barry W. Peyton */ /* Mathematical Sciences Section, Oak Ridge National Laboratory */ /* *********************************************************************** */ /* *********************************************************************** */ /* **** ORDMMD ..... MULTIPLE MINIMUM EXTERNAL DEGREE ************ */ /* *********************************************************************** */ /* *********************************************************************** */ /* PURPOSE - THIS ROUTINE CALLS LIU'S MULTIPLE MINIMUM DEGREE */ /* ROUTINE. */ /* INPUT PARAMETERS - */ /* NEQNS - NUMBER OF EQUATIONS. */ /* IWSIZ - SIZE OF INTEGER WORKING STORAGE. */ /* OUTPUT PARAMETERS - */ /* PERM - THE MINIMUM DEGREE ORDERING. */ /* INVP - THE INVERSE OF PERM. */ /* NOFSUB - AN UPPER BOUND ON THE NUMBER OF NONZERO */ /* SUBSCRIPTS FOR THE COMPRESSED STORAGE SCHEME. */ /* IFLAG - ERROR FLAG. */ /* 0: SUCCESSFUL ORDERING */ /* -1: INSUFFICIENT WORKING STORAGE */ /* [IWORK(*)]. */ /* UPDATED PARAMETER - */ /* (** JFS 2/9/98 MOVED TO UPDATED: */ /* (XADJ,ADJNCY) - ON INPUT, THE ADJACENCY STRUCTURE, */ /* ON OUTPUT UNDEFINED. */ /* **) */ /* WORKING PARAMETERS - */ /* IWORK - INTEGER WORKSPACE OF LENGTH 4*NEQNS. */ /* *********************************************************************** */ /* Subroutine */ int ordmmd_(neqns, xadj, adjncy, invp, perm, iwsiz, iwork, nofsub, iflag) integer *neqns, *xadj, *adjncy, *invp, *perm, *iwsiz, *iwork, *nofsub, *iflag; { static integer delta; extern /* Subroutine */ int genmmd_(); static integer maxint; /* *********************************************************************** */ /* ********************************************************************* */ /* Parameter adjustments */ --iwork; --perm; --invp; --adjncy; --xadj; /* Function Body */ *iflag = 0; if (*iwsiz < *neqns << 2) { *iflag = -1; return 0; } /* DELTA - TOLERANCE VALUE FOR MULTIPLE ELIMINATION. */ /* MAXINT - MAXIMUM MACHINE REPRESENTABLE (SHORT) INTEGER */ /* (ANY SMALLER ESTIMATE WILL DO) FOR MARKING */ /* NODES. */ delta = 0; maxint = 32767; genmmd_(neqns, &xadj[1], &adjncy[1], &invp[1], &perm[1], &delta, &iwork[1] , &iwork[*neqns + 1], &iwork[(*neqns << 1) + 1], &iwork[*neqns * 3 + 1], &maxint, nofsub); return 0; } /* ordmmd_ */ /* *********************************************************************** */ /* *********************************************************************** */ /* Version: 0.3 */ /* Last modified: December 27, 1994 */ /* Authors: Joseph W.H. Liu */ /* Mathematical Sciences Section, Oak Ridge National Laboratory */ /* *********************************************************************** */ /* *********************************************************************** */ /* --- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = GENMMD */ /* (C) UNIVERSITY OF WATERLOO JANUARY 1984 */ /* *********************************************************************** */ /* *********************************************************************** */ /* **** GENMMD ..... MULTIPLE MINIMUM EXTERNAL DEGREE ************ */ /* *********************************************************************** */ /* *********************************************************************** */ /* PURPOSE - THIS ROUTINE IMPLEMENTS THE MINIMUM DEGREE */ /* ALGORITHM. IT MAKES USE OF THE IMPLICIT REPRESENTATION */ /* OF ELIMINATION GRAPHS BY QUOTIENT GRAPHS, AND THE */ /* NOTION OF INDISTINGUISHABLE NODES. IT ALSO IMPLEMENTS */ /* THE MODIFICATIONS BY MULTIPLE ELIMINATION AND MINIMUM */ /* EXTERNAL DEGREE. */ /* --------------------------------------------- */ /* CAUTION - THE ADJACENCY VECTOR ADJNCY WILL BE */ /* DESTROYED. */ /* --------------------------------------------- */ /* INPUT PARAMETERS - */ /* NEQNS - NUMBER OF EQUATIONS. */ /* (XADJ,ADJNCY) - THE ADJACENCY STRUCTURE. */ /* DELTA - TOLERANCE VALUE FOR MULTIPLE ELIMINATION. */ /* MAXINT - MAXIMUM MACHINE REPRESENTABLE (SHORT) INTEGER */ /* (ANY SMALLER ESTIMATE WILL DO) FOR MARKING */ /* NODES. */ /* OUTPUT PARAMETERS - */ /* PERM - THE MINIMUM DEGREE ORDERING. */ /* INVP - THE INVERSE OF PERM. */ /* NOFSUB - AN UPPER BOUND ON THE NUMBER OF NONZERO */ /* SUBSCRIPTS FOR THE COMPRESSED STORAGE SCHEME. */ /* WORKING PARAMETERS - */ /* DHEAD - VECTOR FOR HEAD OF DEGREE LISTS. */ /* INVP - USED TEMPORARILY FOR DEGREE FORWARD LINK. */ /* PERM - USED TEMPORARILY FOR DEGREE BACKWARD LINK. */ /* QSIZE - VECTOR FOR SIZE OF SUPERNODES. */ /* LLIST - VECTOR FOR TEMPORARY LINKED LISTS. */ /* MARKER - A TEMPORARY MARKER VECTOR. */ /* PROGRAM SUBROUTINES - */ /* MMDELM, MMDINT, MMDNUM, MMDUPD. */ /* *********************************************************************** */ /* Subroutine */ int genmmd_(neqns, xadj, adjncy, invp, perm, delta, dhead, qsize, llist, marker, maxint, nofsub) integer *neqns, *xadj, *adjncy, *invp, *perm, *delta, *dhead, *qsize, *llist, *marker, *maxint, *nofsub; { /* System generated locals */ integer i__1; /* Local variables */ static integer mdeg, ehead, i__, mdlmt, mdnode; extern /* Subroutine */ int mmdelm_(), mmdupd_(), mmdint_(), mmdnum_(); static integer nextmd, tag, num; /* *********************************************************************** */ /* *********************************************************************** */ /* Parameter adjustments */ --marker; --llist; --qsize; --dhead; --perm; --invp; --adjncy; --xadj; /* Function Body */ if (*neqns <= 0) { return 0; } /* ------------------------------------------------ */ /* INITIALIZATION FOR THE MINIMUM DEGREE ALGORITHM. */ /* ------------------------------------------------ */ *nofsub = 0; mmdint_(neqns, &xadj[1], &adjncy[1], &dhead[1], &invp[1], &perm[1], & qsize[1], &llist[1], &marker[1]); /* ---------------------------------------------- */ /* NUM COUNTS THE NUMBER OF ORDERED NODES PLUS 1. */ /* ---------------------------------------------- */ num = 1; /* ----------------------------- */ /* ELIMINATE ALL ISOLATED NODES. */ /* ----------------------------- */ nextmd = dhead[1]; L100: if (nextmd <= 0) { goto L200; } mdnode = nextmd; nextmd = invp[mdnode]; marker[mdnode] = *maxint; invp[mdnode] = -num; ++num; goto L100; L200: /* ---------------------------------------- */ /* SEARCH FOR NODE OF THE MINIMUM DEGREE. */ /* MDEG IS THE CURRENT MINIMUM DEGREE; */ /* TAG IS USED TO FACILITATE MARKING NODES. */ /* ---------------------------------------- */ if (num > *neqns) { goto L1000; } tag = 1; dhead[1] = 0; mdeg = 2; L300: if (dhead[mdeg] > 0) { goto L400; } ++mdeg; goto L300; L400: /* ------------------------------------------------- */ /* USE VALUE OF DELTA TO SET UP MDLMT, WHICH GOVERNS */ /* WHEN A DEGREE UPDATE IS TO BE PERFORMED. */ /* ------------------------------------------------- */ mdlmt = mdeg + *delta; ehead = 0; L500: mdnode = dhead[mdeg]; if (mdnode > 0) { goto L600; } ++mdeg; if (mdeg > mdlmt) { goto L900; } goto L500; L600: /* ---------------------------------------- */ /* REMOVE MDNODE FROM THE DEGREE STRUCTURE. */ /* ---------------------------------------- */ nextmd = invp[mdnode]; dhead[mdeg] = nextmd; if (nextmd > 0) { perm[nextmd] = -mdeg; } invp[mdnode] = -num; *nofsub = *nofsub + mdeg + qsize[mdnode] - 2; if (num + qsize[mdnode] > *neqns) { goto L1000; } /* ---------------------------------------------- */ /* ELIMINATE MDNODE AND PERFORM QUOTIENT GRAPH */ /* TRANSFORMATION. RESET TAG VALUE IF NECESSARY. */ /* ---------------------------------------------- */ ++tag; if (tag < *maxint) { goto L800; } tag = 1; i__1 = *neqns; for (i__ = 1; i__ <= i__1; ++i__) { if (marker[i__] < *maxint) { marker[i__] = 0; } /* L700: */ } L800: mmdelm_(&mdnode, &xadj[1], &adjncy[1], &dhead[1], &invp[1], &perm[1], & qsize[1], &llist[1], &marker[1], maxint, &tag); num += qsize[mdnode]; llist[mdnode] = ehead; ehead = mdnode; if (*delta >= 0) { goto L500; } L900: /* ------------------------------------------- */ /* UPDATE DEGREES OF THE NODES INVOLVED IN THE */ /* MINIMUM DEGREE NODES ELIMINATION. */ /* ------------------------------------------- */ if (num > *neqns) { goto L1000; } mmdupd_(&ehead, neqns, &xadj[1], &adjncy[1], delta, &mdeg, &dhead[1], & invp[1], &perm[1], &qsize[1], &llist[1], &marker[1], maxint, &tag) ; goto L300; L1000: mmdnum_(neqns, &perm[1], &invp[1], &qsize[1]); return 0; } /* genmmd_ */ /* *********************************************************************** */ /* *********************************************************************** */ /* Version: 0.3 */ /* Last modified: December 27, 1994 */ /* Authors: Joseph W.H. Liu */ /* Mathematical Sciences Section, Oak Ridge National Laboratory */ /* *********************************************************************** */ /* *********************************************************************** */ /* --- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDINT */ /* (C) UNIVERSITY OF WATERLOO JANUARY 1984 */ /* *********************************************************************** */ /* *********************************************************************** */ /* *** MMDINT ..... MULT MINIMUM DEGREE INITIALIZATION *********** */ /* *********************************************************************** */ /* *********************************************************************** */ /* PURPOSE - THIS ROUTINE PERFORMS INITIALIZATION FOR THE */ /* MULTIPLE ELIMINATION VERSION OF THE MINIMUM DEGREE */ /* ALGORITHM. */ /* INPUT PARAMETERS - */ /* NEQNS - NUMBER OF EQUATIONS. */ /* (XADJ,ADJNCY) - ADJACENCY STRUCTURE. */ /* OUTPUT PARAMETERS - */ /* (DHEAD,DFORW,DBAKW) - DEGREE DOUBLY LINKED STRUCTURE. */ /* QSIZE - SIZE OF SUPERNODE (INITIALIZED TO ONE). */ /* LLIST - LINKED LIST. */ /* MARKER - MARKER VECTOR. */ /* *********************************************************************** */ /* Subroutine */ int mmdint_(neqns, xadj, adjncy, dhead, dforw, dbakw, qsize, llist, marker) integer *neqns, *xadj, *adjncy, *dhead, *dforw, *dbakw, *qsize, *llist, * marker; { /* System generated locals */ integer i__1; /* Local variables */ static integer ndeg, node, fnode; /* *********************************************************************** */ /* *********************************************************************** */ /* Parameter adjustments */ --marker; --llist; --qsize; --dbakw; --dforw; --dhead; --adjncy; --xadj; /* Function Body */ i__1 = *neqns; for (node = 1; node <= i__1; ++node) { dhead[node] = 0; qsize[node] = 1; marker[node] = 0; llist[node] = 0; /* L100: */ } /* ------------------------------------------ */ /* INITIALIZE THE DEGREE DOUBLY LINKED LISTS. */ /* ------------------------------------------ */ i__1 = *neqns; for (node = 1; node <= i__1; ++node) { ndeg = xadj[node + 1] - xadj[node] + 1; fnode = dhead[ndeg]; dforw[node] = fnode; dhead[ndeg] = node; if (fnode > 0) { dbakw[fnode] = node; } dbakw[node] = -ndeg; /* L200: */ } return 0; } /* mmdint_ */ /* *********************************************************************** */ /* *********************************************************************** */ /* Version: 0.3 */ /* Last modified: December 27, 1994 */ /* Authors: Joseph W.H. Liu */ /* Mathematical Sciences Section, Oak Ridge National Laboratory */ /* *********************************************************************** */ /* *********************************************************************** */ /* --- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDELM */ /* (C) UNIVERSITY OF WATERLOO JANUARY 1984 */ /* *********************************************************************** */ /* *********************************************************************** */ /* ** MMDELM ..... MULTIPLE MINIMUM DEGREE ELIMINATION *********** */ /* *********************************************************************** */ /* *********************************************************************** */ /* PURPOSE - THIS ROUTINE ELIMINATES THE NODE MDNODE OF */ /* MINIMUM DEGREE FROM THE ADJACENCY STRUCTURE, WHICH */ /* IS STORED IN THE QUOTIENT GRAPH FORMAT. IT ALSO */ /* TRANSFORMS THE QUOTIENT GRAPH REPRESENTATION OF THE */ /* ELIMINATION GRAPH. */ /* INPUT PARAMETERS - */ /* MDNODE - NODE OF MINIMUM DEGREE. */ /* MAXINT - ESTIMATE OF MAXIMUM REPRESENTABLE (SHORT) */ /* INTEGER. */ /* TAG - TAG VALUE. */ /* UPDATED PARAMETERS - */ /* (XADJ,ADJNCY) - UPDATED ADJACENCY STRUCTURE. */ /* (DHEAD,DFORW,DBAKW) - DEGREE DOUBLY LINKED STRUCTURE. */ /* QSIZE - SIZE OF SUPERNODE. */ /* MARKER - MARKER VECTOR. */ /* LLIST - TEMPORARY LINKED LIST OF ELIMINATED NABORS. */ /* *********************************************************************** */ /* Subroutine */ int mmdelm_(mdnode, xadj, adjncy, dhead, dforw, dbakw, qsize, llist, marker, maxint, tag) integer *mdnode, *xadj, *adjncy, *dhead, *dforw, *dbakw, *qsize, *llist, * marker, *maxint, *tag; { /* System generated locals */ integer i__1, i__2; /* Local variables */ static integer node, link, rloc, rlmt, i__, j, nabor, rnode, elmnt, xqnbr, istop, jstop, istrt, jstrt, nxnode, pvnode, nqnbrs, npv; /* *********************************************************************** */ /* *********************************************************************** */ /* ----------------------------------------------- */ /* FIND REACHABLE SET AND PLACE IN DATA STRUCTURE. */ /* ----------------------------------------------- */ /* Parameter adjustments */ --marker; --llist; --qsize; --dbakw; --dforw; --dhead; --adjncy; --xadj; /* Function Body */ marker[*mdnode] = *tag; istrt = xadj[*mdnode]; istop = xadj[*mdnode + 1] - 1; /* ------------------------------------------------------- */ /* ELMNT POINTS TO THE BEGINNING OF THE LIST OF ELIMINATED */ /* NABORS OF MDNODE, AND RLOC GIVES THE STORAGE LOCATION */ /* FOR THE NEXT REACHABLE NODE. */ /* ------------------------------------------------------- */ elmnt = 0; rloc = istrt; rlmt = istop; i__1 = istop; for (i__ = istrt; i__ <= i__1; ++i__) { nabor = adjncy[i__]; if (nabor == 0) { goto L300; } if (marker[nabor] >= *tag) { goto L200; } marker[nabor] = *tag; if (dforw[nabor] < 0) { goto L100; } adjncy[rloc] = nabor; ++rloc; goto L200; L100: llist[nabor] = elmnt; elmnt = nabor; L200: ; } L300: /* ----------------------------------------------------- */ /* MERGE WITH REACHABLE NODES FROM GENERALIZED ELEMENTS. */ /* ----------------------------------------------------- */ if (elmnt <= 0) { goto L1000; } adjncy[rlmt] = -elmnt; link = elmnt; L400: jstrt = xadj[link]; jstop = xadj[link + 1] - 1; i__1 = jstop; for (j = jstrt; j <= i__1; ++j) { node = adjncy[j]; link = -node; if (node < 0) { goto L400; } else if (node == 0) { goto L900; } else { goto L500; } L500: if (marker[node] >= *tag || dforw[node] < 0) { goto L800; } marker[node] = *tag; /* --------------------------------- */ /* USE STORAGE FROM ELIMINATED NODES */ /* IF NECESSARY. */ /* --------------------------------- */ L600: if (rloc < rlmt) { goto L700; } link = -adjncy[rlmt]; rloc = xadj[link]; rlmt = xadj[link + 1] - 1; goto L600; L700: adjncy[rloc] = node; ++rloc; L800: ; } L900: elmnt = llist[elmnt]; goto L300; L1000: if (rloc <= rlmt) { adjncy[rloc] = 0; } /* -------------------------------------------------------- */ /* FOR EACH NODE IN THE REACHABLE SET, DO THE FOLLOWING ... */ /* -------------------------------------------------------- */ link = *mdnode; L1100: istrt = xadj[link]; istop = xadj[link + 1] - 1; i__1 = istop; for (i__ = istrt; i__ <= i__1; ++i__) { rnode = adjncy[i__]; link = -rnode; if (rnode < 0) { goto L1100; } else if (rnode == 0) { goto L1800; } else { goto L1200; } L1200: /* -------------------------------------------- */ /* IF RNODE IS IN THE DEGREE LIST STRUCTURE ... */ /* -------------------------------------------- */ pvnode = dbakw[rnode]; if (pvnode == 0 || pvnode == -(*maxint)) { goto L1300; } /* ------------------------------------- */ /* THEN REMOVE RNODE FROM THE STRUCTURE. */ /* ------------------------------------- */ nxnode = dforw[rnode]; if (nxnode > 0) { dbakw[nxnode] = pvnode; } if (pvnode > 0) { dforw[pvnode] = nxnode; } npv = -pvnode; if (pvnode < 0) { dhead[npv] = nxnode; } L1300: /* ---------------------------------------- */ /* PURGE INACTIVE QUOTIENT NABORS OF RNODE. */ /* ---------------------------------------- */ jstrt = xadj[rnode]; jstop = xadj[rnode + 1] - 1; xqnbr = jstrt; i__2 = jstop; for (j = jstrt; j <= i__2; ++j) { nabor = adjncy[j]; if (nabor == 0) { goto L1500; } if (marker[nabor] >= *tag) { goto L1400; } adjncy[xqnbr] = nabor; ++xqnbr; L1400: ; } L1500: /* ---------------------------------------- */ /* IF NO ACTIVE NABOR AFTER THE PURGING ... */ /* ---------------------------------------- */ nqnbrs = xqnbr - jstrt; if (nqnbrs > 0) { goto L1600; } /* ----------------------------- */ /* THEN MERGE RNODE WITH MDNODE. */ /* ----------------------------- */ qsize[*mdnode] += qsize[rnode]; qsize[rnode] = 0; marker[rnode] = *maxint; dforw[rnode] = -(*mdnode); dbakw[rnode] = -(*maxint); goto L1700; L1600: /* -------------------------------------- */ /* ELSE FLAG RNODE FOR DEGREE UPDATE, AND */ /* ADD MDNODE AS A NABOR OF RNODE. */ /* -------------------------------------- */ dforw[rnode] = nqnbrs + 1; dbakw[rnode] = 0; adjncy[xqnbr] = *mdnode; ++xqnbr; if (xqnbr <= jstop) { adjncy[xqnbr] = 0; } L1700: ; } L1800: return 0; } /* mmdelm_ */ /* *********************************************************************** */ /* *********************************************************************** */ /* Version: 0.3 */ /* Last modified: December 27, 1994 */ /* Authors: Joseph W.H. Liu */ /* Mathematical Sciences Section, Oak Ridge National Laboratory */ /* *********************************************************************** */ /* *********************************************************************** */ /* --- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDNUM */ /* (C) UNIVERSITY OF WATERLOO JANUARY 1984 */ /* *********************************************************************** */ /* *********************************************************************** */ /* ***** MMDNUM ..... MULTI MINIMUM DEGREE NUMBERING ************* */ /* *********************************************************************** */ /* *********************************************************************** */ /* PURPOSE - THIS ROUTINE PERFORMS THE FINAL STEP IN */ /* PRODUCING THE PERMUTATION AND INVERSE PERMUTATION */ /* VECTORS IN THE MULTIPLE ELIMINATION VERSION OF THE */ /* MINIMUM DEGREE ORDERING ALGORITHM. */ /* INPUT PARAMETERS - */ /* NEQNS - NUMBER OF EQUATIONS. */ /* QSIZE - SIZE OF SUPERNODES AT ELIMINATION. */ /* UPDATED PARAMETERS - */ /* INVP - INVERSE PERMUTATION VECTOR. ON INPUT, */ /* IF QSIZE(NODE)=0, THEN NODE HAS BEEN MERGED */ /* INTO THE NODE -INVP(NODE); OTHERWISE, */ /* -INVP(NODE) IS ITS INVERSE LABELLING. */ /* OUTPUT PARAMETERS - */ /* PERM - THE PERMUTATION VECTOR. */ /* *********************************************************************** */ /* Subroutine */ int mmdnum_(neqns, perm, invp, qsize) integer *neqns, *perm, *invp, *qsize; { /* System generated locals */ integer i__1; /* Local variables */ static integer node, root, nextf, father, nqsize, num; /* *********************************************************************** */ /* *********************************************************************** */ /* Parameter adjustments */ --qsize; --invp; --perm; /* Function Body */ i__1 = *neqns; for (node = 1; node <= i__1; ++node) { nqsize = qsize[node]; if (nqsize <= 0) { perm[node] = invp[node]; } if (nqsize > 0) { perm[node] = -invp[node]; } /* L100: */ } /* ------------------------------------------------------ */ /* FOR EACH NODE WHICH HAS BEEN MERGED, DO THE FOLLOWING. */ /* ------------------------------------------------------ */ i__1 = *neqns; for (node = 1; node <= i__1; ++node) { if (perm[node] > 0) { goto L500; } /* ----------------------------------------- */ /* TRACE THE MERGED TREE UNTIL ONE WHICH HAS */ /* NOT BEEN MERGED, CALL IT ROOT. */ /* ----------------------------------------- */ father = node; L200: if (perm[father] > 0) { goto L300; } father = -perm[father]; goto L200; L300: /* ----------------------- */ /* NUMBER NODE AFTER ROOT. */ /* ----------------------- */ root = father; num = perm[root] + 1; invp[node] = -num; perm[root] = num; /* ------------------------ */ /* SHORTEN THE MERGED TREE. */ /* ------------------------ */ father = node; L400: nextf = -perm[father]; if (nextf <= 0) { goto L500; } perm[father] = -root; father = nextf; goto L400; L500: ; } /* ---------------------- */ /* READY TO COMPUTE PERM. */ /* ---------------------- */ i__1 = *neqns; for (node = 1; node <= i__1; ++node) { num = -invp[node]; invp[node] = num; perm[num] = node; /* L600: */ } return 0; } /* mmdnum_ */ /* *********************************************************************** */ /* *********************************************************************** */ /* Version: 0.3 */ /* Last modified: December 27, 1994 */ /* Authors: Joseph W.H. Liu */ /* Mathematical Sciences Section, Oak Ridge National Laboratory */ /* *********************************************************************** */ /* *********************************************************************** */ /* --- SPARSPAK-A (ANSI FORTRAN) RELEASE III --- NAME = MMDUPD */ /* (C) UNIVERSITY OF WATERLOO JANUARY 1984 */ /* *********************************************************************** */ /* *********************************************************************** */ /* ***** MMDUPD ..... MULTIPLE MINIMUM DEGREE UPDATE ************* */ /* *********************************************************************** */ /* *********************************************************************** */ /* PURPOSE - THIS ROUTINE UPDATES THE DEGREES OF NODES */ /* AFTER A MULTIPLE ELIMINATION STEP. */ /* INPUT PARAMETERS - */ /* EHEAD - THE BEGINNING OF THE LIST OF ELIMINATED */ /* NODES (I.E., NEWLY FORMED ELEMENTS). */ /* NEQNS - NUMBER OF EQUATIONS. */ /* (XADJ,ADJNCY) - ADJACENCY STRUCTURE. */ /* DELTA - TOLERANCE VALUE FOR MULTIPLE ELIMINATION. */ /* MAXINT - MAXIMUM MACHINE REPRESENTABLE (SHORT) */ /* INTEGER. */ /* UPDATED PARAMETERS - */ /* MDEG - NEW MINIMUM DEGREE AFTER DEGREE UPDATE. */ /* (DHEAD,DFORW,DBAKW) - DEGREE DOUBLY LINKED STRUCTURE. */ /* QSIZE - SIZE OF SUPERNODE. */ /* LLIST - WORKING LINKED LIST. */ /* MARKER - MARKER VECTOR FOR DEGREE UPDATE. */ /* TAG - TAG VALUE. */ /* *********************************************************************** */ /* Subroutine */ int mmdupd_(ehead, neqns, xadj, adjncy, delta, mdeg, dhead, dforw, dbakw, qsize, llist, marker, maxint, tag) integer *ehead, *neqns, *xadj, *adjncy, *delta, *mdeg, *dhead, *dforw, *dbakw, *qsize, *llist, *marker, *maxint, *tag; { /* System generated locals */ integer i__1, i__2; /* Local variables */ static integer node, mtag, link, mdeg0, i__, j, enode, fnode, nabor, elmnt, istop, jstop, q2head, istrt, jstrt, qxhead, iq2, deg, deg0; /* *********************************************************************** */ /* *********************************************************************** */ /* Parameter adjustments */ --marker; --llist; --qsize; --dbakw; --dforw; --dhead; --adjncy; --xadj; /* Function Body */ mdeg0 = *mdeg + *delta; elmnt = *ehead; L100: /* ------------------------------------------------------- */ /* FOR EACH OF THE NEWLY FORMED ELEMENT, DO THE FOLLOWING. */ /* (RESET TAG VALUE IF NECESSARY.) */ /* ------------------------------------------------------- */ if (elmnt <= 0) { return 0; } mtag = *tag + mdeg0; if (mtag < *maxint) { goto L300; } *tag = 1; i__1 = *neqns; for (i__ = 1; i__ <= i__1; ++i__) { if (marker[i__] < *maxint) { marker[i__] = 0; } /* L200: */ } mtag = *tag + mdeg0; L300: /* --------------------------------------------- */ /* CREATE TWO LINKED LISTS FROM NODES ASSOCIATED */ /* WITH ELMNT: ONE WITH TWO NABORS (Q2HEAD) IN */ /* ADJACENCY STRUCTURE, AND THE OTHER WITH MORE */ /* THAN TWO NABORS (QXHEAD). ALSO COMPUTE DEG0, */ /* NUMBER OF NODES IN THIS ELEMENT. */ /* --------------------------------------------- */ q2head = 0; qxhead = 0; deg0 = 0; link = elmnt; L400: istrt = xadj[link]; istop = xadj[link + 1] - 1; i__1 = istop; for (i__ = istrt; i__ <= i__1; ++i__) { enode = adjncy[i__]; link = -enode; if (enode < 0) { goto L400; } else if (enode == 0) { goto L800; } else { goto L500; } L500: if (qsize[enode] == 0) { goto L700; } deg0 += qsize[enode]; marker[enode] = mtag; /* ---------------------------------- */ /* IF ENODE REQUIRES A DEGREE UPDATE, */ /* THEN DO THE FOLLOWING. */ /* ---------------------------------- */ if (dbakw[enode] != 0) { goto L700; } /* --------------------------------------- */ /* PLACE EITHER IN QXHEAD OR Q2HEAD LISTS. */ /* --------------------------------------- */ if (dforw[enode] == 2) { goto L600; } llist[enode] = qxhead; qxhead = enode; goto L700; L600: llist[enode] = q2head; q2head = enode; L700: ; } L800: /* -------------------------------------------- */ /* FOR EACH ENODE IN Q2 LIST, DO THE FOLLOWING. */ /* -------------------------------------------- */ enode = q2head; iq2 = 1; L900: if (enode <= 0) { goto L1500; } if (dbakw[enode] != 0) { goto L2200; } ++(*tag); deg = deg0; /* ------------------------------------------ */ /* IDENTIFY THE OTHER ADJACENT ELEMENT NABOR. */ /* ------------------------------------------ */ istrt = xadj[enode]; nabor = adjncy[istrt]; if (nabor == elmnt) { nabor = adjncy[istrt + 1]; } /* ------------------------------------------------ */ /* IF NABOR IS UNELIMINATED, INCREASE DEGREE COUNT. */ /* ------------------------------------------------ */ link = nabor; if (dforw[nabor] < 0) { goto L1000; } deg += qsize[nabor]; goto L2100; L1000: /* -------------------------------------------- */ /* OTHERWISE, FOR EACH NODE IN THE 2ND ELEMENT, */ /* DO THE FOLLOWING. */ /* -------------------------------------------- */ istrt = xadj[link]; istop = xadj[link + 1] - 1; i__1 = istop; for (i__ = istrt; i__ <= i__1; ++i__) { node = adjncy[i__]; link = -node; if (node == enode) { goto L1400; } if (node < 0) { goto L1000; } else if (node == 0) { goto L2100; } else { goto L1100; } L1100: if (qsize[node] == 0) { goto L1400; } if (marker[node] >= *tag) { goto L1200; } /* ----------------------------------- -- */ /* CASE WHEN NODE IS NOT YET CONSIDERED . */ /* ----------------------------------- -- */ marker[node] = *tag; deg += qsize[node]; goto L1400; L1200: /* ---------------------------------------- */ /* CASE WHEN NODE IS INDISTINGUISHABLE FROM */ /* ENODE. MERGE THEM INTO A NEW SUPERNODE. */ /* ---------------------------------------- */ if (dbakw[node] != 0) { goto L1400; } if (dforw[node] != 2) { goto L1300; } qsize[enode] += qsize[node]; qsize[node] = 0; marker[node] = *maxint; dforw[node] = -enode; dbakw[node] = -(*maxint); goto L1400; L1300: /* -------------------------------------- */ /* CASE WHEN NODE IS OUTMATCHED BY ENODE. */ /* -------------------------------------- */ if (dbakw[node] == 0) { dbakw[node] = -(*maxint); } L1400: ; } goto L2100; L1500: /* ------------------------------------------------ */ /* FOR EACH ENODE IN THE QX LIST, DO THE FOLLOWING. */ /* ------------------------------------------------ */ enode = qxhead; iq2 = 0; L1600: if (enode <= 0) { goto L2300; } if (dbakw[enode] != 0) { goto L2200; } ++(*tag); deg = deg0; /* --------------------------------- */ /* FOR EACH UNMARKED NABOR OF ENODE, */ /* DO THE FOLLOWING. */ /* --------------------------------- */ istrt = xadj[enode]; istop = xadj[enode + 1] - 1; i__1 = istop; for (i__ = istrt; i__ <= i__1; ++i__) { nabor = adjncy[i__]; if (nabor == 0) { goto L2100; } if (marker[nabor] >= *tag) { goto L2000; } marker[nabor] = *tag; link = nabor; /* ------------------------------ */ /* IF UNELIMINATED, INCLUDE IT IN */ /* DEG COUNT. */ /* ------------------------------ */ if (dforw[nabor] < 0) { goto L1700; } deg += qsize[nabor]; goto L2000; L1700: /* ------------------------------- */ /* IF ELIMINATED, INCLUDE UNMARKED */ /* NODES IN THIS ELEMENT INTO THE */ /* DEGREE COUNT. */ /* ------------------------------- */ jstrt = xadj[link]; jstop = xadj[link + 1] - 1; i__2 = jstop; for (j = jstrt; j <= i__2; ++j) { node = adjncy[j]; link = -node; if (node < 0) { goto L1700; } else if (node == 0) { goto L2000; } else { goto L1800; } L1800: if (marker[node] >= *tag) { goto L1900; } marker[node] = *tag; deg += qsize[node]; L1900: ; } L2000: ; } L2100: /* ------------------------------------------- */ /* UPDATE EXTERNAL DEGREE OF ENODE IN DEGREE */ /* STRUCTURE, AND MDEG (MIN DEG) IF NECESSARY. */ /* ------------------------------------------- */ deg = deg - qsize[enode] + 1; fnode = dhead[deg]; dforw[enode] = fnode; dbakw[enode] = -deg; if (fnode > 0) { dbakw[fnode] = enode; } dhead[deg] = enode; if (deg < *mdeg) { *mdeg = deg; } L2200: /* ---------------------------------- */ /* GET NEXT ENODE IN CURRENT ELEMENT. */ /* ---------------------------------- */ enode = llist[enode]; if (iq2 == 1) { goto L900; } goto L1600; L2300: /* ----------------------------- */ /* GET NEXT ELEMENT IN THE LIST. */ /* ----------------------------- */ *tag = mtag; elmnt = llist[elmnt]; goto L100; } /* mmdupd_ */