Actual source code: qmdmrg.c

      1: #define PETSCMAT_DLL

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

     5:  #include petsc.h

      7: /******************************************************************/
      8: /***********     QMDMRG ..... QUOT MIN DEG MERGE       ************/
      9: /******************************************************************/
     10: /*    PURPOSE - THIS ROUTINE MERGES INDISTINGUISHABLE NODES IN   */
     11: /*              THE MINIMUM DEGREE ORDERING ALGORITHM.           */
     12: /*              IT ALSO COMPUTES THE NEW DEGREES OF THESE        */
     13: /*              NEW SUPERNODES.                                  */
     14: /*                                                               */
     15: /*    INPUT PARAMETERS -                                         */
     16: /*       (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE.               */
     17: /*       DEG0 - THE NUMBER OF NODES IN THE GIVEN SET.            */
     18: /*       (NHDSZE, NBRHD) - THE SET OF ELIMINATED SUPERNODES      */
     19: /*              ADJACENT TO SOME NODES IN THE SET.               */
     20: /*                                                               */
     21: /*    UPDATED PARAMETERS -                                       */
     22: /*       DEG - THE DEGREE VECTOR.                                */
     23: /*       QSIZE - SIZE OF INDISTINGUISHABLE NODES.                */
     24: /*       QLINK - LINKED LIST FOR INDISTINGUISHABLE NODES.        */
     25: /*       MARKER - THE GIVEN SET IS GIVEN BY THOSE NODES WITH     */
     26: /*              MARKER VALUE SET TO 1.  THOSE NODES WITH DEGREE  */
     27: /*              UPDATED WILL HAVE MARKER VALUE SET TO 2.         */
     28: /*                                                               */
     29: /*    WORKING PARAMETERS -                                       */
     30: /*       RCHSET - THE REACHABLE SET.                             */
     31: /*       OVRLP -  TEMP VECTOR TO STORE THE INTERSECTION OF TWO   */
     32: /*              REACHABLE SETS.                                  */
     33: /*                                                               */
     34: /*****************************************************************/
     37: PetscErrorCode SPARSEPACKqmdmrg(PetscInt *xadj, PetscInt *adjncy, PetscInt *deg,
     38:         PetscInt *qsize, PetscInt *qlink, PetscInt *marker, PetscInt *deg0,
     39:         PetscInt *nhdsze, PetscInt *nbrhd, PetscInt *rchset, PetscInt *ovrlp)
     40: {
     41:     /* System generated locals */
     42:     PetscInt i__1, i__2, i__3;

     44:     /* Local variables */
     45:     PetscInt head, inhd, irch, node, mark, ilink, root, j, lnode, nabor,
     46:             jstop, jstrt, rchsze, mrgsze, novrlp, iov, deg1;

     49:     /* Parameter adjustments */
     50:     --ovrlp;
     51:     --rchset;
     52:     --nbrhd;
     53:     --marker;
     54:     --qlink;
     55:     --qsize;
     56:     --deg;
     57:     --adjncy;
     58:     --xadj;

     60:     if (*nhdsze <= 0) {
     61:         return(0);
     62:     }
     63:     i__1 = *nhdsze;
     64:     for (inhd = 1; inhd <= i__1; ++inhd) {
     65:         root = nbrhd[inhd];
     66:         marker[root] = 0;
     67:     }
     68: /*       LOOP THROUGH EACH ELIMINATED SUPERNODE IN THE SET     */
     69: /*       (NHDSZE, NBRHD).                                      */
     70:     i__1 = *nhdsze;
     71:     for (inhd = 1; inhd <= i__1; ++inhd) {
     72:         root = nbrhd[inhd];
     73:         marker[root] = -1;
     74:         rchsze = 0;
     75:         novrlp = 0;
     76:         deg1 = 0;
     77: L200:
     78:         jstrt = xadj[root];
     79:         jstop = xadj[root + 1] - 1;
     80: /*          DETERMINE THE REACHABLE SET AND ITS PETSCINTERSECT-     */
     81: /*          ION WITH THE INPUT REACHABLE SET.                  */
     82:         i__2 = jstop;
     83:         for (j = jstrt; j <= i__2; ++j) {
     84:             nabor = adjncy[j];
     85:             root = -nabor;
     86:             if (nabor < 0) {
     87:                 goto L200;
     88:             } else if (!nabor) {
     89:                 goto L700;
     90:             } else {
     91:                 goto L300;
     92:             }
     93: L300:
     94:             mark = marker[nabor];
     95:             if (mark < 0) {
     96:                 goto L600;
     97:             } else if (!mark) {
     98:                 goto L400;
     99:             } else {
    100:                 goto L500;
    101:             }
    102: L400:
    103:             ++rchsze;
    104:             rchset[rchsze] = nabor;
    105:             deg1 += qsize[nabor];
    106:             marker[nabor] = 1;
    107:             goto L600;
    108: L500:
    109:             if (mark > 1) {
    110:                 goto L600;
    111:             }
    112:             ++novrlp;
    113:             ovrlp[novrlp] = nabor;
    114:             marker[nabor] = 2;
    115: L600:
    116:             ;
    117:         }
    118: /*          FROM THE OVERLAPPED SET, DETERMINE THE NODES        */
    119: /*          THAT CAN BE MERGED TOGETHER.                        */
    120: L700:
    121:         head = 0;
    122:         mrgsze = 0;
    123:         i__2 = novrlp;
    124:         for (iov = 1; iov <= i__2; ++iov) {
    125:             node = ovrlp[iov];
    126:             jstrt = xadj[node];
    127:             jstop = xadj[node + 1] - 1;
    128:             i__3 = jstop;
    129:             for (j = jstrt; j <= i__3; ++j) {
    130:                 nabor = adjncy[j];
    131:                 if (marker[nabor] != 0) {
    132:                     goto L800;
    133:                 }
    134:                 marker[node] = 1;
    135:                 goto L1100;
    136: L800:
    137:                 ;
    138:             }
    139: /*             NODE BELONGS TO THE NEW MERGED SUPERNODE.      */
    140: /*             UPDATE THE VECTORS QLINK AND QSIZE.            */
    141:             mrgsze += qsize[node];
    142:             marker[node] = -1;
    143:             lnode = node;
    144: L900:
    145:             ilink = qlink[lnode];
    146:             if (ilink <= 0) {
    147:                 goto L1000;
    148:             }
    149:             lnode = ilink;
    150:             goto L900;
    151: L1000:
    152:             qlink[lnode] = head;
    153:             head = node;
    154: L1100:
    155:             ;
    156:         }
    157:         if (head <= 0) {
    158:             goto L1200;
    159:         }
    160:         qsize[head] = mrgsze;
    161:         deg[head] = *deg0 + deg1 - 1;
    162:         marker[head] = 2;
    163: /*          RESET MARKER VALUES.          */
    164: L1200:
    165:         root = nbrhd[inhd];
    166:         marker[root] = 0;
    167:         if (rchsze <= 0) {
    168:             goto L1400;
    169:         }
    170:         i__2 = rchsze;
    171:         for (irch = 1; irch <= i__2; ++irch) {
    172:             node = rchset[irch];
    173:             marker[node] = 0;
    174:         }
    175: L1400:
    176:         ;
    177:     }
    178:     return(0);
    179: }