C    Copyright(C) 1999-2021 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 MESH (A, IA, MP, ML, MS, MR, MSC, MA, MCOM, ICOM, JCOM,
     &   CIN, RIN, IIN, KIN, IDUMP, N, IPOINT, COOR, IPBOUN, ILINE,
     &   LTYPE, NINT, FACTOR, LCON, ILBOUN, ISBOUN, ISIDE, NLPS, IFLINE,
     &   ILLIST, IBARST, JMAT, JCENT, NLPB, JFLINE, JLLIST, IREGN, IMAT,
     &   NSPR, IFSIDE, ISLIST, IRPB, IPBF, NPPF, IFPB, LISTPB, ILBF,
     &   NLPF, IFLB, LISTLB, ISBF, NSPF, IFSB, LISTSB, LINKP, LINKL,
     &   LINKS, LINKB, LINKR, LINKM, LINKSC, LINKPB, LINKLB, LINKSB,
     &   IWTPBF, IWTLBF, IWTSBF, RSIZE, IFHOLE, NHPR, IHLIST, IRGFLG,
     &   ISCHM, SCHEME, NUMBER, DEFSCH, DEFSIZ, TITLE, OPTIM, IDEV,
     &   ALPHA, DEV1, THREE, EIGHT, NINE, BATCH, VAXVMS, VERSN, AXIS,
     &   AREACG, LABN, LABE, LABO, LABNB, LABSB, LABM, LABW, WROTE,
     &   TIME1, HARDPL, EXODUSII)
C***********************************************************************

C  SUBROUTINE MESH = PROCESSES THE MESH AND THEN GRAPHICALLY DISPLAYS
C                    THE MESH

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

C  SUBROUTINE CALLED BY:
C     FASTQ  = A PROGRAM TO QUICKLY PREPARE QMESH INPUT

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

C  SUBROUTINES CALLED:
C     QMESH  = GENERATES THE MESH
C     RENUM  = ASSIGNS NODAL AND ELEMENT NUMBERS TO THE MESH

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

C  VARIABLES USED:
C     IANS   = LOGICAL RESPONSE FROM YES-NO QUESTION
C     TITLE  = MESH TITLE
C     TALL   = CHARACTER HEIGHT SETTING PARAMETER
C     STEP   = .TRUE. IF GENERATION TO BE STEPPED THROUGH INTERACTIVELY
C     DONE   = .TRUE. IF MESH HAS BEEN PROCESSED

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

      PARAMETER (MAXNAM = 40, MLINK = 55)

      include 'exodusII.inc'

C  DIMENSIONS FOR MESH DEFINING ENTITIES  (I.E. POINTS,  LINES,  ETC.)

      DIMENSION A(1), IA(1)
      DIMENSION IPOINT(MP), COOR(2, MP), IPBOUN(MP)
      DIMENSION ILINE(ML), LTYPE(ML), NINT(ML), FACTOR(ML)
      DIMENSION LCON(3, ML)
      DIMENSION ILBOUN(ML), ISBOUN(ML)
      DIMENSION ISIDE(MS), NLPS(MS), IFLINE(MS), ILLIST(MS*3)
      DIMENSION IREGN(MR), IMAT(MR)
      DIMENSION NSPR(MR), IFSIDE(MR), ISLIST(MR*4), IRGFLG(MR)
      DIMENSION RSIZE(MR), IFHOLE(MR), NHPR(MR), IHLIST(MR*2)
      DIMENSION IBARST(MS), JMAT(MS), JCENT(MS)
      DIMENSION NLPB(MS), JFLINE(MS), JLLIST(MS*3)
      DIMENSION IRPB(MR), ISCHM(MSC), SCHEME(MSC)
      DIMENSION IPBF(MP), NPPF(MP), IFPB(MP)
      DIMENSION LISTPB(2, MP), IWTPBF(3, MP)
      DIMENSION ILBF(ML), NLPF(ML), IFLB(ML)
      DIMENSION LISTLB(2, ML), IWTLBF(3, ML)
      DIMENSION ISBF(ML), NSPF(ML), IFSB(ML)
      DIMENSION LISTSB(2, ML), IWTSBF(3, ML)
      DIMENSION LINKP(2, MP), LINKL(2, ML), LINKS(2, MS)
      DIMENSION LINKB(2, MS)
      DIMENSION LINKR(2, MR), LINKM(2, (MS + MR)), LINKSC(2, MR)
      DIMENSION LINKPB(2, MP), LINKLB(2, ML), LINKSB(2, ML)
      DIMENSION NUMBER(MSC)
      DIMENSION N(29), K(41), IDEV(2), III(1)
      DIMENSION KIN(MCOM), IIN(MCOM), RIN(MCOM)

      CHARACTER*72 SCHEME, DEFSCH, TITLE, DEV1*3, CIN(MCOM)
      CHARACTER*2048 FNAME
      CHARACTER*80 NUMBER, HOLD, VERSN*10

      LOGICAL OPTIM, STEP, ERR, ALPHA, THREE, EIGHT, NINE
      LOGICAL AXIS, AREACG, LABE, LABO, LABN, LABNB, LABSB, LABM, LABW
      LOGICAL ADDLNK, BATCH, VAXVMS, WROTE, HARDPL, LGROUP
      LOGICAL REMESH, LONG
      LOGICAL EXODUSII, ISBARS

      CHARACTER*8 CDUMH, CDUMS
      INTEGER CMPSIZ

      NPREGN = 0
      IZ = 0
      ADDLNK = .FALSE.
      REMESH = .FALSE.

C  ENTER THE MESH OPTION

  100 CONTINUE
      IF (ICOM.GT.JCOM) THEN
         CALL MESSAGE(' ')
         CALL FREFLD (IZ, IZ, 'ENTER MESH OPTION: ', MCOM, IOSTAT, JCOM,
     &      KIN, CIN, IIN, RIN)
         ICOM = 1
      END IF

C  RETURN FROM MESHING AFTER DELETING THE MESH

      IF (CIN(ICOM)(1:1) .EQ. ' ') THEN
         ICOM = ICOM + 1
         IF (NPREGN.GT.0) THEN
            CALL MDDEL ('IPART')
            CALL MDDEL ('LSTNBC')
            CALL MDDEL ('LSTSBC')
            CALL MDDEL ('NNFLG')
            CALL MDDEL ('NNPTR')
            CALL MDDEL ('NNLEN')
            CALL MDDEL ('NSFLG')
            CALL MDDEL ('NSPTR')
            CALL MDDEL ('NSLEN')
            CALL MDDEL ('NVPTR')
            CALL MDDEL ('NVLEN')
            CALL MDDEL ('NSIDEN')
            CALL MDDEL ('NUID')
            CALL MDDEL ('XN')
            CALL MDDEL ('YN')
            CALL MDDEL ('NXK')
            CALL MDDEL ('MAT')
            CALL MDDEL ('KXN')
            CALL MDDEL ('LIST')
            CALL MDDEL ('LA')
            CALL MDDEL ('LB')
            CALL MDDEL ('CENTK')
            CALL MDDEL ('MATMAP')
            CALL MDDEL ('LISTN')
            CALL MDDEL ('WTNODE')
            CALL MDDEL ('WTSIDE')
            CALL MDDEL ('WTHOLD')
            CALL MDDEL ('IHERE')
            CALL MDDEL ('ILIST')
            CALL MDDEL ('XLIST')
            CALL MDDEL ('AMESUR')
            CALL MDDEL ('XNOLD')
            CALL MDDEL ('YNOLD')
            CALL MDDEL ('NXKOLD')
            CALL MDDEL ('MMPOLD')
            CALL MDDEL ('LINKEG')
            CALL MDDEL ('LISTEG')
            CALL MDDEL ('BMESUR')
            CALL MDDEL ('CMESUR')
            CALL MDDEL ('DMESUR')
            CALL MDSTAT (NERR, MUSED)
            IF (NERR.GT.0) THEN
               CALL MDEROR (6)
               STOP ' '
            END IF
            KKK = 0
         END IF
         RETURN

C  SPECIFY ExodusI (X1) or ExodusII (X2) database format
      ELSE IF ((CIN(ICOM)(1:1) .EQ. 'X') .OR.
     &        (CIN(ICOM)(1:1) .EQ. 'x')) THEN
         if (cin(icom)(2:2) .eq. '2') then
            exodusII = .TRUE.
            call message ('Writing EXODUSII Format')
         else if (cin(icom)(2:2) .eq. '1') then
            exodusII = .FALSE.
            call message ('Writing EXODUSI/GENESIS Format')
         end if
         ICOM = ICOM + 1

C  ENTER THE MESH GRAPHICS OPTION

      ELSE IF ((CIN(ICOM)(1:1) .EQ. 'G') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 'g')) THEN
         ICOM = ICOM + 1
         IF (KKK.LE.0) THEN
            CALL MESSAGE(' ')
            CALL MESSAGE('****************************************')
            CALL MESSAGE('*    NO MESH HAS BEEN PROCESSED        *')
            CALL MESSAGE('*        NO PLOTTING POSSIBLE          *')
            CALL MESSAGE('****************************************')
            CALL MESSAGE(' ')
         ELSE
            CALL GMESH (NPNODE, NPELEM, MXNFLG, MXSFLG, NPNBC, NPSBC,
     &         MAXKXN, MR, NPREGN, MCOM, ICOM, JCOM, CIN, RIN, IIN, KIN,
     &         NNN, KKK, NUMMAT, NNXK, IA(K(1)), IA(K(2)), IA(K(4)),
     &         IA(K(5)), IA(K(7)), IA(K(10)), IA(K(11)), IA(K(12)),
     &         IA(K(13)), A(K(14)), A(K(15)), IA(K(16)),
     &         IA(K(17)), IA(K(18)), IA(K(19)), A(K(22)),
     &         IA(K(23)), A(K(25)), A(K(26)), NBCNOD, NNLIST,
     &         NBCSID, NVLIST, TITLE, IDUMP, AXIS, AREACG, LABE, LABO,
     &         LABN, LABNB, LABSB, LABM, LABW, IDEV, ALPHA, DEV1, EIGHT,
     &         NINE, VAXVMS, VERSN, WROTE, TIME1, HARDPL, BATCH)
         END IF

C  TOGGLE OPTIMIZATION

      ELSE IF ((CIN(ICOM)(1:1) .EQ. 'O') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 'o')) THEN
         ICOM = ICOM + 1
         IF (OPTIM) THEN
            OPTIM = .FALSE.
            CALL MESSAGE(' ')
            CALL MESSAGE('BANDWIDTH OPTIMIZATION - DISABLED')
         ELSE
            OPTIM = .TRUE.
            CALL MESSAGE(' ')
            CALL MESSAGE('BANDWIDTH OPTIMIZATION - ENABLED')
         END IF

C  TOGGLE THREE NODE BAR ELEMENTS

      ELSE IF ((CIN(ICOM)(1:1) .EQ. 'T') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 't')) THEN
         ICOM = ICOM + 1
         IF (THREE) THEN
            THREE = .FALSE.
            CALL MESSAGE(' ')
            CALL MESSAGE('THREE NODE BAR GENERATION - DISABLED')
         ELSE
            THREE = .TRUE.
            CALL MESSAGE(' ')
            CALL MESSAGE('THREE NODE BAR GENERATION - ENABLED')
         END IF
         KKK = 0

C  TOGGLE EIGHT NODE ELEMENTS

      ELSE IF ((CIN(ICOM)(1:2) .EQ. 'EI') .OR.
     &   (CIN(ICOM)(1:2) .EQ. 'ei')) THEN
         ICOM = ICOM + 1
         IF (EIGHT) THEN
            EIGHT = .FALSE.
            CALL MESSAGE(' ')
            CALL MESSAGE('EIGHT NODE QUAD GENERATION - DISABLED')
         ELSE
            EIGHT = .TRUE.
            NINE = .FALSE.
            CALL MESSAGE(' ')
            CALL MESSAGE('EIGHT NODE QUAD GENERATION - ENABLED')
         END IF
         KKK = 0

C  TOGGLE NINE NODE ELEMENT GENERATION

      ELSE IF ((CIN(ICOM)(1:2) .EQ. 'NI') .OR.
     &   (CIN(ICOM)(1:2) .EQ. 'ni')) THEN
         ICOM = ICOM + 1
         IF (NINE) THEN
            NINE = .FALSE.
            CALL MESSAGE(' ')
            CALL MESSAGE('NINE NODE QUAD GENERATION - DISABLED')
         ELSE
            NINE = .TRUE.
            EIGHT = .FALSE.
            CALL MESSAGE(' ')
            CALL MESSAGE('NINE NODE QUAD GENERATION - ENABLED')
         END IF
         KKK = 0

C  EXIT OPTION - EXITS FASTQ

      ELSE IF ((CIN(ICOM)(1:2) .EQ. 'EX') .OR.
     &   (CIN(ICOM)(1:2) .EQ. 'ex')) THEN
         CALL STRLNG (CIN(ICOM), LEN)
         IF (LEN .GT. 1) THEN
            IF ( (CIN(ICOM)(2:2) .EQ. 'X') .OR.
     &         (CIN(ICOM)(2:2) .EQ. 'x')) THEN
               ICOM = ICOM + 1
               CALL FEXIT (WROTE, MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN,
     &            TIME1, BATCH, VERSN)
            ELSE
               ICOM = ICOM + 1
               CALL HELP_FQ(12)
            ENDIF
         ELSE
            ICOM = ICOM + 1
            CALL FEXIT (WROTE, MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN,
     &         TIME1, BATCH, VERSN)
         ENDIF
         GOTO 100

C  ENTER LINE INTERVALS

      ELSE IF ((CIN(ICOM)(1:1) .EQ. 'I') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 'i')) THEN
         ICOM = ICOM + 1
         IF (ICOM.GT.JCOM) THEN
            CALL MESSAGE('ENTER LINE INTERVALS IN THE FOLLOWING '//
     &         'FORMAT:')
            CALL MESSAGE('[ LINE NO. (OR NEG SIDE NO.),  INTERVALS ]')
            CALL MESSAGE('HIT RETURN TO END INPUT')
         END IF
  110    CONTINUE
         IF (ICOM.GT.JCOM) THEN
            CALL FREFLD (IZ, IZ, '>', MCOM, IOSTAT, JCOM, KIN, CIN, IIN,
     &         RIN)
            ICOM = 1
         END IF
         CALL GETI12 (MCOM, ICOM, JCOM, CIN, IIN, KIN, I1, I2, IFOUND)
         IF (IFOUND.GT.0) THEN
            III(1) = I1
            CALL ININTR (ML, MS, 1, I2, III(1), N(19), N(20), NINT,
     &         NLPS, IFLINE, ILLIST, LINKL, LINKS, ADDLNK)
            GOTO 110
         END IF

C  SPAWN A PROCESS

      ELSE IF ((CIN(ICOM)(1:2) .EQ. 'SP') .OR.
     &   (CIN(ICOM)(1:2) .EQ. 'sp')) THEN
         ICOM = ICOM + 1
         CALL SPAWN (VAXVMS)

C  ENTER A NEW SIZE FOR A REGION

      ELSE IF ((CIN(ICOM)(1:2)  .EQ.  'SI') .OR.
     &   (CIN(ICOM)(1:2)  .EQ.  'si')) THEN
         ICOM = ICOM + 1
         CALL MESSAGE('NOTE: ENTER A DEFAULT SIZE BY SPECIFYING')
         CALL MESSAGE('      A SIZE WITH NO REGIONS.')
         CALL MESSAGE('ENTER REGION SIZE DATA IN THE FOLLOWING FORMAT:')
         CALL MESSAGE('[ SIZE, REGION 1, REGION 2, ..., REGION N ]')
         CALL MESSAGE('HIT RETURN TO END INPUT')
         ICOM = JCOM + 1
  120    CONTINUE
         CALL FREFLD (IZ, IZ, '>', MCOM, IOSTAT, IFOUND, KIN, CIN, IIN,
     &      RIN)
         IF (IFOUND .GT. 0) THEN
            IF (IFOUND .LT. 2) THEN
               DEFSIZ = RIN(1)
            ELSE
               ADDLNK = .FALSE.
               DO 130 IRSZ = 2, IFOUND
                  CALL LTSORT(MR, LINKR, IIN(IRSZ), JJ, ADDLNK)
                  IF (JJ .GE. 0) THEN
                     RSIZE(JJ) = AMAX1(RIN(1), 0.)
                  ELSE
                     WRITE(*, 10000)IIN(IRSZ)
                  END IF
  130          CONTINUE
            END IF
            GO TO 120
         END IF

C  GENERATE THE MESH

      ELSE IF ((CIN(ICOM)(1:1) .EQ. 'P') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 'p') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 'S') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 's')) THEN
         DO 140 I = 1, 2
            IF (N(I).LE.0) THEN
               CALL MESSAGE('***************************************')
               IF (I .EQ. 1) THEN
                  CALL MESSAGE
     &               ('*    NO POINT CARDS IN DATABASE       *')
               ELSE
                  CALL MESSAGE
     &               ('*     NO LINE CARDS IN DATABASE       *')
               END IF
               CALL MESSAGE('*     NO MESH GENERATION POSSIBLE     *')
               CALL MESSAGE('***************************************')
               ICOM = ICOM + 1
               GOTO 100
            END IF
  140    CONTINUE
         IF ((CIN(ICOM)(1:1) .EQ. 'S') .OR.
     &      (CIN(ICOM)(1:1) .EQ. 's')) THEN
            STEP = .TRUE.
         ELSE
            STEP = .FALSE.
         END IF
         ICOM = ICOM + 1

C  OPEN THE TEMPORARY FILE

         IUNIT = 99
         OPEN (UNIT = IUNIT, STATUS = 'scratch', FORM = 'unformatted',
     &      ACCESS = 'sequential')
         REWIND IUNIT

C  GENERATE THE MESH

         IF (NPREGN.GT.0) THEN
            CALL MDDEL ('IPART')
            CALL MDDEL ('LSTNBC')
            CALL MDDEL ('LSTSBC')
            CALL MDDEL ('NNFLG')
            CALL MDDEL ('NNPTR')
            CALL MDDEL ('NNLEN')
            CALL MDDEL ('NSFLG')
            CALL MDDEL ('NSPTR')
            CALL MDDEL ('NSLEN')
            CALL MDDEL ('NVPTR')
            CALL MDDEL ('NVLEN')
            CALL MDDEL ('NSIDEN')
            CALL MDDEL ('NUID')
            CALL MDDEL ('XN')
            CALL MDDEL ('YN')
            CALL MDDEL ('NXK')
            CALL MDDEL ('MAT')
            CALL MDDEL ('KXN')
            CALL MDDEL ('LIST')
            CALL MDDEL ('LA')
            CALL MDDEL ('LB')
            CALL MDDEL ('CENTK')
            CALL MDDEL ('MATMAP')
            CALL MDDEL ('LISTN')
            CALL MDDEL ('WTNODE')
            CALL MDDEL ('WTSIDE')
            CALL MDDEL ('WTHOLD')
            CALL MDDEL ('IHERE')
            CALL MDDEL ('ILIST')
            CALL MDDEL ('XLIST')
            IF (.NOT. REMESH) THEN
               CALL MDDEL ('AMESUR')
               CALL MDDEL ('XNOLD')
               CALL MDDEL ('YNOLD')
               CALL MDDEL ('NXKOLD')
               CALL MDDEL ('MMPOLD')
               CALL MDDEL ('LINKEG')
               CALL MDDEL ('LISTEG')
               CALL MDDEL ('BMESUR')
               CALL MDDEL ('CMESUR')
               CALL MDDEL ('DMESUR')
            END IF
            CALL MDSTAT (NERR, MUSED)
            IF (NERR.GT.0) THEN
               CALL MDEROR (6)
               STOP ' '
            END IF
            NPREGN = 0

C  SET UP THE ARRAYS FOR ADAPTIVE REMESHING

         END IF
         IF (.NOT. REMESH) THEN
            CALL MDRSRV ('AMESUR', K(31), 1)
            CALL MDRSRV ('XNOLD',  K(32), 1)
            CALL MDRSRV ('YNOLD',  K(33), 1)
            CALL MDRSRV ('NXKOLD', K(34), 4)
            CALL MDRSRV ('MMPOLD', K(35), 3)
            CALL MDRSRV ('LINKEG', K(36), 2)
            CALL MDRSRV ('LISTEG', K(37), 2)
            CALL MDRSRV ('BMESUR', K(38), 1)
            CALL MDRSRV ('CMESUR', K(39), 1)
            CALL MDRSRV ('DMESUR', K(40), 1)
            NPROLD = 1
            NPNOLD = 1
            NPEOLD = 1
            NNXK = 1
            CALL MDSTAT (NERR, MUSED)
            IF (NERR.GT.0) THEN
               CALL MDEROR (6)
               STOP ' '
            END IF
         END IF

         LGROUP = .FALSE.
         DO 150 I = 1, N(7)
            IF (IRGFLG(I) .GE. 1) THEN
               LGROUP = .TRUE.
               GO TO 160
            END IF
  150    CONTINUE
  160    CONTINUE
         CALL QMESH (A, IA, MP, ML, MS, MR, MSC, MCOM, ICOM, JCOM, CIN,
     &      RIN, IIN, KIN, IUNIT, IDUMP, N, IPOINT, COOR, IPBOUN,
     &      ILINE, LTYPE, NINT, FACTOR, LCON, ILBOUN, ISBOUN, ISIDE,
     &      NLPS, IFLINE, ILLIST, IBARST, JMAT, JCENT, NLPB, JFLINE,
     &      JLLIST, IREGN, IMAT, NSPR, IFSIDE, ISLIST, IRPB, IPBF,
     &      NPPF, IFPB, LISTPB, ILBF, NLPF, IFLB, LISTLB, ISBF, NSPF,
     &      IFSB, LISTSB, LINKP, LINKL, LINKS, LINKB, LINKR, LINKSC,
     &      LINKPB, LINKLB, LINKSB, RSIZE, IFHOLE, NHPR, IHLIST,
     &      IRGFLG, ISCHM, SCHEME, DEFSCH, DEFSIZ, NPREGN, NPNBC, NPSBC,
     &      NPNODE, NPELEM, MAXKXN, STEP, DEV1, THREE, EIGHT, NINE,
     &      LGROUP, BATCH, A(K(31)), A(K(32)), A(K(33)), A(K(34)),
     &      A(K(35)), A(K(36)), A(K(37)), A(K(38)), MLINK, NPROLD,
     &      NPNOLD, NPEOLD, NNXK, REMESH, REXMIN, REXMAX, REYMIN,
     &      REYMAX, IDIVIS, SIZMIN, EMAX, EMIN)

         IF (REMESH) REMESH = .FALSE.
         IF (NPREGN.GT.0) THEN

C  SET UP THE NECESSARY DIMENSIONING FOR NUMBERING

C  A(K(1))  =  IPART   =  ARRAY OF BEGINNING/ENDING ELEMENT NUMBERS/REGION
C  A(K(2))  =  LSTNBC  =  LIST OF NODAL BOUNDARY CONDITIONS
C                      (REORDERED TO NODES)
C  A(K(3))  =  LSTSBC  =  LIST OF SIDE BOUNDARY CONDITIONS
C                      (REORDERED TO NELEMS)
C  A(K(4))  =  NNFLG   =  LIST OF NODAL FLAGS
C  A(K(5))  =  NNPTR   =  POINTERS INTO THE NODES LIST FOR EACH NODE FLAG
C  A(K(6))  =  NNLEN   =  NUMBER OF NODES IN THE LIST FOR EACH NODE FLAG
C  A(K(7))  =  NSFLG   =  LIST OF SIDE FLAGS
C  A(K(8))  =  NSPTR   =  POINTERS INTO THE SIDES LIST FOR EACH SIDE FLAG
C  A(K(9))  =  NSLEN   =  NUMBER OF SIDES IN THE LIST FOR EACH SIDE FLAG
C  A(K(10)) =  NVPTR   =  POINTERS INTO THE NSIDEN LIST FOR EACH SIDE FLAG
C  A(K(11)) =  NVLEN   =  NUMBER OF NODES IN THE NSIDEN LIST FOR EACH
C                     SIDE FLAG
C  A(K(12)) =  NSIDEN  =  LIST OF SIDE NODES ASSOCIATED WITH THE SIDE LIST
C  A(K(13)) =  NUID    =  NODE UNIQUE IDENTIFIER ARRAY
C                     (LATER - MAPDXG ARRAY)
C  A(K(14)) =  XN      =  X COORDINATE OF THE NODES
C  A(K(15)) =  YN      =  Y COORDINATE OF THE NODES
C  A(K(16)) =  NXK     =  NODES PER ELEMENT (CONNECTIVITY) ARRAY
C  A(K(17)) =  MAT     =  MATERIAL NUMBER FOR EACH ELEMENT
C  A(K(18)) =  KXN     =  ELEMENTS ATTACHED TO EACH NODE
C                     (LATER - LOOKUP TABLE)
C  A(K(19)) =  LIST    =  WORKING ARRAY FOR NODE NUMBERING
C                     (LATER - MAPGXD ARRAY)
C  A(K(20)) =  LA      =  WORKING ARRAY FOR NODE NUMBERING
C  A(K(21)) =  LB      =  WORKING ARRAY FOR NODE NUMBERING
C  A(K(22)) =  CENTK   =  ARRAY CONTAINING X, Y LOCATION OF
C                           ELEMENT CENTER
C  A(K(23)) =  MATMAP  =  ARRAY OF BEGIN/END ELEMENT NUMBERS/REGION IN
C                     MAPGXD
C  A(K(24)) =  LISTN   =  LIST FOR RENUMBERING THE NODES FOR
C                     BANDWIDTH OPTIMIZATION
C  A(K(25)) =  WTNODE  =  NODAL BOUNDARY FLAG WEIGHTING FACTOR ARRAY
C  A(K(26)) =  WTSIDE  =  ELEMENT SIDE BOUNDARY FLAG WEIGHTING
C                           FACTOR ARRAY
C  A(K(27)) =  WTHOLD  =  TEMPORARY ARRAY USED FOR MIDSIDE NODE
C                           PROCESSING
C  A(K(28)) =  IHERE   =  A WORK ARRAY FOR SORTING BOUNDARY FLAGS
C  A(K(29)) =  ILIST   =  LINE LIST FOR WEIGHTED BOUNDARIES
C  A(K(30)) =  XLIST   =  WORKING LIST FOR WEIGHTED BOUNDARIES
C  A(K(31)) =  AMESUR  =  FIRST ADAPTIVE MESHING VARIABLE
C  A(K(32)) =  XNOLD   =  OLD XN ARRAY USED DURING ADAPTIVE MESHING
C  A(K(33)) =  YNOLD   =  OLD YN ARRAY USED DURING ADAPTIVE MESHING
C  A(K(34)) =  NXKOLD  =  OLD NXK ARRAY USED DURING ADAPTIVE MESHING
C  A(K(35)) =  MMPOLD  =  OLD MATMAP ARRAY USED DURING ADAPTIVE MESHING
C  A(K(36)) =  LINKEG  =  ELEMENT GRID LINK FOR ADAPTIVE MESHING
C  A(K(37)) =  LISTEG  =  ELEMENT GRID LIST FOR ADAPTIVE MESHING
C  A(K(38)) =  BMESUR  =  AMESUR VALUES AVERAGED AT THE NODES
C  A(K(31)) =  CMESUR  =  SECOND ADAPTIVE MESHING VARIABLE
C  A(K(40)) =  DMESUR  =  CMESUR VALUES AVERAGED AT THE NODES

            IF (EIGHT) THEN
               NPNBC = NPNBC*2
               NPSBC = NPSBC*2
               NNXK = 8
            ELSE IF (NINE) THEN
               NPNBC = NPNBC*2
               NPSBC = NPSBC*2
               NNXK = 9
            ELSE
               NNXK = 4
            END IF
            NPWTS = MAX0 (NPNBC, NPSBC)
            MXNFLG = N(11) + N(13) + 1
            MXSFLG = N(15) + 1
            NNUID = MAX0 (NPNODE, NPNBC, NPSBC, NPELEM)
            MXLPS = 2
            DO 170 I = 1, N(3)
               MXLPS = MAX0(NLPS(I) + 1, MXLPS)
  170       CONTINUE
            CALL MDRSRV ('IPART', K(1), 3*NPREGN)
            CALL MDRSRV ('LSTNBC', K(2), NPNBC)
            CALL MDRSRV ('LSTSBC', K(3), NPSBC)
            CALL MDRSRV ('NNFLG', K(4), MXNFLG)
            CALL MDRSRV ('NNPTR', K(5), MXNFLG)
            CALL MDRSRV ('NNLEN', K(6), MXNFLG)
            CALL MDRSRV ('NSFLG', K(7), MXSFLG)
            CALL MDRSRV ('NSPTR', K(8), MXSFLG)
            CALL MDRSRV ('NSLEN', K(9), MXSFLG)
            CALL MDRSRV ('NVPTR', K(10), MXSFLG)
            CALL MDRSRV ('NVLEN', K(11), MXSFLG)
            CALL MDRSRV ('NSIDEN', K(12), NPSBC)
            CALL MDRSRV ('NUID', K(13), NNUID)
            CALL MDRSRV ('XN', K(14), NPNODE)
            CALL MDRSRV ('YN', K(15), NPNODE)
            CALL MDRSRV ('NXK', K(16), NPELEM*NNXK)
            CALL MDRSRV ('MAT', K(17), NPELEM)
C ... The kxn array is used for a work array in renum and needs to hold npsbc items.
            if (npsbc .gt. maxkxn) maxkxn = npsbc
            CALL MDRSRV ('KXN', K(18), MAXKXN*NNXK)
            CALL MDRSRV ('LIST', K(19), NNUID)
            CALL MDRSRV ('LA', K(20), NPNODE)
            CALL MDRSRV ('LB', K(21), NPNODE)
            CALL MDRSRV ('CENTK', K(22), NPELEM*2)
            CALL MDRSRV ('MATMAP', K(23), NPREGN*3)
            CALL MDRSRV ('LISTN', K(24), NNUID)
            CALL MDRSRV ('WTNODE', K(25), NPNBC)
            CALL MDRSRV ('WTSIDE', K(26), NPSBC)
            CALL MDRSRV ('WTHOLD', K(27), NPWTS)
            CALL MDRSRV ('IHERE',  K(28), NNUID)
            CALL MDRSRV ('ILIST',  K(29), MXLPS)
            CALL MDRSRV ('XLIST',  K(30), MXLPS)
            CALL MDSTAT (NERR, MUSED)
            IF (NERR.GT.0) THEN
               CALL MDEROR (6)
               STOP ' '
            END IF

            if (n(5) .gt. 0) then
              isbars = .true.
            else
              isbars = .false.
            end if

            CALL RENUM (NPNODE, NPELEM, MXNFLG, MXSFLG, NPNBC, NPSBC,
     &         NPWTS, NPREGN, MP, ML, MS, MR, MSC, MAXKXN, NNUID, NNXK,
     &         MXLPS, IUNIT, NNN, KKK, N(28), N(2), N(11), N(13),
     &         N(15), IA(K(1)), IA(K(2)), IA(K(3)), IA(K(4)),
     &         IA(K(5)), IA(K(6)), IA(K(7)), IA(K(8)), IA(K(9)),
     &         IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)),
     &         A(K(14)), A(K(15)), IA(K(16)), IA(K(17)),
     &         IA(K(18)), IA(K(19)), IA(K(20)), IA(K(21)),
     &         IA(K(23)), IA(K(24)), A(K(25)), A(K(26)),
     &         A(K(27)), IA(K(28)), IA(K(29)), A(K(30)), 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  AN ERROR HAS OCCURRED AND THUS THE DUMMY REMESH ARRAYS MUST BE
C  DELETED IF NOT REMESHING

         ELSEIF (.NOT. REMESH) THEN
            CALL MDDEL ('AMESUR')
            CALL MDDEL ('XNOLD')
            CALL MDDEL ('YNOLD')
            CALL MDDEL ('NXKOLD')
            CALL MDDEL ('MMPOLD')
            CALL MDDEL ('LINKEG')
            CALL MDDEL ('LISTEG')
            CALL MDDEL ('BMESUR')
            CALL MDDEL ('CMESUR')
            CALL MDDEL ('DMESUR')
            CALL MDSTAT (NERR, MUSED)
            IF (NERR.GT.0) THEN
               CALL MDEROR (6)
               STOP ' '
            END IF
         END IF

         CLOSE (IUNIT)

C  ENTER LINE FACTORS

      ELSE IF ((CIN(ICOM)(1:1) .EQ. 'F') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 'f')) THEN
         ICOM = ICOM + 1
         IF (ICOM.GT.JCOM) THEN
            CALL MESSAGE('ENTER LINE FACTORS IN THE FOLLOWING FORMAT:')
            CALL MESSAGE('[ LINE NO. (OR NEG. SIDE NO.),  FACTOR ]')
            CALL MESSAGE('HIT RETURN TO END INPUT')
         END IF
  180    CONTINUE
         IF (ICOM.GT.JCOM) THEN
            CALL FREFLD (IZ, IZ, '>', MCOM, IOSTAT, JCOM, KIN, CIN, IIN,
     &         RIN)
            ICOM = 1
         END IF
         CALL GETI1R (MCOM, ICOM, JCOM, CIN, IIN, RIN, KIN, I1, R1,
     &      IFOUND)
         IF (IFOUND.GT.0) THEN
            III(1) = I1
            CALL INFACT (ML, MS, 1, R1, III(1), N(19), N(20), FACTOR,
     &         NLPS, IFLINE, ILLIST, LINKL, LINKS, ADDLNK)
            GOTO 180
         END IF

C  CLEAR OUT ALL THE INTERVALS ASSIGNED TO LINES BY REGION

      ELSE IF ((CIN(ICOM)(1:2) .EQ. 'CI') .OR.
     &   (CIN(ICOM)(1:2) .EQ. 'ci')) THEN
         ICOM = ICOM + 1
         CALL MESSAGE('CLEAR INTERVALS FROM REGIONS FROM <I1> TO <I2>')
         CALL MESSAGE('HIT RETURN TO END INPUT')
  200    CONTINUE
         IF (ICOM.GT.JCOM)THEN
            CALL FREFLD (IZ, IZ, '>', MCOM, IOSTAT, JCOM, KIN, CIN,
     &         IIN, RIN)
            ICOM = 1
         ENDIF
         CALL GETI12 (MCOM, ICOM, JCOM, CIN, IIN, KIN, I1, I2, IFOUND)

         IF (IFOUND .GT. 0) THEN
            IF (I1 .GT. 0) THEN
               CALL CHECK (I1, I2, N (22))

C  REMOVE INTERVALS ON LINES ASSOCIATED WITH THE REGIONS

               DO 230 I = I1, I2
                  CALL LTSORT (MR, LINKR, I, II, ADDLNK)
                  IF (II .GT. 0) THEN
                     DO 220 J = IFSIDE (II), IFSIDE (II) + NSPR (II)-1

C  FIRST REMOVE INTERVALS OF LINES ON SIDE DATA

                        CALL LTSORT (MS, LINKS, ISLIST (J), JJ, ADDLNK)
                        IF ((ISLIST (J) .GT. 0) .AND. (JJ .GT. 0)) THEN
                           DO 210 KKK = IFLINE (JJ), IFLINE (JJ) +
     &                        NLPS (JJ)-1
                              CALL LTSORT (ML, LINKL, ILLIST (KKK), KK,
     &                           ADDLNK)
                              IF (KK .GT. 0) NINT (KK) = 0
  210                      CONTINUE

C  NEXT REMOVE INTERVALS ON LINES ALONE

                        ELSE
                           JJ = IABS (ISLIST (J))
                           CALL LTSORT (ML, LINKL, JJ, KK, ADDLNK)
                           IF (KK.GT.0) NINT (KK) = 0
                        ENDIF
  220                CONTINUE
                  ENDIF
  230          CONTINUE
               GOTO 200
            ENDIF
         ENDIF

C     ADJUST THE MESH

      ELSE IF ((CIN(ICOM)(1:2) .EQ. 'AD') .OR.
     &   (CIN(ICOM)(1:2) .EQ. 'ad')) THEN
         ICOM = ICOM + 1
         IF (KKK.LE.0) THEN
            CALL MESSAGE(' ')
            CALL MESSAGE('****************************************')
            CALL MESSAGE('*      NO ELEMENTS IN DATABASE         *')
            CALL MESSAGE('*    NO MESH ADJUSTMENT POSSIBLE       *')
            CALL MESSAGE('****************************************')
            CALL MESSAGE(' ')
            GOTO 100
         END IF
         CALL ADJMSH (MS, MR, NPNODE, NPELEM, MXNFLG, MXSFLG, NPREGN,
     &      NPNBC, NPSBC, MCOM, ICOM, JCOM, CIN, RIN, IIN, KIN, NNN,
     &      KKK, NNXK, IA(K(2)), IA(K(3)), IA(K(4)), IA(K(5)), IA(K(6)),
     &      IA(K(7)), IA(K(8)), IA(K(9)), IA(K(10)), IA(K(11)),
     &      IA(K(12)), IA(K(13)), A(K(14)), A(K(15)), IA(K(16)),
     &      IA(K(17)), IA(K(19)), IA(K(23)), A(K(25)), A(K(26)), NBCNOD,
     &      NNLIST, NBCSID, NSLIST, NVLIST, NUMMAT, LINKM, TITLE, ERR,
     &      EIGHT, NINE, VERSN)
         IF (ERR) THEN
            CALL MESSAGE(' ')
            CALL MESSAGE('******************************************')
            CALL MESSAGE('*         ERROR ADJUSTING MESH           *')
            CALL MESSAGE('******************************************')
            CALL MESSAGE(' ')
         END IF

C     CALCULATE A DISTORTION INDEX FOR THE REGIONS

      ELSE IF (((CIN(ICOM)(1:1) .EQ. 'D') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 'd')) .AND.
     &   (CIN(ICOM)(2:2) .NE. 'N') .AND.
     &   (CIN(ICOM)(2:2) .NE. 'n')) THEN
         ICOM = ICOM + 1
         IF (KKK.LE.0) THEN
            CALL MESSAGE(' ')
            CALL MESSAGE('****************************************')
            CALL MESSAGE('*      NO ELEMENTS IN DATABASE         *')
            CALL MESSAGE('*   NO DISTORTION INDEX CALCULATED     *')
            CALL MESSAGE('****************************************')
            CALL MESSAGE(' ')
            GOTO 100
         END IF
         CALL RGDSTR (NPNODE, NPELEM, KKK, NNXK, IA(K(14)),
     &      A(K(15)), A(K(16)) )

C     Write out the mesh data into the genesis or exodusII data base
      ELSE IF ((CIN(ICOM)(1:1) .EQ. 'W') .OR.
     &         (CIN(ICOM)(1:1) .EQ. 'w')) THEN
         ICOM = ICOM + 1
         IF (KKK.LE.0) THEN
            CALL MESSAGE(' ')
            CALL MESSAGE('****************************************')
            CALL MESSAGE('*       NO ELEMENTS IN DATABASE        *')
            CALL MESSAGE('*  NO EXODUSII FILE WRITING POSSIBLE   *')
            CALL MESSAGE('****************************************')
            CALL MESSAGE(' ')
            GOTO 100
         END IF
         IUNIT = 9
  240    CONTINUE
         IF (BATCH) THEN
            CALL EXNAME (IUNIT, FNAME, LN)
         ELSE
            IF (ICOM.LE.JCOM) THEN
               FNAME = CIN(ICOM)
               LN = lenstr(FNAME)
               ICOM = ICOM + 1
            ELSE
               CALL INQSTR ('OUTPUT DATABASE FILE NAME: ',
     &            FNAME)
               LN = lenstr(FNAME)
            END IF
         END IF
C ... Create the exodusII file
         if (EXODUSII) THEN
            CMPSIZ = 0
            IOWS   = 0

C ... See if user-specified output word size EXT05
            call exname (-5, hold, llen)
            if (llen .lt. 1) goto 25
            read(hold,'(i1)',ERR=25)iows
            goto 26
 25         continue

            call exparm (cdumh, cdums, idum, iows, idum, idum)
 26         continue

C ... One final check to make sure we have a valid iows.
            if (iows .ne. 4 .and. iows .ne. 8) then
              iows = 4
            endif

            iunit = excre(FNAME(:LN), EXCLOB, CMPSIZ, IOWS, IERR)
            if (ierr .lt. 0) then
               call exopts (EXVRBS, ierr)
               call exerr('fastq', 'Error from excre', ierr)
               if (batch) then
                 stop 'Exodus Error'
               else
                 go to 240
               endif
            endif
            CALL WREX2 (MS, MR, NPNODE, NPELEM, MXNFLG, MXSFLG, NPREGN,
     &           NPNBC, NPSBC, IUNIT, NNN, KKK, NNXK, IA(K(2)),
     &           IA(K(3)), IA(K(4)), IA(K(5)), IA(K(6)), IA(K(7)),
     &           IA(K(8)), IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)),
     &           IA(K(13)), A(K(14)), A(K(15)), IA(K(16)), IA(K(17)),
     &           IA(K(19)), IA(K(23)), A(K(25)), A(K(26)),
     &           NBCNOD, NNLIST, NBCSID, NSLIST, NVLIST, NUMMAT, LINKM,
     &           TITLE, ERR, EIGHT, NINE, VERSN, A, IA, FNAME(:LN))
            IF (ERR) THEN
               IF (BATCH) THEN
                  CALL MESSAGE(' ')
                  CALL MESSAGE
     &                 ('******************************************')
                  CALL MESSAGE
     &                 ('*  ERROR WRITING GENESIS DATABASE FILE   *')
                  CALL MESSAGE
     &                 ('*         NO OUTPUT FILE SAVED           *')
                  CALL MESSAGE
     &                 ('******************************************')
                  CALL MESSAGE(' ')
                  STOP
               END IF
            END IF
            call exclos(iunit, ierr)
         else
            OPEN (UNIT = IUNIT, FILE = FNAME(:LN), STATUS = 'UNKNOWN',
     &           FORM = 'UNFORMATTED', ACCESS = 'SEQUENTIAL', ERR = 240)
            REWIND IUNIT
            CALL WRGENS (MS, MR, NPNODE, NPELEM, MXNFLG, MXSFLG, NPREGN,
     &           NPNBC, NPSBC, IUNIT, NNN, KKK, NNXK, IA(K(2)),
     &           IA(K(3)), IA(K(4)), IA(K(5)), IA(K(6)), IA(K(7)),
     &           IA(K(8)), IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)),
     &           IA(K(13)), A(K(14)), A(K(15)), IA(K(16)), IA(K(17)),
     &           IA(K(19)), IA(K(23)), A(K(25)), A(K(26)),
     &           NBCNOD, NNLIST, NBCSID, NSLIST, NVLIST, NUMMAT, LINKM,
     &           TITLE, ERR, EIGHT, NINE, VERSN)
            IF (ERR) THEN
               CLOSE (UNIT = IUNIT, STATUS = 'DELETE')
               IF (BATCH) THEN
                  CALL MESSAGE(' ')
                  CALL MESSAGE
     &                 ('******************************************')
                  CALL MESSAGE
     &                 ('*  ERROR WRITING GENESIS DATABASE FILE   *')
                  CALL MESSAGE
     &                 ('*         NO OUTPUT FILE SAVED           *')
                  CALL MESSAGE
     &                 ('******************************************')
                  CALL MESSAGE(' ')
                  STOP
               END IF
            ELSE
               CLOSE (UNIT = IUNIT, STATUS = 'KEEP')
            end if
         end if

C     WRITE OUT THE MESH DATA INTO THE ERROR CODE DATA FORMAT

      ELSE IF ((CIN (ICOM) (1:1) .EQ. 'J') .OR.
     &   (CIN (ICOM) (1:1) .EQ. 'j')) THEN
         ICOM = ICOM + 1
         IF (KKK.LE.0) THEN
            CALL MESSAGE(' ')
            CALL MESSAGE('****************************************')
            CALL MESSAGE('*      NO ELEMENTS IN DATABASE         *')
            CALL MESSAGE('*     NO FILE WRITING POSSIBLE        *')
            CALL MESSAGE('****************************************')
            CALL MESSAGE(' ')
            GOTO 100
         END IF
         IUNIT = 99
  250    CONTINUE
         IF (ICOM.LE.JCOM) THEN
            FNAME = CIN (ICOM)
            ICOM = ICOM + 1
         ELSE
            CALL INQSTR ('JOE''S ERROR OUTPUT FILE NAME: ', FNAME)
         END IF
         OPEN (UNIT = IUNIT, FILE = FNAME, STATUS = 'NEW', ERR = 250)
         REWIND IUNIT
         CALL WRJERR (MS, MR, NPNODE, NPELEM, MXNFLG, MXSFLG, NPREGN,
     &      NPNBC, NPSBC, IUNIT, NNN, KKK, NNXK, IA(K(2)), IA(K(3)),
     &      IA(K(4)), IA(K(5)), IA(K(6)), IA(K(7)), IA(K(8)),
     &      IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)),
     &      A(K(14)), A(K(15)), IA(K(16)), IA(K(17)), IA(K(19)),
     &      IA(K(23)), NBCNOD, NNLIST, NBCSID, NSLIST, NVLIST, NUMMAT,
     &      LINKM, TITLE, ERR, EIGHT, NINE)
         IF(ERR) THEN
            CLOSE (UNIT = IUNIT, STATUS = 'DELETE')
         ELSE
            CLOSE (UNIT = IUNIT, STATUS = 'KEEP')
         END IF

C     WRITE OUT THE MESH DATA INTO THE ABAQUS DATA FORMAT

      ELSE IF ((CIN (ICOM) (1:1) .EQ. 'A') .OR.
     &   (CIN (ICOM) (1:1) .EQ. 'a')) THEN
         ICOM = ICOM + 1
         IF (KKK.LE.0) THEN
            CALL MESSAGE(' ')
            CALL MESSAGE('****************************************')
            CALL MESSAGE('*      NO ELEMENTS IN DATABASE         *')
            CALL MESSAGE('*     NO FILE WRITING POSSIBLE        *')
            CALL MESSAGE('****************************************')
            CALL MESSAGE(' ')
            GOTO 100
         END IF
         IUNIT = 99
  260    CONTINUE
         IF (ICOM.LE.JCOM) THEN
            FNAME = CIN (ICOM)
            ICOM = ICOM + 1
         ELSE
            CALL INQSTR ('ABAQUS OUTPUT FILE NAME: ', FNAME)
         END IF
         OPEN (UNIT = IUNIT, FILE = FNAME, STATUS = 'UNKNOWN',
     &        ERR = 260)
         REWIND IUNIT
         CALL WRABQS (MS, MR, NPNODE, NPELEM, MXNFLG, MXSFLG, NPREGN,
     &      NPNBC, NPSBC, IUNIT, NNN, KKK, NNXK, IA(K(2)), IA(K(3)),
     &      IA(K(4)), IA(K(5)), IA(K(6)), IA(K(7)), IA(K(8)),
     &      IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)),
     &      A(K(14)), A(K(15)), IA(K(16)), IA(K(17)), IA(K(19)),
     &      IA(K(23)), NBCNOD, NNLIST, NBCSID, NSLIST, NVLIST, NUMMAT,
     &      LINKM, TITLE, ERR, EIGHT, NINE)
         IF(ERR) THEN
            CLOSE (UNIT = IUNIT, STATUS = 'DELETE')
         ELSE
            CLOSE (UNIT = IUNIT, STATUS = 'KEEP')
         END IF

C     WRITE OUT THE MESH DATA INTO THE NASTRAN DATA FORMAT

      ELSE IF ((CIN(ICOM)(1:1) .EQ. 'N') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 'n') .OR. (CIN(ICOM)(1:2) .EQ. 'DN') .OR.
     &   (CIN(ICOM)(1:1) .EQ. 'DN')) THEN
         ICOM = ICOM + 1
         IF ((CIN(ICOM)(1:1) .EQ. 'N') .OR.
     &      (CIN(ICOM)(1:1) .EQ. 'n')) THEN
            LONG = .TRUE.
         ELSE
            LONG = .FALSE.
         ENDIF
         IF (KKK.LE.0) THEN
            CALL MESSAGE(' ')
            CALL MESSAGE('****************************************')
            CALL MESSAGE('*      NO ELEMENTS IN DATABASE         *')
            CALL MESSAGE('*     NO FILE WRITING POSSIBLE        *')
            CALL MESSAGE('****************************************')
            CALL MESSAGE(' ')
            GOTO 100
         END IF
         IUNIT = 99
  270    CONTINUE
         IF (ICOM.LE.JCOM) THEN
            FNAME = CIN(ICOM)
            ICOM = ICOM + 1
         ELSE
            CALL INQSTR ('NASTRAN OUTPUT FILE NAME: ', FNAME)
         END IF
         OPEN (UNIT = IUNIT, FILE = FNAME, STATUS = 'UNKNOWN',
     &        ERR = 270)
         REWIND IUNIT
         CALL WRNAST (MS, MR, NPNODE, NPELEM, MXNFLG, MXSFLG, NPREGN,
     &      NPNBC, NPSBC, IUNIT, NNN, KKK, NNXK, IA(K(2)), IA(K(3)),
     &      IA(K(4)), IA(K(5)), IA(K(6)), IA(K(7)), IA(K(8)),
     &      IA(K(9)), IA(K(10)), IA(K(11)), IA(K(12)), IA(K(13)),
     &      A(K(14)), A(K(15)), IA(K(16)), IA(K(17)), IA(K(19)),
     &      IA(K(23)), NBCNOD, NNLIST, NBCSID, NSLIST, NVLIST, NUMMAT,
     &      LINKM, TITLE, ERR, EIGHT, NINE, LONG)
         IF (ERR) THEN
            CLOSE (UNIT = IUNIT, STATUS = 'DELETE')
         ELSE
            CLOSE (UNIT = IUNIT, STATUS = 'KEEP')
         END IF
      ELSE
         ICOM = ICOM + 1
         CALL HELP_FQ (12)
      END IF
      GOTO 100

10000 FORMAT (' REGION NO:', I5, ' IS NOT IN THE DATABASE', /,
     &   ' THUS NO SIZE CAN BE ENTERED')

      END
