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

C**               SIDE BOUNDARY FLAG WOULD REDIMENSION FOREVER.
C**               THE KKSBC VARIABLE WAS CHANGED TO BE SET AT THE
C**               BEGINNING OF THE ROUTINE INSTEAD OF RIGHT BEFORE THE
C**               ZHOLE PROCESSING WAS STARTED.

      SUBROUTINE PSCHEM (MP, ML, MS, MR, N, IPOINT, COOR, IPBOUN, ILINE,
     &   LTYPE, NINT, FACTOR, LCON, ILBOUN, ISBOUN, ISIDE, NLPS, IFLINE,
     &   ILLIST, IREGN, NSPR, IFSIDE, ISLIST, NPPF, IFPB, LISTPB, NLPF,
     &   IFLB, LISTLB, NSPF, IFSB, LISTSB, LINKP, LINKL, LINKS, LINKR,
     &   LINKSC, LINKPB, LINKLB, LINKSB, IFHOLE, NHPR, IHLIST, MAXNBC,
     &   KNBC, MAXSBC, KSBC, MXND, NNN, NNNOLD, KKK, KKKOLD, LLL, X, Y,
     &   NID, LISTL, XN, YN, NUID, LXK, KXL, NXL, LXN, LSTNBC, NXH,
     &   NPERIM, MARKED, IAVAIL, NAVAIL, MXNL, MXNPER, NPER, MAXPRM,
     &   NPRM, MSC, ISCHM, SCHEME, SCHSTR, RECT, M1, INSIDE, JJHOLE,
     &   KKSBC, DEV1, EIGHT, NINE, STEP, L, NL, MCOM, CIN, IIN, RIN,
     &   KIN, ICOM, JCOM, XMIN, XMAX, YMIN, YMAX, ICODE, NOROOM, ERR,
     &   AMESUR, XNOLD, YNOLD, NXKOLD, MMPOLD, LINKEG, LISTEG, BMESUR,
     &   MLINK, NPROLD, NPNOLD, NPEOLD, NNXK, REMESH, REXMIN, REXMAX,
     &   REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX, EMIN)
C***********************************************************************

C  PSCHEM - PROCESS A COMPLETE SCHEME

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

      DIMENSION IPOINT(MP), COOR(2, MP), IPBOUN(MP)
      DIMENSION ILINE(ML), LTYPE(ML), NINT(ML), FACTOR(ML), LCON(3, ML)
      DIMENSION ILBOUN(ML), ISBOUN(ML)
      DIMENSION ISIDE(MS), NLPS(MS), IFLINE(MS), ILLIST(MS*3)
      DIMENSION IREGN(MR), NSPR(MR), IFSIDE(MR), ISLIST(MR*4)
      DIMENSION IFHOLE(MR), NHPR(MR), IHLIST(MR*2)
      DIMENSION ISCHM(MSC), SCHEME(MSC)
      DIMENSION NPPF(MP), IFPB(MP), LISTPB(2, MP)
      DIMENSION NLPF(ML), IFLB(ML), LISTLB(2, ML)
      DIMENSION NSPF(ML), IFSB(ML), LISTSB(2, ML)
      DIMENSION LINKP(2, MP), LINKL(2, ML), LINKS(2, MS)
      DIMENSION LINKR(2, MR), LINKSC(2, MR), LINKPB(2, MP)
      DIMENSION LINKLB(2, ML), LINKSB(2, ML)
      DIMENSION N(29), CIN(MCOM), IIN(MCOM), RIN(MCOM), KIN(MCOM)
      DIMENSION X(MXNPER), Y(MXNPER), NID(MXNPER*MAXPRM)
      DIMENSION LISTL(MXNL), MARKED(3, MXNL)
      DIMENSION XN(MXND), YN(MXND), NUID(MXND), LXK(4, MXND)
      DIMENSION KXL(2, 3*MXND), NXL(2, 3*MXND), LXN(4, MXND)
      DIMENSION LSTNBC(MAXNBC), NXH(MXND), NPERIM(MAXPRM)

      DIMENSION ILPC(10)

      DIMENSION AMESUR(NPEOLD), XNOLD(NPNOLD), YNOLD(NPNOLD)
      DIMENSION NXKOLD(NNXK, NPEOLD), MMPOLD(3, NPROLD)
      DIMENSION LINKEG(2, MLINK), LISTEG(2 * NPEOLD), BMESUR(NPNOLD)

      CHARACTER*72 ADDSTR, CIN, DEFSCH, SCHEME, SCHOLE, SCHSTR
      CHARACTER DEV1*3

      LOGICAL DOLINK, EIGHT, ERR, NINE, NOROOM, STEP
      LOGICAL ADDLNK, ACTIVE, IANS, DONE, DOSMOO, DOTILT, LACT(10)
      LOGICAL RECT, REMESH

      DATA IEXIT, IOVER, IQUIT /1, 2, 3/

      ALPHA = 0.7
      ASMALL = 45.0
      RO = 1.
      TOL = .03
      WF = 0.7
      ICODE = 0
      ISTYPE = 1
      J = 1
      NACALL = 0
      NEWSGN = 0
      DOTILT = .TRUE.
      DOSMOO = .TRUE.
      ERR = .FALSE.
      NOROOM = .FALSE.
      KKSBC = KSBC
      NLEFTP = 0

      NIT = 5 * NPER/2
      CALL MNORM (MXND, XN, YN, NXL, LLL, STDLEN)
      EPS = 0.03 * STDLEN

      CALL STRIPB (SCHSTR, I1, LENSCH)
  100 CONTINUE

      IISIGN = NEWSGN
      NEWSGN = 0

C  ACT ON NEXT COMMAND

C  A - ALPHA CONTROL FOR APALSM

      IF ((SCHSTR(J:J) .EQ. 'A') .OR. (SCHSTR(J:J) .EQ. 'a')) THEN
         IF (IISIGN .GE. 0) THEN
            ALPHA = MIN(ALPHA + 0.1, 1.0)
         ELSE
            ALPHA = MAX(ALPHA - 0.1, 0.0)
         END IF
         IF (ISTYPE .LE. 2) DOSMOO = .TRUE.
         WRITE(*, 10010) ALPHA

C  B - BLACKER TRANSITION REGION TEST

      ELSE IF ((SCHSTR(J:J) .EQ. 'B') .OR.
     &   (SCHSTR(J:J) .EQ. 'b')) THEN
         CONTINUE

C  C - SEMI-CIRCLE REGION TEST

      ELSE IF ((SCHSTR(J:J) .EQ. 'C') .OR.
     &   (SCHSTR(J:J) .EQ. 'c')) THEN
         CONTINUE

C  D - DELETE WORST RHOMBUS

      ELSE IF ((SCHSTR(J:J) .EQ. 'D') .OR.
     &   (SCHSTR(J:J) .EQ. 'd')) THEN
         LIMIT = 0
         IF (DOTILT) THEN
            CALL RESTA (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK,
     &         KKKOLD, NAVAIL, IAVAIL, NNN, LIMIT, IREST, TILT, ERR,
     &         NOROOM)
            IF (NOROOM) THEN
               GO TO 140
            ELSE IF (ERR) THEN
               CALL MESSAGE('ERROR DURING SHAPE SORTING OF ELEMENTS')
               GO TO 140
            END IF
            DOTILT = .FALSE.
         END IF
         ATILT = MIN(45.0, TILT*0.667)
         ATILT = (ASMALL/45.0)*ATILT
         CALL SQUASH (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK,
     &      KKKOLD, NNN, NAVAIL, IAVAIL, ATILT, DONE, NOROOM, ERR)
         IF (NOROOM) THEN
            GO TO 140
         ELSE IF (ERR) THEN
            CALL MESSAGE('ERROR DURING DELETION OF ELEMENT')
            GO TO 140
         END IF
         IF (DONE) THEN
            DOSMOO = .TRUE.
            RECT = .FALSE.
            ACTIVE = .TRUE.
            CALL MESSAGE('ELEMENT DELETED')
         ELSE
            CALL MESSAGE('NO ELEMENT(S) DELETED')
         END IF

C  E - EXIT SAVING SCHEME AND REGION

      ELSE IF ((SCHSTR(J:J) .EQ. 'E') .OR.
     &   (SCHSTR(J:J) .EQ. 'e')) THEN

C  SAVE THE SCHEME USED IF STEPPING THROUGH

         IF (STEP) THEN
            DOLINK = .TRUE.
            NOLD10 = N(10)
            NOLD24 = N(24)
            JJ = ABS(IREGN(L))
            CALL STRLNG (SCHSTR, LTRY)
            SCHSTR(LTRY:LTRY) = ' '
            CALL INSCHM (MR, MSC, N(10), N(24), JJ, SCHSTR, ISCHM,
     &         SCHEME, LINKSC, DEFSCH, NOROOM, DOLINK)
            IF (NOROOM) THEN
               N(10) = NOLD10
               N(24) = NOLD24
               WRITE(*, 10020) SCHSTR(1:LENSCH), ABS(IREGN(L))
               GO TO 140
            END IF
         END IF
         ICODE = IEXIT
         GO TO 140

C  F - CONTROL UNDER- OR OVER-RELAXATION

      ELSE IF ((SCHSTR(J:J) .EQ. 'F') .OR.
     &   (SCHSTR(J:J) .EQ. 'f')) THEN
         RODEL = .25
         IF (IISIGN .GE. 0) THEN
            RO = RO + RODEL
         ELSE
            RO = MAX(RO - RODEL, RODEL)
         END IF
         DOSMOO = .TRUE.
         WRITE(*, 10030) RO

C  H - INDICATES A HELP MESSAGERESPONSE IF STEPPING

      ELSE IF ((SCHSTR(J:J) .EQ. 'H') .OR.
     &   (SCHSTR(J:J) .EQ. 'h')) THEN
         IF (STEP) CALL HELP_FQ (3)

C  I - CHANGE MAX SMOOTHING ITERATIONS

      ELSE IF ((SCHSTR(J:J) .EQ. 'I') .OR.
     &   (SCHSTR(J:J) .EQ. 'i')) THEN
         IF (IISIGN .GE. 0) THEN
            NIT = INT(DBLE(NIT)*1.500 + 0.51)
         ELSE
            NIT = INT(DBLE(NIT)*.6667 + 0.51)
         END IF
         DOSMOO = .TRUE.
         WRITE(*, 10050) NIT

C  J - CONTROL SMOOTHING TOLERANCE

      ELSE IF ((SCHSTR(J:J) .EQ. 'J') .OR.
     &   (SCHSTR(J:J) .EQ. 'j')) THEN
         IF (IISIGN .GE. 0) THEN
            TOL = TOL*1.259921
            EPS = EPS*1.259921
         ELSE
            TOL = TOL/1.259921
            EPS = EPS/1.259921
         END IF
         DOSMOO = .TRUE.
         WRITE(*, 10060) TOL, EPS

C  L - INSERT ROW OF ELEMENTS AROUND A HOLE (TOO LATE NOW)

      ELSE IF ((SCHSTR(J:J) .EQ. 'L') .OR.
     &   (SCHSTR(J:J) .EQ. 'l')) THEN
         CONTINUE

C  M - LOGICAL MESH SIDES CHOSEN BY QMESH (TOO LATE NOW)

      ELSE IF ((SCHSTR(J:J) .EQ. 'M') .OR.
     &   (SCHSTR(J:J) .EQ. 'm')) THEN
         CONTINUE

C  N - NECKLACE

      ELSE IF ((SCHSTR(J:J) .EQ. 'N') .OR.
     &   (SCHSTR(J:J) .EQ. 'n')) THEN
         CALL NCKLCE (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK, NNN,
     &      NNNOLD, LLL, NAVAIL, IAVAIL, EPS, NOROOM, ERR)
         IF (NOROOM) THEN
            GO TO 140
         ELSE IF (ERR) THEN
            CALL MESSAGE('ERROR DURING NECKLACING OF REGION')
            GO TO 140
         END IF
         ACTIVE = .TRUE.
         RECT = .FALSE.
         DOSMOO = .TRUE.
         CALL MESSAGE('NECKLACE INSTALLED')

C  O - ORIGINATE THE MESH AGAIN.

      ELSE IF ((SCHSTR(J:J) .EQ. 'O') .OR.
     &   (SCHSTR(J:J) .EQ. 'o')) THEN
         CALL MESSAGE('PROCESSING RETURNED TO ORIGINAL')
         SCHSTR = ' '
         ICODE = IOVER
         GO TO 140

C  P - PLOT

      ELSE IF ((SCHSTR(J:J) .EQ. 'P') .OR.
     &   (SCHSTR(J:J) .EQ. 'p')) THEN
         IF (STEP) THEN
            CALL PLOTL (MXND, XN, YN, NXL, ABS(IREGN(L)), XMIN, XMAX,
     &         YMIN, YMAX, LLL, DEV1)
         ELSE
            CALL MESSAGE('PLOTTING AVAILABLE ONLY IN INTERACTIVE '//
     &         'STEP PROCESSING')
         END IF

C  Q - QUIT STEP PROCESSING WITHOUT SAVING MESH

      ELSE IF ((SCHSTR(J:J) .EQ. 'Q') .OR.
     &   (SCHSTR(J:J) .EQ. 'q')) THEN
         CALL MESSAGE ('REGION PROCESSING ABORTED WITH "QUIT"')
         ICODE = IQUIT
         GO TO 140

C  R - RESTRUCTURE

      ELSE IF ((SCHSTR(J:J) .EQ. 'R') .OR.
     &   (SCHSTR(J:J) .EQ. 'r')) THEN
         LIMIT = MXND
         CALL RESTA (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK,
     &      KKKOLD, NAVAIL, IAVAIL, NNN, LIMIT, IREST, TILT, ERR,
     &      NOROOM)
         IF (NOROOM) THEN
            GO TO 140
         ELSE IF (ERR) THEN
            CALL MESSAGE('ERROR DURING RESTRUCTURE OF REGION')
            GO TO 140
         END IF
         DOTILT = .FALSE.
         IF (IREST .GE. 1) THEN
            DOSMOO = .TRUE.
            RECT = .FALSE.
            ACTIVE = .TRUE.
            CALL MESSAGE('RESTRUCTURE COMPLETED')
         END IF

C  S - SMOOTH

      ELSE IF ((SCHSTR(J:J) .EQ. 'S') .OR.
     &   (SCHSTR(J:J) .EQ. 's')) THEN
         IF (DOSMOO) THEN
            IF (ISTYPE .EQ. 1) THEN
               IF (RECT) THEN
                  CALL REPSMO (MXND, XN, YN, LXN, NNN, NNNOLD, NIT, EPS,
     &               RO, M1)
                  CALL MESSAGE('EQUIPOTENTIAL SMOOTHING COMPLETED')
               ELSE
                  IF ((NACALL/5)*5 .EQ. NACALL) THEN
                     CALL ARELAX (MXND, XN, YN, LXK, KXL, NXL, LLL,
     &                  ARFACT)
                  END IF
                  CALL APALSM (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN,
     &               NNNOLD, NIT, TOL, RO*ARFACT, ALPHA, ERR)
                  IF (ERR) THEN
                     CALL MESSAGE('ERROR DURING AREA PULL & '//
     &                  'LAPLACIAN SMOOTHING')
                     GO TO 140
                  END IF
                  CALL MESSAGE('AREA PULL AND LAPLACIAN SMOOTHING '//
     &               'COMPLETED')
                  NACALL = NACALL + 1
               END IF
            ELSE IF (ISTYPE .EQ. 2) THEN
               IF ((NACALL/5)*5 .EQ. NACALL) THEN
                  CALL ARELAX (MXND, XN, YN, LXK, KXL, NXL, LLL, ARFACT)
               END IF
               CALL APALSM (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN,
     &            NNNOLD, NIT, TOL, RO*ARFACT, ALPHA, ERR)
               IF (ERR) THEN
                  CALL MESSAGE
     &               ('ERROR DURING AREA PULL & LAPLACIAN SMOOTHING')
                  GO TO 140
               END IF
               CALL MESSAGE
     &            ('AREA PULL AND LAPLACIAN SMOOTHING COMPLETED')
               NACALL = NACALL + 1
            ELSE IF (ISTYPE .EQ. 3) THEN
               CALL CIAPAL (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN,
     &            NNNOLD, NIT, EPS, RO, 0.5)
               CALL MESSAGE('CENTROID INVERSE PUSH AND LAPLACIAN '//
     &            'SMOOTHING COMPLETED')
            ELSE IF (ISTYPE .EQ. 4) THEN
               CALL CASMO (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN,
     &            NNNOLD, NIT, EPS, RO)
               CALL MESSAGE
     &            ('CENTROID AREA PULL SMOOTHING COMPLETED')
            ELSE IF (ISTYPE .EQ. 5) THEN
               IF (RECT) THEN
                  CALL REPSMO (MXND, XN, YN, LXN, NNN, NNNOLD, NIT, EPS,
     &               RO, M1)
                  CALL MESSAGE('EQUIPOTENTIAL SMOOTHING COMPLETED')
               ELSE
                  CALL SMOGS (MXND, XN, YN, NXL, LXN, NNN, NNNOLD, NIT,
     &               EPS, RO)
                  CALL MESSAGE('LAPLACIAN SMOOTHING COMPLETED')
               END IF
            ELSE IF (ISTYPE .EQ. 6) THEN
               CALL L2SMO (MXND, XN, YN, NXL, LXN, NNN, NNNOLD, NIT,
     &            EPS, RO)
               CALL MESSAGE('LENGTH WEIGHTED LAPLACIAN SMOOTHING '//
     &            'COMPLETED')
            ELSE IF (ISTYPE .EQ. 7) THEN
               CALL ISOLAP (MXND, XN, YN, LXK, KXL, NXL, LXN, NNN,
     &            NNNOLD, WF, NIT, EPS, RO)
               CALL MESSAGE
     &            ('LAPLACIAN-ISOPARAMETRIC SMOOTHING COMPLETED')
            END IF
            DOSMOO = .FALSE.
            ACTIVE = .TRUE.
         ELSE
            CALL MESSAGE('MESH AND/OR SMOOTHING PARAMETERS HAVE')
            CALL MESSAGE('NOT CHANGED - NO SMOOTHING ATTEMPTED')
         END IF

C  T - TRIANGULAR REGION - QUAD MESH GENERATION

      ELSE IF ((SCHSTR(J:J) .EQ. 'T') .OR.
     &   (SCHSTR(J:J) .EQ. 't')) THEN
         CONTINUE

C  U - PENTAGON REGION - QUAD MESH GENERATION

      ELSE IF ((SCHSTR(J:J) .EQ. 'U') .OR.
     &   (SCHSTR(J:J) .EQ. 'u')) THEN
         CONTINUE

C  V - CHANGE ASMALL FOR SQUASH (D)

      ELSE IF ((SCHSTR(J:J) .EQ. 'V') .OR.
     &   (SCHSTR(J:J) .EQ. 'v')) THEN
         IF (IISIGN .GE. 0) THEN
            ASMALL = MIN(ASMALL + 2.5, 80.0)
         ELSE
            ASMALL = MAX(ASMALL - 2.5, 10.0)
         END IF
         WRITE(*, 10070) ASMALL

C  W - RESTRUCTURE WORST POSSIBLE ELEMENT ONLY

      ELSE IF ((SCHSTR(J:J) .EQ. 'W') .OR.
     &   (SCHSTR(J:J) .EQ. 'w')) THEN
         LIMIT = 1
         CALL RESTA (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK,
     &      KKKOLD, NAVAIL, IAVAIL, NNN, LIMIT, IREST, TILT, ERR,
     &      NOROOM)
         IF (NOROOM) THEN
            GO TO 140
         ELSE IF (ERR) THEN
            CALL MESSAGE('ERROR DURING WORST ELEMENT RESTRUCTURE')
            GO TO 140
         END IF
         DOTILT = .FALSE.
         IF (IREST .GE. 1) THEN
            DOSMOO = .TRUE.
            RECT = .FALSE.
            ACTIVE = .TRUE.
            CALL MESSAGE('WORST ELEMENT RESTRUCTURED')
         END IF

C  X - PAVING REGION - QUAD MESH GENERATION

      ELSE IF ((SCHSTR(J:J) .EQ. 'X') .OR.
     &   (SCHSTR(J:J) .EQ. 'x')) THEN
         CONTINUE

C  Y - CONTROL UNDER- OR OVER-RELAXATION

      ELSE IF ((SCHSTR(J:J) .EQ. 'Y') .OR.
     &   (SCHSTR(J:J) .EQ. 'y')) THEN
         WFDEL = .1
         IF (IISIGN .GE. 0) THEN
            WF = WF + WFDEL
         ELSE
            WF = MAX(WF - WFDEL, WFDEL)
         END IF
         DOSMOO = .TRUE.
         WRITE(*, 10040) WF

C  Z - PROCESS REGION WITH HOLES

      ELSE IF ((SCHSTR(J:J) .EQ. 'Z') .OR.
     &   (SCHSTR(J:J) .EQ. 'z')) THEN
         IF (NHPR(L) .EQ. 0) THEN
            CALL MESSAGE('NO HOLES DEFINED IN THIS REGION')
            GO TO 130
         ELSE IF (JJHOLE .EQ. 0) THEN
            JJHOLE = IFHOLE(L)
            MXHOLE = JJHOLE + NHPR(L) - 1
         ELSE
            JJHOLE = JJHOLE + 1
         END IF
         IF (JJHOLE .GT. MXHOLE) THEN
            CALL MESSAGE('ALL HOLES PROCESSED FOR REGION')
            GO TO 130
         END IF
         ADDLNK = .FALSE.
         CALL LTSORT (MR, LINKR, IHLIST(JJHOLE), JHOLE, ADDLNK)

C  JHOLE IS NEGATIVE FOR REGIONS ON BODY CARD WITH LESS THAN THREE INTERVALS

         JHOLE = ABS(JHOLE)
         CALL LTSORT (MR, LINKSC, ABS(IREGN(JHOLE)), IPNTR,
     &      ADDLNK)
         IF ((ABS(IREGN(JHOLE)) .LE. N(24)) .AND.
     &      (IPNTR .GT. 0)) THEN
            SCHOLE = SCHEME(IPNTR)
         ELSE
            SCHOLE = ' '
         END IF
         IF (STEP) THEN
            CALL STRCUT (SCHOLE)
            CALL STRLNG (SCHOLE, LENHOL)
            WRITE(*, 10000) SCHOLE(1:LENHOL)
            CALL INTRUP ('USE CURRENT HOLE SCHEME', IANS, MCOM, ICOM,
     &         JCOM, CIN, IIN, RIN, KIN)
            IF (.NOT.IANS) THEN
  110          CONTINUE
               IF (ICOM .LE. JCOM) THEN
                  SCHOLE = CIN(ICOM)
                  ICOM = ICOM + 1
                  IANS = .TRUE.
               ELSE
                  CALL INQSTR ('ENTER HOLE PROCESSING SCHEME: ', SCHOLE)
               END IF
               IF ((SCHOLE(1:1) .EQ. 'H') .OR.
     &            (SCHOLE(1:1) .EQ. 'h')) THEN
                  CALL MESSAGE(' ')
                  CALL HELP_FQ (13)
                  CALL MESSAGE(' ')
                  GO TO 110
               END IF
            END IF
         END IF

         CALL STRCUT (SCHOLE)
         CALL STRLNG (SCHOLE, LENHOL)
         INSIDE = 0
         DO 120 M = 1, LENHOL
            IF ((SCHOLE(M:M) .EQ. 'L') .OR.
     &         (SCHOLE(M:M) .EQ. 'l')) INSIDE = INSIDE + 1
  120    CONTINUE

         NPRM = NPRM + 1

         CALL ZHOLE (MP, ML, MS, MR, NSPR(JHOLE), MXNL, MXNPER, MAXPRM,
     &      NPRM, MAXNBC, MAXSBC, KNBC, KSBC, IREGN(JHOLE), IPOINT,
     &      COOR, IPBOUN, ILINE, LTYPE, NINT, FACTOR, LCON, ILBOUN,
     &      ISBOUN, ISIDE, NLPS, IFLINE, ILLIST, ISLIST,
     &      IFSIDE(JHOLE), NPPF, IFPB, LISTPB, NLPF, IFLB, LISTLB, NSPF,
     &      IFSB, LISTSB, LINKP, LINKL, LINKS, LINKPB, LINKLB, LINKSB,
     &      X, Y, NID, LISTL, MARKED, NL, LSTNBC, MXND, XN, YN, NUID,
     &      LXK, KXL, NXL, LXN, NXH, NPERIM, NNN, NNNOLD, KKK, LLL,
     &      IAVAIL, NAVAIL, JHOLE, INSIDE, EPS, NOROOM, ERR, AMESUR,
     &      XNOLD, YNOLD, NXKOLD, MMPOLD, LINKEG, LISTEG, BMESUR,
     &      MLINK, NPROLD, NPNOLD, NPEOLD, NNXK, REMESH, REXMIN, REXMAX,
     &      REYMIN, REYMAX, IDIVIS, SIZMIN, EMAX, EMIN)
         IF (NOROOM) THEN
            GO TO 140
         ELSE IF (ERR) THEN
            CALL MESSAGE('HOLE PROCESSING FAILED')
            GO TO 140
         ELSE
            DOSMOO = .TRUE.
            RECT = .FALSE.
            ACTIVE = .TRUE.
            IF (INSIDE .GT. 0) THEN
               NIT3 = 3
               RONE = 1.0
               CALL SMOGS (MXND, XN, YN, NXL, LXN, NNN, NNNOLD, NIT3,
     &            EPS, RONE)
            END IF
            IF (IPNTR .LE. 0) THEN
               ADDLNK = .TRUE.
               CALL LTSORT (MR, LINKSC, ABS(IREGN(JHOLE)), IPNTR,
     &            ADDLNK)
               ADDLNK = .FALSE.
            END IF
            if (ipntr .gt. 0) SCHEME(IPNTR) = SCHOLE
            CALL MESSAGE('HOLE PROCESSING COMPLETED')
         END IF
  130    CONTINUE

C  ( - START LOOP

      ELSE IF (SCHSTR(J:J) .EQ. '(') THEN
         IF (NLEFTP .GE. 10) THEN
            CALL MESSAGE('TOO MANY NESTED LOOPS IN THE SCHEME')
            GO TO 140
         END IF
         NLEFTP = NLEFTP + 1
         LACT(NLEFTP) = ACTIVE
         ILPC(NLEFTP) = J
         ACTIVE = .FALSE.

C  ) - END OF LOOP - CHECK FOR ACTIVITY

      ELSE IF (SCHSTR(J:J) .EQ. ')') THEN
         IF (NLEFTP .LE. 0) THEN
            CALL MESSAGE('THERE IS NO LEFT PARENTHESIS TO')
            CALL MESSAGE('MATCH THE RIGHT PARENTHESIS')
            CALL MESSAGE('")" IS THUS IGNORED')
         ELSE

C  LOOP BACK

            IF (ACTIVE) THEN
               ACTIVE = .FALSE.
               J = ILPC(NLEFTP)
               LACT(NLEFTP) = .TRUE.

C  LOOP IS COMPLETED

            ELSE
               ACTIVE = LACT(NLEFTP)
               NLEFTP = NLEFTP - 1
            END IF
         END IF

C  + SIGN

      ELSE IF (SCHSTR(J:J) .EQ. '+') THEN
         NEWSGN = +1

C  - SIGN

      ELSE IF (SCHSTR(J:J) .EQ. '-') THEN
         NEWSGN = -1

C  1, 2, ..., 6  SMOOTHING TYPE DECLARATION

      ELSE IF (SCHSTR(J:J) .EQ. '1') THEN
         IF (ISTYPE .NE. 1) THEN
            ISTYPE = 1
            DOSMOO = .TRUE.
         END IF
         CALL MESSAGE('SMOOTHING TYPE SET TO "EQUIPOTENTIAL"')
      ELSE IF (SCHSTR(J:J) .EQ. '2') THEN
         IF (ISTYPE .NE. 2) THEN
            ISTYPE = 2
            DOSMOO = .TRUE.
         END IF
         CALL MESSAGE('SMOOTHING TYPE SET TO "AREA PULL & LAPLACIAN"')
      ELSE IF (SCHSTR(J:J) .EQ. '3') THEN
         IF (ISTYPE .NE. 3) THEN
            ISTYPE = 3
            DOSMOO = .TRUE.
         END IF
         CALL MESSAGE('SMOOTHING TYPE SET TO "CENTROID INVERSE AREA '//
     &      'PUSH & LAPLACIAN"')
      ELSE IF (SCHSTR(J:J) .EQ. '4') THEN
         IF (ISTYPE .NE. 4) THEN
            ISTYPE = 4
            DOSMOO = .TRUE.
         END IF
         CALL MESSAGE('SMOOTHING TYPE SET TO "CENTROID AREA PULL"')
      ELSE IF (SCHSTR(J:J) .EQ. '5') THEN
         IF (ISTYPE .NE. 5) THEN
            ISTYPE = 5
            DOSMOO = .TRUE.
         END IF
         CALL MESSAGE('SMOOTHING TYPE SET TO "LAPLACIAN"')
      ELSE IF (SCHSTR(J:J) .EQ. '6') THEN
         IF (ISTYPE .NE. 6) THEN
            ISTYPE = 6
            DOSMOO = .TRUE.
         END IF
         CALL MESSAGE('SMOOTHING TYPE SET TO "LENGTH WEIGHTED '//
     &      'LAPLACIAN"')
      ELSE IF (SCHSTR(J:J) .EQ. '7') THEN
         IF (ISTYPE .NE. 7) THEN
            ISTYPE = 7
            DOSMOO = .TRUE.
         END IF
         CALL MESSAGE('SMOOTHING TYPE SET TO "LAPLACIAN-ISOPARAMETRIC"')

C  BLANK SCHEME FLAG

      ELSE IF (SCHSTR(J:J) .EQ. ' ') THEN
         IF (J .NE. 1) CALL MESSAGE('BLANK SCHEME COMMAND IGNORED')

C  ILLEGAL SCHEME FLAG

      ELSE
         WRITE(*, 10080) SCHSTR(J:J)
      END IF

C  GET NEXT SCHEME COMMAND

      J = J + 1
      IF (J .LE. LENSCH) THEN
         GO TO 100
      ELSE IF (STEP) THEN
         CALL MESSAGE('------------------------')
         IF (ICOM .LE. JCOM) THEN
            ADDSTR = CIN(ICOM)
            ICOM = ICOM + 1
         ELSE
            CALL INQSTR ('FURTHER PROCESSING STEPS: ', ADDSTR)
         END IF
         CALL STRCUT (ADDSTR)
         CALL STRLNG (ADDSTR, LENA)
         IF ((LENSCH .EQ. 1) .AND. (SCHSTR(J - 1:J - 1) .EQ. ' '))
     &      LENSCH = LENSCH - 1
         IF (LENSCH + LENA .GT. 72) THEN
            CALL MESSAGE('ERROR - SCHEME TOO LONG')
            GO TO 140
         END IF
         SCHSTR(LENSCH + 1:LENSCH + LENA) = ADDSTR(1:LENA)
         CALL STRCUT (SCHSTR)
         J = LENSCH + 1
         CALL STRLNG (SCHSTR, LENSCH)
         GO TO 100
      END IF
      ICODE = IEXIT

C  END OF THIS REGION

  140 CONTINUE
      RETURN
10000 FORMAT (' ', /, ' INITIAL MESH DEFINED USING THIS HOLE SCHEME:' /,
     &   '    ', A)
10010 FORMAT (' ALPHA SMOOTHING PARAMETER FOR EQUAL AREAS SET TO:',
     &   F6.3)
10020 FORMAT (' SCHEME: ', A, /,
     &   ' FOR REGION:', I5, /,
     &   ' CANNOT BE SAVED HERE DUE TO DIMENSIONING CONSTRAINTS')
10030 FORMAT (' RO SMOOTHING PARAMETER FOR RELAXATION SET TO:', F6.3)
10040 FORMAT (' WF SMOOTHING PARAMETER FOR ISOPARAMETIC SET TO:', F6.3)
10050 FORMAT (' NO OF SMOOTHING ITERATIONS SET TO:', I5)
10060 FORMAT (' SMOOTHING TOLERANCE SET TO:', G14.7, /,
     &   ' SMOOTHING EPSILON SET TO:', G14.7)
10070 FORMAT (' SMALLEST ANGLE OF ELEMENT TO BE DELETED SET TO:', F6.3)
10080 FORMAT (' ILLEGAL SCHEME COMMAND: ', A1)
      END
