SUBROUTINE PROFIT(NR, NDSTK, NEW, NDEG, LVLS2, LVLST, LSTPT,      PRO   10
     * NXTNUM)
C SUBROUTINE PROFIT NUMBERS LEVEL BY LEVEL WITH CONSECUTIVE INTEGERS
C USING A MODIFIED VERSION OF KING*S ALGORITHM.
C   NR-        ROW DIMENSION OF CONNECTION TABLE.
C   NDSTK-     THE CONNECTION TABLE.
C   NEW-       VECTOR TO STORE THE NEW NUMBERING.
C   NDEG(I)-   THE DEGREE OF NODE I.
C   LVLS2-     THE LEVEL STRUCTURE PRODUCED BY PIKLVL.
C              LVLS2(I) = J MEANS VERTEX I HAS BEEN
C              PLACED IN LEVEL J.
C   LVLST-     ON OUTPUT,  CONTAINS THE LEVEL STRUCTURE USED.
C              LVLST(LSTPT(I)),...,LVLST(LSTPT(I+1)-1) ARE
C              THE VERTICES IN LEVEL I.
C   LSTPT(I)-  ON OUTPUT, INDEX INTO LVLST TO FIRST NODE IN LEVEL I.
C              LSTPT(I+1) - LSTPT(I) = NUMBER OF NODES IN I*TH LEVEL.
C   NXTNUM-    ON INPUT AND OUTPUT,  THE NEXT AVAILABLE NUMBER.
C ON IBM 360 OR 370 USE INTEGER * 2 NDSTK.
      INTEGER NDSTK
      INTEGER NEW(1), NDEG(1), LVLS2(1), LVLST(1), LSTPT(1)
      DIMENSION NDSTK(NR,1)
C COMMON AREA GRA HOLDS VITAL INFORMATION ABOUT THE GRAPH
C N-         THE NUMBER OF NODES
C IDPTH-     THE NUMBER OF LEVELS FOUND BY PIKLVL.
C IDEG-      MAXIMUM DEGREE OF GRAPH -- COLUMN DIMENSION OF NDSTK.
      COMMON /GRA/ N, IDPTH, IDEG
C IT IS ASSUMED THAT NO LEVEL HAS MORE THAN 100 NODES.
      COMMON /LVLW/ S2(100), S3(100), Q(100)
      COMMON /CC/ CONECT(100)
      INTEGER S2, S3, Q, CONECT, S2SZE, S3SZE, QPTR, CONSZE
C SET UP LVLST AND LSTPT FROM LVLS2.
      NSTPT = 1
      DO 20 I=1,IDPTH
        LSTPT(I) = NSTPT
        DO 10 J=1,N
          IF (LVLS2(J).NE.I) GO TO 10
          LVLST(NSTPT) = J
          NSTPT = NSTPT + 1
   10   CONTINUE
   20 CONTINUE
      LSTPT(IDPTH+1) = NSTPT
C ******************  STEP P0   ****************************************
C  S2 IS THE FIRST LEVEL.
      LEVEL = 1
      CALL FORMLV(S2, S2SZE, LSTPT, LVLST, LEVEL)
C ******************  STEP P1   ****************************************
C  S3 IS THE LEVEL ADJACENT TO THE LEVEL S2.
C  Q IS A QUEUE USED TO RETAIN THE ORDER IN WHICH THE ELEMENTS OF S3
C  ARE REMOVED.  Q EVENTUALLY BECOMES THE NEW S2 AND IS ORDERED
C  ACCORDING TO KING*S CRITERA.
   30 CALL FORMLV(S3, S3SZE, LSTPT, LVLST, LEVEL+1)
      QPTR = 0
C ******************  STEP P2   ****************************************
C  FIND THE NODE M IN S2 WHICH IS ADJACENT TO THE FEWEST NODES IN S3.
   40 M = MINCON(S2,S2SZE,S3,S3SZE,CONECT,CONSZE,NDSTK,NR,NDEG)
C ******************  STEP P3   ****************************************
C  NUMBER M AND REMOVE IT FROM S2.
      NEW(M) = NXTNUM
      NXTNUM = NXTNUM + 1
      CALL DELETE(S2, S2SZE, M)
      IF (CONSZE.LE.0) GO TO 60
C THE ELEMENTS OF CONLST ARE TO BE REMOVED FROM S3 AND PLACED INTO
C Q.
      DO 50 I=1,CONSZE
        QPTR = QPTR + 1
        Q(QPTR) = CONECT(I)
        CALL DELETE(S3, S3SZE, CONECT(I))
   50 CONTINUE
C ******************  STEP P4   ****************************************
   60 IF (S2SZE.LE.0) GO TO 80
C ******************  STEP P5   ****************************************
      IF (S3SZE.GT.0) GO TO 40
C ******************  STEP P6   ****************************************
C  S3 IS EMPTY, BUT S2 IS NOT.  RENUMBER THE NODES WHICH REMAIN IN S2.
      DO 70 I=1,S2SZE
        NS2 = S2(I)
        NEW(NS2) = NXTNUM
        NXTNUM = NXTNUM + 1
   70 CONTINUE
      GO TO 100
C ******************  STEP P7   ****************************************
   80 IF (S3SZE.LE.0) GO TO 100
C S2 IS EMPTY, BUT S3 IS NOT.  MOVE S3*S REMAINING NODES INTO Q.
      DO 90 I=1,S3SZE
        QPTR = QPTR + 1
        Q(QPTR) = S3(I)
   90 CONTINUE
C ******************  STEP P8   ****************************************
  100 LEVEL = LEVEL + 1
      IF (LEVEL.GE.IDPTH) GO TO 120
C S2 BECOMES THE OLD Q SINCE BOTH S2 AND S3 ARE EMPTY.
      DO 110 I=1,QPTR
        S2(I) = Q(I)
  110 CONTINUE
      S2SZE = QPTR
      GO TO 30
C ******************  STEP P9   ****************************************
C  LAST LEVEL IS ORDERED IN Q,  SO NUMBER IT BEFORE RETURNING.
  120 DO 130 I=1,QPTR
        IQ = Q(I)
        NEW(IQ) = NXTNUM
        NXTNUM = NXTNUM + 1
  130 CONTINUE
      RETURN
      END
      FUNCTION MINCON(X, XSZE, Y, YSZE, CONLST, CONSZE, NDSTK, NR,      MIN   10
     * NDEG)
C FUNCTION MINCON RETURNS AS ITS FUNCTIONAL VALUE A VERTEX X(I) SUCH
C THAT THE NUMBER OF CONNECTIONS FROM X(I) TO THE SET Y IS A MINIMUM.
C THE VERTICES OF Y WHICH ARE ADJACENT TO X(I) ARE PLACED IN
C CONLST(1), CONLST(2),...,CONLST(CONSZE).
C USE INTEGER * 2 NDSTK ON IBM 360 OR 370.
      INTEGER NDSTK
      DIMENSION NDSTK(NR,1)
      INTEGER X(1), XSZE, Y(1), YSZE, CONLST(1), CONSZE, NDEG(1)
C IT IS ASSUMED THAT NO LEVEL HAS MORE THAN 100 VERTICES.
      INTEGER SMLST(100)
      CONSZE = YSZE + 1
      DO 50 I=1,XSZE
        LSTSZE = 0
        IX = X(I)
        IROWDG = NDEG(IX)
        DO 20 J=1,YSZE
          DO 10 K=1,IROWDG
            IX = X(I)
            IF (NDSTK(IX,K).NE.Y(J)) GO TO 10
            SMLST(LSTSZE+1) = Y(J)
            LSTSZE = LSTSZE + 1
            IF (LSTSZE.GE.CONSZE) GO TO 50
            GO TO 20
   10     CONTINUE
   20   CONTINUE
        IF (LSTSZE.GT.0) GO TO 30
C WE HAVE FOUND A VERTEX IN X WHICH IS NOT CONNECTED TO ANY VERTEX
C IN Y
        MINCON = X(I)
        CONSZE = 0
        RETURN
C WE HAVE FOUND A VERTEX X(I) WITH FEWEST CONNECTIONS (NONZERO) TO Y
C SO FAR.  SAVE THE ELEMENTS OF Y WHICH CONNECT TO X(I) IN CONLST AND
C SAVE X(I) AS THE FUNCTIONAL VALUE.
   30   CONSZE = LSTSZE
        DO 40 J=1,LSTSZE
          CONLST(J) = SMLST(J)
   40   CONTINUE
        MINCON = X(I)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE DELETE(SET, SETSZE, ELEMNT)                            DEL   10
C SUBROUTINE DELETE REMOVES ELEMNT FROM THE SET SET IF ELEMNT
C IS IN SET.  OTHERWISE,  IT ISSUES A DIAGNOSTIC.
      INTEGER SET(1), SETSZE, ELEMNT
      IF (SETSZE.GT.1) GO TO 10
      IF (SETSZE.EQ.1 .AND. SET(1).NE.ELEMNT) GO TO 30
      SETSZE = 0
      RETURN
   10 DO 20 I=1,SETSZE
        IF (SET(I).EQ.ELEMNT) GO TO 40
   20 CONTINUE
   30 WRITE (6,99999) ELEMNT, (SET(I),I=1,SETSZE)
      RETURN
   40 SETSZE = SETSZE - 1
      DO 50 J=I,SETSZE
        SET(J) = SET(J+1)
   50 CONTINUE
      RETURN
99999 FORMAT (10H0ERROR -- , I6, 8H NOT IN , (20I5))
      END
      SUBROUTINE FORMLV(SET, SETSZE, LSTPT, LVLST, LEVEL)               FOR   10
C FORMLVL COPIES LEVEL(LEVEL) INTO SET.
      INTEGER SET(1), SETSZE, LSTPT(1), LVLST(1), UPPER
      LOWER = LSTPT(LEVEL)
      UPPER = LSTPT(LEVEL+1) - 1
      SETSZE = 1
      DO 10 I=LOWER,UPPER
        SET(SETSZE) = LVLST(I)
        SETSZE = SETSZE + 1
   10 CONTINUE
      SETSZE = SETSZE - 1
      RETURN
      END
      SUBROUTINE CHECK(BESTBW, BESTPF, RENUM, NDSTK, NR, NDEG, IWK)     CHE   10
C SUBROUTINE CHECK TESTS TO SEE IF REVERSED NUMBERING GIVES BETTER
C PROFILE THAN PROFIT.  IF IT DOES, THEN RENUM IS REVERSED AND BESTPF
C IS SET TO THE SMALLEST OF RENUM AND REVERSED RENUM.
C USE INTEGER * 2 NDSTK ON IBM 360 OR 370
      INTEGER NDSTK
      DIMENSION NDSTK(NR,1)
      INTEGER BESTBW, BESTPF, RENUM(1), NDEG(1), IWK(1)
      COMMON /GRA/ N, IDPTH, IDEG
      DO 10 I=1,N
        IWK(I) = N - RENUM(I) + 1
   10 CONTINUE
      CALL BAND(BESTBW, BESTPF, RENUM, NDSTK, NR, NDEG)
      CALL BAND(IBW, IPF, IWK, NDSTK, NR, NDEG)
      IF (IPF.GE.BESTPF) RETURN
      DO 20 I=1,N
        RENUM(I) = IWK(I)
   20 CONTINUE
      BESTPF = IPF
      RETURN
      END
      SUBROUTINE BAND(IBW, IPF, NEW, NDSTK, NR, NDEG)                   BAN   10
C SUBROUTINE BAND COMPUTES THE BANDWIDTH IBW AND THE PROFILE
C IPF OF THE GRAPH REPRESENTED BY NDSTK USING THE NUMBERING NEW.
C ON IBM 360 OR 370 USE INTEGER * 2 NDSTK.
      INTEGER NDSTK
      DIMENSION NDSTK(NR,1), NEW(1), NDEG(1)
      COMMON /GRA/ N, IDPTH, IDEG
      IPF = 0
      IBW = 0
      DO 20 K=1,N
        IEND = NDEG(K)
        IF (IEND.EQ.0) GO TO 20
        NBW = 0
        DO 10 J=1,IEND
          IDUMMY = NDSTK(K,J)
          NTEST = NEW(K) - NEW(IDUMMY)
          IF (NTEST.LE.NBW) GO TO 10
          NBW = NTEST
   10   CONTINUE
        IPF = IPF + NBW
        IF (NBW.GT.IBW) IBW = NBW
   20 CONTINUE
      RETURN
      END

.