C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE RENUM (NPNODE, NPELEM, MXNFLG, MXSFLG, NPNBC, NPSBC,
     &   NPWTS, NPREGN, MP, ML, MS, MR, MSC, MAXKXN, NNUID, NNXK,
     &   MXLPS, IUNIT, NNN, KKK, KCRD, NL, NPBF, NLBF, NSBF, IPART,
     &   LSTNBC, LSTSBC, NNFLG, NNPTR, NNLEN, NSFLG, NSPTR, NSLEN,
     &   NVPTR, NVLEN, NSIDEN, NUID, XN, YN, NXK, MAT, KXN, LIST, LA,
     &   LB, MATMAP, LISTN, WTNODE, WTSIDE, WTHOLD, IHERE, ILIST, XLIST,
     &   NUMMAT, NBCNOD, NNLIST, NBCSID, NSLIST, NVLIST, COOR, ILINE,
     &   LTYPE, LCON, ISIDE, NLPS, IFLINE, ILLIST, LINKP, LINKL, LINKS,
     &   LINKR, IMAT, LINKB, JMAT, IPBF, NPPF, IFPB, LISTPB, IWTPBF,
     &   ILBF, NLPF, IFLB, LISTLB, IWTLBF, ISBF, NSPF, IFSB, LISTSB,
     &   IWTSBF, LINKPB, LINKLB, LINKSB, NUMBER, THREE, EIGHT, NINE,
     &   OPTIM, ISBARS)
C***********************************************************************

C  SUBROUTINE RENUM = NUMBERS QMESH OUTPUT, AND RENUMBERS AS NEEDED FOR
C                     OPTIMIZATION

C***********************************************************************

C    THE REFERENCE DOCUMENTS FOR THIS CODE ARE SLA-73-1088, JULY 1974,
C    AND SLA-74-0239, JULY 1974

C***********************************************************************

      DIMENSION NLIST(20), IPART(3, NPREGN)
      DIMENSION COOR(2, MP), ILINE(ML), LTYPE(ML), LCON(3, ML)
      DIMENSION ISIDE(MS), NLPS(MS), IFLINE(MS), ILLIST(MS*3)
      DIMENSION LINKP(2, MP), LINKL(2, ML), LINKS(2, MS), LINKB(2, MS)
      DIMENSION LINKR(2, MR)
      DIMENSION IMAT(MR), JMAT(MS)
      DIMENSION IPBF(MP), NPPF(MP), IFPB(MP), LISTPB(2, MP)
      DIMENSION ILBF(ML), NLPF(ML), IFLB(ML), LISTLB(2, ML)
      DIMENSION ISBF(ML), NSPF(ML), IFSB(ML), LISTSB(2, ML)
      DIMENSION IWTPBF(3, MP), IWTLBF(3, ML), IWTSBF(3, ML)
      DIMENSION LINKPB(2, MP), LINKLB(2, ML), LINKSB(2, ML)

      DIMENSION LIST(NNUID), LISTN(NNUID), NUID(NNUID), XN(NPNODE)
      DIMENSION YN(NPNODE), NXK(NNXK, NPELEM), MAT(NPELEM)
      DIMENSION KXN(NNXK, MAXKXN), LA(NPNODE), LB(NPNODE)
      DIMENSION IHERE(NNUID), ILIST(MXLPS), XLIST(MXLPS)

      DIMENSION LSTNBC(NPNBC), LSTSBC(NPSBC), NSIDEN(NPSBC)
      DIMENSION NNFLG(MXNFLG), NNLEN(MXNFLG), NNPTR(MXNFLG)
      DIMENSION NSFLG(MXSFLG), NSLEN(MXSFLG), NSPTR(MXSFLG)
      DIMENSION WTHOLD(NPWTS), WTNODE(NPNBC), WTSIDE(NPSBC)
      DIMENSION NVLEN(MXSFLG), NVPTR(MXSFLG), MATMAP(3, NPREGN)

      DIMENSION KLIST(20)

      LOGICAL OPTIM, ERR, NOROOM, ALL, THREE, EIGHT, NINE
      LOGICAL ITSOK, ISBARS

      CHARACTER*80 NUMBER(MSC)

C  HEADER

      CALL MESSAGE(' ')
      CALL MESSAGE('NUMBERING OF GENERATED OUTPUT BEGUN')
      IF (OPTIM) CALL MESSAGE('  -- OPTIMIZATION IS ENABLED --')

C  READ THE MESH TAPE

      CALL RDMESH (NPNODE, NPELEM, NPNBC, NPSBC, NPREGN, MS, MR, NNUID,
     &   NNXK, IUNIT, NNN, KKK, IPART, LSTNBC, LSTSBC, NUID, XN, YN,
     &   NXK, MAT, MATMAP, NUMMAT, ISIDE, NLPS, IFLINE, ILLIST, LINKS,
     &   LINKR, IMAT, LINKB, JMAT, NNNBC, NNSBC, ERR)
      IF (ERR) THEN
         CALL MESSAGE('** NUMBERING ABORT **')
         RETURN
      END IF

C  SORT NODE LIST INTO INCREASING NUID-S

      DO 100 I = 1, NNN
         LISTN(I) = NUID(I)
  100 CONTINUE
      IF (OPTIM) THEN
         CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN)
      ELSE
         DO 110 I = 1, NNN
            LIST(I) = I
  110    CONTINUE
         CALL SORT (NNN, NUID, LIST)
      END IF

C  CONVERT REFERENCES TO NUID-S TO REFERENCES TO
C  SEQUENCE NUMBERS

      DO 130 I = 1, 4
         DO 120 K = 1, KKK
            IF (NXK(I, K) .GT. 0) THEN
               NEW = INDX(NNN, NUID, NXK(I, K))
               IF (NEW .EQ. 0) THEN
                  CALL MESSAGE('ERROR SORTING NUMBERING DATA -- NODE')
                  CALL MESSAGE('*** NO MESH SAVED ***')
                  KKK = 0
                  RETURN
               END IF
               IF (OPTIM) THEN
                  NXK(I, K) = NEW
               ELSE
                  NXK(I, K) = LIST(NEW)
               END IF
            END IF
  120    CONTINUE
  130 CONTINUE

      IF (NNNBC .GT. 0) THEN
         DO 140 I = 1, NNNBC
            IF (LSTNBC(I) .GT. 0) THEN
               NEW = INDX(NNN, NUID, LSTNBC(I))
               IF (NEW .EQ. 0) THEN
                  CALL MESSAGE('ERROR SORTING NUMBERING DATA -- NBC')
                  CALL MESSAGE('*** NO MESH SAVED ***')
                  KKK = 0
                  RETURN
               END IF
               IF (OPTIM) THEN
                  LSTNBC(I) = NEW
               ELSE
                  LSTNBC(I) = LIST(NEW)
               END IF
            END IF
  140    CONTINUE
      END IF

C  BUILD KXN ARRAY

      NUMKXN = NNN
      DO 160 I = 1, NNXK
         DO 150 J = 1, MAXKXN
            KXN(I, J) = 0
  150    CONTINUE
  160 CONTINUE

      DO 180 I = 1, 4
         DO 170 K = 1, KKK
            IF (NXK(I, K) .GT. 0) THEN
               CALL KXNADD (MAXKXN, NNXK, KXN, NUMKXN, K, NXK(I, K),
     &            ERR)
               IF (ERR) THEN
                  CALL MESSAGE('** NUMBERING ABORT **')
                  KKK = 0
                  RETURN
               END IF
            END IF
  170    CONTINUE
  180 CONTINUE
      IF (OPTIM) THEN

C  GET STARTING LIST FOR CUTHILL-MCKEE PROCESS

         IF (KCRD .GT. 0) THEN
            CALL GNLIST (NPNODE, NNUID, MSC, NPNODE, NPELEM, MAXKXN,
     &         NNXK, KXN, NXK, NUID, XN, YN, LIST, NUML, NUMBER, KCRD,
     &         NNN, ERR, NOROOM)
            IF (NOROOM) THEN
               CALL MESSAGE('TOO MANY NODES IN STARTING LIST')
               CALL MESSAGE('*** NO MESH SAVED ***')
               CALL MESSAGE('** NUMBERING ABORT **')
               KKK = 0
               RETURN
            ELSE IF (ERR) THEN
               CALL MESSAGE('ERROR GENERATING STARTING LIST')
               CALL MESSAGE('*** NO MESH SAVED ***')
               CALL MESSAGE('** NUMBERING ABORT **')
               KKK = 0
               RETURN
            END IF
         ELSE
            CALL MESSAGE('NO CARDS AVAILABLE FOR STARTING LIST')
            CALL MESSAGE('FIRST NODE IN THE OUTPUT USED')
            NUML = 1
            LIST(1) = 1
         END IF

C  INITIALIZE LISTS

         DO 190 I = 1, NNN
            LISTN(I) = I
  190    CONTINUE

C  USE LISTN AS A CHECK ON WHETHER THE NODE HAS BEEN USED (NEGATED)

         DO 200 I = 1, NUML
            LA(I) = LIST(I)
            NODE = LIST(I)
            LISTN(NODE) = -LISTN(NODE)
  200    CONTINUE

         NUMA = NUML

C  CREATE LIST OF NEW NODES CONNECTED TO LIST A

  210    CONTINUE
         NUMB = 0
         DO 230 N = 1, NUMA
            ALL = .TRUE.
            CALL GETNXN (NPNODE, NPELEM, MAXKXN, NNXK, KXN, NXK, LISTN,
     &         LA(N), NLIST, NUMB1, ALL, ERR)
            IF (ERR) THEN
               CALL MESSAGE('** NUMBERING ABORT **')
               KKK = 0
               RETURN
            END IF
            IF (NUMB1 .GT. 0) THEN
               IF ((NUMB + NUMB1) .GT. NPNODE) THEN
                  CALL MESSAGE('LIST B HAS OVERFLOWED')
                  CALL MESSAGE('*** NO MESH SAVED  ***')
                  CALL MESSAGE('** NUMBERING ABORT **')
                  KKK = 0
                  RETURN
               END IF
               DO 220 I = 1, NUMB1
                  NODE = NLIST(I)
                  NUMB = NUMB + 1
                  LB(NUMB) = NODE
                  LISTN(NODE) = -LISTN(NODE)
  220          CONTINUE
            END IF
  230    CONTINUE
         IF (NUMB .GT. 0) THEN

C  INCLUDE LIST B INTO FULL LIST
C  ALSO TRANSFER LIST B TO LIST A

            DO 240 I = 1, NUMB
               NUML = NUML + 1
               LIST(NUML) = LB(I)
               LA(I) = LB(I)
  240       CONTINUE
            NUMA = NUMB

C  CHECK FOR CONVERGENCE

            IF (NUML .LT. NNN) GO TO 210

C  PROCESS HAS CONVERGED
C  CHECK IF ALL NODES WERE COVERED

         ELSE IF (NUML .LT. NNN) THEN

            DO 250 I = 1, NNN
               IF (LISTN(I) .GT. 0) THEN

C  START THE LIST AGAIN WITH THE MISSED NODE

                  CALL MESSAGE('A DISCONTINUITY (SLIDE LINE) IN THE '//
     &               'BODY HAS BEEN FOUND')
                  CALL MESSAGE
     &               ('SEPARATE PART NUMBERING WILL ALSO BE OPTIMIZED')
                  NUMA = 1
                  LA(1) = I
                  GO TO 210
               END IF
  250       CONTINUE

C  DEFINITE ERROR IN THE NUMBERING PROCESS

            CALL MESSAGE('ALL NODES COULD NOT BE FOUND TO NUMBER')
            CALL MESSAGE('       *** NO MESH SAVED ***')
            CALL MESSAGE('       ** NUMBERING ABORT **')
            KKK = 0
            RETURN
         END IF

C  PREPARE TO PUT NODE LIST INTO NEWLY DETERMINED ORDER
C  LISTN BECOMES THE POINTER FROM THE OLD NUMBER TO THE NEW

         DO 260 I = 1, NNN
            J = LIST(I)
            LISTN(J) = I
  260    CONTINUE

C  CONVERT NODE NUMBERS TO NEW NODE ORDER BY REDOING THE NXK ARRAY

         DO 280 I = 1, 4
            DO 270 K = 1, KKK
               J = NXK(I, K)
               IF (J .GT. 0) NXK(I, K) = LISTN(J)
  270       CONTINUE
  280    CONTINUE

         IF (NNNBC .GT. 0) THEN
            DO 290 I = 1, NNNBC
               IF (LSTNBC(I) .GT. 0) THEN
                  J = LSTNBC(I)
                  LSTNBC(I) = LISTN(J)
               END IF
  290       CONTINUE
         END IF

C  PUT NODE LIST INTO NEW ORDER

         CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN)

C  REBUILD KXN ARRAY

         NUMKXN = NNN
         DO 310 I = 1, NNXK
            DO 300 J = 1, MAXKXN
               KXN(I, J) = 0
  300       CONTINUE
  310    CONTINUE

         DO 330 I = 1, 4
            DO 320 K = 1, KKK
               IF (NXK(I, K) .GT. 0) THEN
                  CALL KXNADD (MAXKXN, NNXK, KXN, NUMKXN, K, NXK(I, K),
     &               ERR)
                  IF (ERR) THEN
                     CALL MESSAGE('** NUMBERING ABORT **')
                     KKK = 0
                     RETURN
                  END IF
               END IF
  320       CONTINUE
  330    CONTINUE

C  PUT ELEMENT NUMBERING INTO NEW ORDER USING LA AS TEMPORARY STORAGE

         DO 340 I = 1, KKK
            LA(I) = 0
            LB(I) = 0
  340    CONTINUE
         KOUNT = 0
         DO 360 I = 1, NNN
            CALL GETKXN (NPNODE, MAXKXN, NNXK, KXN, NUID, I, KLIST,
     &         NUMK, ERR)
            DO 350 J = 1, NUMK
               IF (LB(KLIST(J)) .EQ. 0) THEN
                  KOUNT = KOUNT + 1
                  LA(KOUNT) = KLIST(J)
                  LB(KLIST(J)) = 1
               END IF
  350       CONTINUE
  360    CONTINUE

C  END OF OPTIMIZATION

      ELSE
         DO 370 I = 1, NNN
            NUID(I) = LISTN(I)
  370    CONTINUE
      END IF

C  STICK LSTNBC INTO LISTN AS A WORK ARRAY FOR SORTING NODAL BOUNDARY
C  CONDITIONS LISTS

      IF (NNNBC .GT. 0) THEN
         DO 380 I = 1, NNNBC
            LISTN(I) = LSTNBC(I)
  380    CONTINUE

C  SORT THROUGH LSTNBC AND RECREATE IT IN PLACE
C  USING LISTN AS THE ARRAY TO TAKE LSTNBC OVER
C  AND IHERE AS A WORK ARRAY
C  (LSTNBC NOW BECOMES THE NODES ARRAY FOR THE
C  GENESIS DATA BASE)

         CALL SRTNBC (MXNFLG, NPNBC, NNN, NNFLG, NNLEN, NNPTR, LSTNBC,
     &      LISTN, IHERE, NNNBC, NBCNOD, NNLIST)
      ELSE
         NNLIST = 0
         NBCNOD = 0
      END IF

C  SORT THROUGH LSTSBC AND RECREATE IT IN PLACE
C  USING LISTN AS THE ARRAY TO TAKE LSTSBC OVER
C  AND KXN AS A WORK ARRAY
C  (LSTSBC NOW BECOMES THE NELEMS ARRAY FOR THE
C  GENESIS DATA BASE)

      IF (NNSBC .GT. 0) THEN
         DO 390 I = 1, NNSBC
            LISTN(I) = LSTSBC(I)
  390    CONTINUE

         CALL SRTSBC (MXSFLG, NPSBC, NPELEM, NNXK, NXK, NSFLG, NSLEN,
     &      NSPTR, NVLEN, NVPTR, LISTN, LSTSBC, NSIDEN, IHERE, NNSBC,
     &      NSLIST, NVLIST, NBCSID)

      ELSE
         NBCSID = 0
         NSLIST = 0
         NVLIST = 0
      END IF

C  PUT WEIGHTS ON FLAGGED NODES AS NEEDED
C  USE THE IHERE ARRAY AS A WORK ARRAY

      CALL ADDWT (NNUID, NNXK, MAXKXN, NPNODE, NPELEM, MXLPS, MP, ML,
     &   MS, NPNBC, NPSBC, MXNFLG, MXSFLG, NPWTS, COOR, ILINE, LTYPE,
     &   LCON, ISIDE, NLPS, IFLINE, ILLIST, LINKP, LINKL, LINKS, IPBF,
     &   NPPF, IFPB, LISTPB, IWTPBF, ILBF, NLPF, IFLB, LISTLB, IWTLBF,
     &   ISBF, NSPF, IFSB, LISTSB, IWTSBF, LINKPB, LINKLB, LINKSB, XN,
     &   YN, NUID, NXK, KXN, LSTNBC, NNFLG, NNPTR, NNLEN, NSFLG, NVPTR,
     &   NVLEN, NSIDEN, WTNODE, WTSIDE, WTHOLD, NBCNOD, NNLIST, NBCSID,
     &   NSLIST, NVLIST, ILIST, XLIST)

C  SORT NUMBERS ACCORDING TO MATERIAL TYPE
C  USE KXN AS A WORK ARRAY

      DO 410 J = 1, 4
         DO 400 I = 1, KKK
            KXN(J, I) = NXK(J, I)
  400    CONTINUE
  410 CONTINUE

C  SET UP THE MATERIAL MAPPING ARRAY
C      MATMAP(1, I) = THE MATERIAL ID FOR THE I'TH BLOCK
C      MATMAP(2, I) = THE FIRST ELEMENT IN THE I'TH BLOCK
C      MATMAP(3, I) = THE LAST ELEMENT IN THE I'TH BLOCK

      KOUNT = 1
      DO 440 I = 1, NUMMAT
         KMAT = MATMAP(1, I)
         MATMAP(2, I) = KOUNT
         DO 430 J = 1, KKK
            IF (MAT(J) .EQ. KMAT) THEN
               LISTN(J) = KOUNT
               LIST(KOUNT) = J
               DO 420 K = 1, 4
                  NXK(K, KOUNT) = KXN(K, J)
  420          CONTINUE
               KOUNT = KOUNT + 1
            END IF
  430    CONTINUE
         MATMAP(3, I) = KOUNT - 1
  440 CONTINUE
      IF (KOUNT - 1 .NE. KKK) THEN
         CALL MESSAGE('ALL ELEMENTS DID NOT HAVE AN ELEMENT ID')
         CALL MESSAGE('MESH NUMBERING ABORTED')
         KKK = 0
         RETURN
      END IF

C  REDO THE REGION POINTER ARRAY

      DO 450 I = 1, NPREGN
         IPART(2, I) = LISTN(IPART(2, I))
         IPART(3, I) = LISTN(IPART(3, I))
  450 CONTINUE

C  REDO THE MATERIAL ARRAY

      DO 470 I = 1, NUMMAT
         DO 460 J = MATMAP(2, I), MATMAP(3, I)
            MAT(J) = MATMAP(1, I)
  460    CONTINUE
  470 CONTINUE

C  REDO THE MAPPING ARRAY IF OPTIMIZING RENUMBERING HAS BEEN DONE

      IF (OPTIM) THEN
         DO 480 I = 1, KKK
            LA(I) = LISTN(LA(I))
  480    CONTINUE
      END IF

C  REDO THE ELEMENT SIDE BOUNDARY LISTING WITH THE CURRENT ELEMENT NO.

      DO 490 I = 1, NSLIST
         LSTSBC(I) = LISTN(LSTSBC(I))
  490 CONTINUE

C  STORE THE LISTN POINTER SYSTEM FOR NOW

      DO 500 I = 1, KKK
         LIST(I) = LISTN(I)
  500 CONTINUE

C  ADD THE MID-SIDE NODES IF EIGHT OR NINE NODE QUADS ARE WANTED
C  OR IF THREE NODE BARS ARE WANTED

      IF ((EIGHT) .OR. (NINE) .OR. (THREE)) THEN

C  FLAG ALL ELEMENT SIDES ONLY ONCE (NO SHARED SIDE FLAGGED)

         CALL NXKBDY (NNXK * MAXKXN, NNXK, NPELEM, NXK, KKK, KXN,
     &      THREE, EIGHT, NINE)

C  CREATE THE MIDSIDE NODES

         CALL MIDNOD (NPNODE, NNUID, NPELEM, NNXK, MP, ML, KKK, NNN,
     &      NALL, NL, NXK, NUID, XN, YN, LISTN, COOR, ILINE, LTYPE,
     &      LCON, LINKP, LINKL, THREE, EIGHT, NINE)

C  MODIFY THE IDENTIFIERS OF THE OLD NODES

         DO 510 I = 1, NNN
            LISTN(I) = I * 100000
  510    CONTINUE
         NNN = NALL

C  ORDER THE EXPANDED NODE LIST

         CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN)

C  EXPAND THE CONNECTIVITY ARRAY TO INCLUDE THE MIDSIDE NODES
C  WHILE REPOSITIONING THE CORNER NODES INTO PROPER SEQUENCE

         DO 540 I = 1, KKK
            IF ((THREE) .AND. (NXK (3, I) .EQ. 0)) THEN
               ITSOK = .TRUE.
            ELSEIF ((NXK (3, I) .NE. 0) .AND. ((EIGHT) .OR. (NINE)))
     &         THEN
               ITSOK = .TRUE.
            ELSE
               ITSOK = .FALSE.
            ENDIF
            IF (ITSOK) THEN
               DO 520 J = 4, 1, -1
                  JJ = J + 1
                  IF (JJ .EQ. 5) JJ = 1
                  NODEA = IABS(NXK(J, I))
                  NODEB = IABS(NXK(JJ, I))

C  CHECK FOR 3 NODE BAR ELEMENTS

                  IF ((NODEA .GT. 0) .AND. (NODEB .GT. 0)) THEN
                     NXK (J * 2 - 1, I) = NODEA * 100000
                     NLO = MIN0(NODEA, NODEB)
                     NHI = MAX0(NODEA, NODEB)
                     NXK (J * 2, I) = NLO * 100000 + NHI
                  ELSE IF (NODEA .GT. 0) THEN
                     NXK (J * 2 - 1, I) = NODEA * 100000
                  END IF
  520          CONTINUE
            ELSE
               DO 530 J = 1, 4
                  NXK (J, I) = IABS (NXK (J,I)) * 100000
  530          CONTINUE
            ENDIF
  540    CONTINUE

C  GET THE LIST OF NODAL BOUNDARY FLAGS EXTENDED AND THE NEW IDENTIFIERS
C  IN PLACE (USE NUID AND WTHOLD AS WORK ARRAYS)

         IF (NBCNOD .GT. 0) THEN
            KOUNT = 0
            DO 570 I = 1, NBCNOD
               JEND = NNLEN(I) + NNPTR(I) - 1
               DO 560 J = NNPTR(I), JEND
                  KOUNT = KOUNT + 1
                  NUID(KOUNT) = LSTNBC(J) * 100000
                  WTHOLD(KOUNT) = WTNODE(J)
                  DO 550 K = J + 1, JEND
                     ILO = MIN0(LSTNBC(J), LSTNBC(K))
                     IHI = MAX0(LSTNBC(J), LSTNBC(K))
                     ITRY = (ILO * 100000) + IHI
                     IF (INDX(NNN, LISTN, ITRY) .GT. 0) THEN
                        KOUNT = KOUNT + 1
                        NNLEN(I) = NNLEN(I) + 1
                        NUID(KOUNT) = ITRY
                        WTHOLD(KOUNT) = (WTNODE(J) + WTNODE(K)) * .5
                     END IF
  550             CONTINUE
  560          CONTINUE
               IF (I .NE. 1) NNPTR(I) = NNPTR(I - 1) + NNLEN(I - 1)
  570       CONTINUE
            NNLIST = KOUNT
            DO 580 I = 1, NNLIST
               LSTNBC(I) = NUID(I)
               WTNODE(I) = WTHOLD(I)
  580       CONTINUE
         END IF

C  GET THE LIST OF SIDE BOUNDARY FLAGS EXTENDED AND THE NEW IDENTIFIERS
C  IN PLACE (USE NUID, WTHOLD, AND KXN AS WORK ARRAYS)

         IF (NBCSID .GT. 0) THEN
            KOUNT = 0
            KOUNT2 = 0
            DO 600 I = 1, NBCSID
               ISTART = NSPTR (I)
               IEND = NSPTR (I) + NSLEN (I) - 1
               J = NVPTR (I)
               JEND = NVPTR (I) + NVLEN (I) - 1
               DO 590 II = ISTART, IEND
                  KELEM = LSTSBC (II)
                  KOUNT = KOUNT + 1
                  KXN (1, KOUNT) = KELEM
                  K = J + 1
                  KOUNT2 = KOUNT2 + 1
                  NUID(KOUNT2) = NSIDEN(J) * 100000
                  WTHOLD(KOUNT2) = WTSIDE(J)

C  DO THE ADJUSTMENTS IF THE ELEMENT IS ONE THAT HAS BEEN EXPANDED

                  IF ( ((THREE) .AND. (NXK (4, KELEM) .EQ. 0)) .OR.
     &               ( ((EIGHT) .OR. (NINE)) .AND.
     &               (NXK (4, KELEM) .NE. 0) ) ) THEN
                     KOUNT = KOUNT + 1
                     KXN (1, KOUNT) = LSTSBC(II)
                     NSLEN (I) = NSLEN (I) + 1
                     ILO = MIN0(NSIDEN(J), NSIDEN(K))
                     IHI = MAX0(NSIDEN(J), NSIDEN(K))
                     ITRY = (ILO * 100000) + IHI
                     KOUNT2 = KOUNT2 + 1
                     NUID(KOUNT2) = ITRY
                     WTHOLD(KOUNT2) = (WTSIDE(J) + WTSIDE(K)) * .5
                     KOUNT2 = KOUNT2 + 1
                     NUID(KOUNT2) = ITRY
                     WTHOLD(KOUNT2) = (WTSIDE(J) + WTSIDE(K)) * .5
                     NVLEN(I) = NVLEN(I) + 2
                  ENDIF
                  KOUNT2 = KOUNT2 + 1
                  NUID(KOUNT2) = NSIDEN(K) * 100000
                  WTHOLD(KOUNT2) = WTSIDE(K)
                  J = J + 2
  590          CONTINUE
               IF (I .GT. 1) THEN
                  NSPTR(I) = NSPTR(I - 1) + NSLEN(I - 1)
                  NVPTR(I) = NVPTR(I - 1) + NVLEN(I - 1)
               ENDIF
  600       CONTINUE

C  TRANSFER THE ELEMENT BOUNDARIES BACK FROM THE WORK ARRAYS

            NSLIST = KOUNT
            DO 610 I = 1, NSLIST
               LSTSBC(I) = KXN(1, I)
  610       CONTINUE
            NVLIST = KOUNT2
            DO 620 I = 1, NVLIST
               NSIDEN(I) = NUID(I)
               WTSIDE(I) = WTHOLD(I)
  620       CONTINUE
         END IF

C  ADD A CENTER NODE TO THE NODE LIST IF NEEDED

         IF (NINE) THEN
            NOLD = NNN
            DO 630 I = 1, KKK

C  WATCH OUT FOR 3 NODE BAR ELEMENTS

               IF (.NOT. ISBARS .OR. NXK(4, I) .GT. 0) THEN
                  N2 = INDX(NOLD, LISTN, NXK(2, I))
                  N4 = INDX(NOLD, LISTN, NXK(4, I))
                  N6 = INDX(NOLD, LISTN, NXK(6, I))
                  N8 = INDX(NOLD, LISTN, NXK(8, I))
                  IF ((N2 .EQ. 0) .OR. (N4 .EQ. 0) .OR.
     &               (N6 .EQ. 0) .OR. (N8 .EQ. 0)) THEN
                     CALL MESSAGE('BAD LINK IN RENUM AT 8 NODE LIST')
                     CALL MESSAGE('NO MESH SAVED')
                     KKK = 0
                     RETURN
                  END IF
                  DIST1 = SQRT((XN(N2) - XN(N6)) **2
     &               + (YN(N2) - YN(N6)) **2)
                  DIST2 = SQRT((XN(N8) - XN(N4)) **2
     &               + (YN(N8) - YN(N4)) **2)
                  NNN = NNN + 1
                  IF (DIST1 .LT. DIST2) THEN
                     XN(NNN) = .5 * (XN(N2) + XN(N6))
                     YN(NNN) = .5 * (YN(N2) + YN(N6))
                  ELSE
                     XN(NNN) = .5 * (XN(N4) + XN(N8))
                     YN(NNN) = .5 * (YN(N4) + YN(N8))
                  END IF
                  LISTN(NNN) = INT((MIN0(NXK(1, I), NXK(5, I))) +
     &               (MAX0(NXK(1, I), NXK(5, I)) * .0001))
                  NXK(9, I) = LISTN(NNN)
                ELSE
                  write (*,*) 'Element ', i, ' is a 3-node bar?'
               END IF
  630       CONTINUE

C  NOW, ORDER THE EXPANDED NODE LIST AGAIN

            CALL NODORD (NPNODE, XN, YN, LISTN, NUID, NNN)
            IEND = 9
         ELSEIF (EIGHT) THEN
            IEND = 8
         ELSE
            IEND = 4
         END IF

C  NOW REPLACE THE NODE REFERENCES WITH AN EXPANDED ORDER NUMBER

C  FIRST FIX THE CONNECTIVITY (NXK ARRAY)

         DO 650 I = 1, IEND
            DO 640 K = 1, KKK

C  AGAIN, WATCH OUT FOR 3 NODE BAR ELEMENTS

               IF (.NOT. ISBARS .OR. NXK(I, K) .GT. 0) THEN
                  NEW = INDX(NNN, LISTN, NXK(I, K))
                  IF (NEW .EQ. 0) THEN
                     CALL MESSAGE('BAD LINK IN RENUM 8 NODE LIST')
                     CALL MESSAGE('NO MESH SAVED')
                     KKK = 0
                     RETURN
                  END IF
                  NXK(I, K) = NEW
               END IF
  640       CONTINUE
  650    CONTINUE

C  NOW FIX THE NODE BOUNDARY FLAGS

         IF (NBCNOD .GT. 0) THEN
            DO 660 I = 1, NNLIST
               NEW = INDX(NNN, LISTN, LSTNBC(I))
               IF (NEW .EQ. 0) THEN
                  CALL MESSAGE('BAD LINK IN RENUM AT 8 NODE NBC')
                  CALL MESSAGE('NO MESH SAVED')
                  KKK = 0
                  RETURN
               END IF
               LSTNBC(I) = NEW
  660       CONTINUE
         END IF

C  NOW FIX THE SIDE BOUNDARY FLAGS

         IF (NBCSID .GT. 0) THEN
            DO 670 I = 1, NVLIST
               NEW = INDX(NNN, LISTN, NSIDEN(I))
               IF (NEW .EQ. 0) THEN
                  CALL MESSAGE('BAD LINK IN RENUM AT 8 NODE SBC')
                  CALL MESSAGE('NO MESH SAVED')
                  KKK = 0
                  RETURN
               END IF
               NSIDEN(I) = NEW
  670       CONTINUE
         END IF
      END IF

C  RENUMBERING COMPLETED

      CALL MESSAGE(' ')
      CALL MESSAGE('**************************************************')
      CALL MESSAGE('**           MESH PROCESSING COMPLETED          **')
      IF (ISBARS .AND. NINE) THEN
         CALL MESSAGE('**            THREE NODE BARS OUTPUT         '//
     &      '   **')
      ENDIF
      IF (NINE) THEN
         CALL MESSAGE('**            NINE NODE QUADS OUTPUT         '//
     &      '   **')
      ELSE IF (EIGHT) THEN
         CALL MESSAGE('**           EIGHT NODE QUADS OUTPUT         '//
     &      '   **')
      END IF
      IF (OPTIM) THEN
         CALL MESSAGE
     &      ('**   WITH NODE AND ELEMENT NUMBERING OPTIMIZED  **')

C  FIND LARGEST NODE DIFFERENCE FOR AN ELEMENT

         LWID = 0
         DO 680 K = 1, KKK
            N1 = NXK(1, K)
            N2 = NXK(2, K)
            N3 = NXK(3, K)
            N4 = NXK(4, K)
            IF ((N4 .GT. 0) .AND. ((EIGHT) .OR. (NINE))) THEN
               N5 = NXK(5, K)
               N6 = NXK(6, K)
               N7 = NXK(7, K)
               N8 = NXK(8, K)
               IF (NINE) THEN
                  N9 = NXK(9, K)
                  NLO = MIN0(N1, N2, N3, N4, N5, N6, N7, N8, N9)
                  NHI = MAX0(N1, N2, N3, N4, N5, N6, N7, N8, N9)
               ELSE
                  NLO = MIN0(N1, N2, N3, N4, N5, N6, N7, N8)
                  NHI = MAX0(N1, N2, N3, N4, N5, N6, N7, N8)
               END IF
            ELSE
               IF (N3 .LE. 0) N3 = N1
               IF (N4 .LE. 0) N4 = N2
               NLO = MIN0(N1, N2, N3, N4)
               NHI = MAX0(N1, N2, N3, N4)
            END IF
            LWID = MAX0(LWID, NHI - NLO)
  680    CONTINUE
         WRITE(*, 10000) LWID
      END IF
      WRITE(*, 10010) NNN, KKK, NUMMAT
      CALL MESSAGE('**************************************************')

C  RESTORE THE NUID ARRAY AS A POINTER ARRAY OF OLD TO NEW ELEMENTS
C  (MAPDXG ARRAY)

      IF (OPTIM) THEN
         DO 690 I = 1, KKK
            NUID(I) = LA(I)
            LIST(NUID(I)) = I
  690    CONTINUE
      ELSE
         DO 700 I = 1, KKK
            NUID(I) = I
            LIST(I) = I
  700    CONTINUE
      END IF

      RETURN

10000 FORMAT(' **   LARGEST NODE DIFFERENCE PER ELEMENT:', I6, '  **')
10010 FORMAT(' ** NODES:', I6, '; ELEMENTS:', I6, '; MATERIALS:', I3,
     &   ' **')

      END
