Actual source code: fn1wd.c

      1: #define PETSCMAT_DLL

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

     5:  #include petsc.h
     6:  #include src/mat/order/order.h
      7: EXTERN PetscErrorCode SPARSEPACKfnroot(PetscInt*, PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *, PetscInt *);

      9: /*****************************************************************/
     10: /********     FN1WD ..... FIND ONE-WAY DISSECTORS        *********/
     11: /*****************************************************************/
     12: /*    PURPOSE - THIS SUBROUTINE FINDS ONE-WAY DISSECTORS OF      */
     13: /*       A CONNECTED COMPONENT SPECIFIED BY MASK AND ../../...       */
     14: /*                                                               */
     15: /*    INPUT PARAMETERS -                                         */
     16: /*       ../../.. - A NODE THAT DEFINES (ALONG WITH MASK) THE        */
     17: /*              COMPONENT TO BE PROCESSED.                       */
     18: /*       (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE.               */
     19: /*                                                               */
     20: /*    OUTPUT PARAMETERS -                                        */
     21: /*       NSEP - NUMBER OF NODES IN THE ONE-WAY DISSECTORS.       */
     22: /*       SEP - VECTOR CONTAINING THE DISSECTOR NODES.            */
     23: /*                                                               */
     24: /*    UPDATED PARAMETER -                                        */
     25: /*       MASK - NODES IN THE DISSECTOR HAVE THEIR MASK VALUES    */
     26: /*              SET TO ZERO.                                     */
     27: /*                                                               */
     28: /*    WORKING PARAMETERS-                                        */
     29: /*       (XLS, LS) - LEVEL STRUCTURE USED BY THE ROUTINE FN../../... */
     30: /*                                                               */
     31: /*    PROGRAM SUBROUTINE -                                       */
     32: /*       FN../../...                                                 */
     33: /*****************************************************************/
     36: PetscErrorCode SPARSEPACKfn1wd(PetscInt *root, PetscInt *xadj, PetscInt *adjncy,
     37:                                PetscInt *mask, PetscInt *nsep, PetscInt *sep, PetscInt *nlvl, PetscInt *
     38:                                xls, PetscInt *ls)
     39: {
     40:     /* System generated locals */
     41:     PetscInt  i__1, i__2;

     43:     /* Local variables */
     44:     PetscInt  node, i, j, k;
     45:     PetscReal width, fnlvl;
     46:     PetscInt  kstop, kstrt, lp1beg, lp1end;
     47:     PetscReal deltp1;
     48:     PetscInt  lvlbeg, lvlend;
     49:     PetscInt  nbr, lvl;

     52:     /* Parameter adjustments */
     53:     --ls;
     54:     --xls;
     55:     --sep;
     56:     --mask;
     57:     --adjncy;
     58:     --xadj;

     60:     SPARSEPACKfnroot(root, &xadj[1], &adjncy[1], &mask[1], nlvl, &xls[1], &ls[1]);
     61:     fnlvl = (PetscReal) (*nlvl);
     62:     *nsep = xls[*nlvl + 1] - 1;
     63:     width = (PetscReal) (*nsep) / fnlvl;
     64:     deltp1 = sqrt((width * 3.f + 13.f) / 2.f) + 1.f;
     65:     if (*nsep >= 50 && deltp1 <= fnlvl * .5f) {
     66:         goto L300;
     67:     }
     68: /*       THE COMPONENT IS TOO SMALL, OR THE LEVEL STRUCTURE */
     69: /*       IS VERY LONG AND NARROW. RETURN THE WHOLE COMPONENT.*/
     70:     i__1 = *nsep;
     71:     for (i = 1; i <= i__1; ++i) {
     72:         node = ls[i];
     73:         sep[i] = node;
     74:         mask[node] = 0;
     75:     }
     76:     return(0);
     77: /*       FIND THE PARALLEL DISSECTORS.*/
     78: L300:
     79:     *nsep = 0;
     80:     i = 0;
     81: L400:
     82:     ++i;
     83:     lvl = (PetscInt)((PetscReal) i * deltp1 + .5f);
     84:     if (lvl >= *nlvl) {
     85:         return(0);
     86:     }
     87:     lvlbeg = xls[lvl];
     88:     lp1beg = xls[lvl + 1];
     89:     lvlend = lp1beg - 1;
     90:     lp1end = xls[lvl + 2] - 1;
     91:     i__1 = lp1end;
     92:     for (j = lp1beg; j <= i__1; ++j) {
     93:         node = ls[j];
     94:         xadj[node] = -xadj[node];
     95:     }
     96: /*          NODES IN LEVEL LVL ARE CHOSEN TO FORM DISSECTOR. */
     97: /*          INCLUDE ONLY THOSE WITH NEIGHBORS IN LVL+1 LEVEL. */
     98: /*          XADJ IS USED TEMPORARILY TO MARK NODES IN LVL+1.  */
     99:     i__1 = lvlend;
    100:     for (j = lvlbeg; j <= i__1; ++j) {
    101:         node = ls[j];
    102:         kstrt = xadj[node];
    103:         kstop = (i__2 = xadj[node + 1], (PetscInt)PetscAbsInt(i__2)) - 1;
    104:         i__2 = kstop;
    105:         for (k = kstrt; k <= i__2; ++k) {
    106:             nbr = adjncy[k];
    107:             if (xadj[nbr] > 0) {
    108:                 goto L600;
    109:             }
    110:             ++(*nsep);
    111:             sep[*nsep] = node;
    112:             mask[node] = 0;
    113:             goto L700;
    114: L600:
    115:             ;
    116:         }
    117: L700:
    118:         ;
    119:     }
    120:     i__1 = lp1end;
    121:     for (j = lp1beg; j <= i__1; ++j) {
    122:         node = ls[j];
    123:         xadj[node] = -xadj[node];
    124:     }
    125:     goto L400;
    126: }