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 WRGENS (MS, MR, NPNODE, NPELEM, MXNFLG, MXSFLG, NPREGN,
     &   NPNBC, NPSBC, IUNIT, NNN, KKK, NNXK, NODES, NELEMS, NNFLG,
     &   NNPTR, NNLEN, NSFLG, NSPTR, NSLEN, NVPTR, NVLEN, NSIDEN,
     &   MAPDXG, XN, YN, NXK, MAT, MAPGXD, MATMAP, WTNODE, WTSIDE,
     &   NBCNOD, NNLIST, NBCSID, NSLIST, NVLIST, NUMMAT, LINKM, TITLE,
     &   ERR, EIGHT, NINE, VERSN)
C************************************************************************

C  SUBROUTINE WRGENS = WRITES GENESIS DATABASE MESH OUTPUT

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

      PARAMETER (IGUESS = 1000)

C  IGUESS IS THE NUMBER OF ELEMENT BLOCKS,  FOR USE WITH THE ENAME
C  VARIABLE.  IF THIS VARIABLE IS NOT AS LARGE AS NUMMAT,  IT WILL NOT
C  RESULT IN A FATAL ERROR,  BUT SIMPLY A WARNING,  AND NO ELEMENT
C  NAMES WILL BE WRITTEN.

      DIMENSION XN (NPNODE), YN (NPNODE), NXK (NNXK, NPELEM)
      DIMENSION MAT (NPELEM)
      DIMENSION NODES (NPNBC), NELEMS (NPSBC), NSIDEN (NPSBC)
      DIMENSION NNFLG (MXNFLG), NNLEN (MXNFLG)
      DIMENSION NNPTR (MXNFLG), WTNODE (NPNBC)
      DIMENSION NSFLG (MXSFLG), NSLEN (MXSFLG)
      DIMENSION NSPTR (MXSFLG), WTSIDE (NPSBC)
      DIMENSION NVLEN (MXSFLG), NVPTR (MXSFLG), LINKM (2,  (MS+MR))
      DIMENSION MAPDXG (NPNODE), MAPGXD (NPNODE), MATMAP (3, NPREGN)

      CHARACTER*72 TITLE, HOLD*80
      CHARACTER*8 DATE, TIME, VERSN1, VERSN2, XNAME, YNAME
      CHARACTER*8 ENAME (IGUESS)
      CHARACTER*10 VERSN

      LOGICAL ERR, EIGHT, NINE

      integer lcon(9)
      integer lbar(3)

      data lcon /1,3,5,7,2,4,6,8,9/
      data lbar /1,3,2/

      CALL EXDATE (DATE)
      CALL EXTIME (TIME)
      VERSN1 = '        '
      VERSN2 = '        '
      VERSN1 = VERSN (1:5)
      VERSN2 = VERSN (6:10)
      ERR = .TRUE.
      HOLD = TITLE
      XNAME = 'X'
      YNAME = 'Y'

C  CHECK TO MAKE SURE THAT THERE IS ENOUGH ROOM FOR ELEMENT NAMES

      IF (NUMMAT.GT.IGUESS) THEN
         CALL MESSAGE('WARNING:  THE NUMBER OF ELEMENT BLOCKS EXCEEDS')
         CALL MESSAGE('          THE CAPACITY TO NAME EACH BLOCK.')
         CALL MESSAGE('          NO ELEMENT NAMES WILL BE WRITTEN.')
      ENDIF

C  WRITE OUT HEADER INFORMATION

      WRITE (IUNIT, ERR = 110)HOLD
      IJK = 2
      IVERS = 1
C ... Fix up side set nodes for 8 and 9 node elements.
C ... At this point, they are treated as two linear segments,
C ... They should be ends followed by middle

C    1-----3-----2 Now: 1 3 3 2 Correct: 1 2 3

      if (eight .or. nine) then
         nvlst = nvlist / 4 * 3
         if (nslist .gt. 1) then
            nslst = nslist / 2
         else
            nslst = nslist
         end if
      else
         nvlst = nvlist
         nslst = nslist
      end if

      WRITE (IUNIT, ERR = 110)NNN, IJK, KKK, NUMMAT, NBCNOD, NNLIST,
     &   NBCSID, NSLST, NVLST, IVERS

C  WRITE OUT NODE BLOCK

      WRITE (IUNIT, ERR = 110) (XN (I), I = 1, NNN),
     &   (YN (I), I = 1, NNN)
      WRITE (IUNIT, ERR = 110) (MAPDXG (I), I = 1, KKK)

C  WRITE OUT ELEMENT BLOCKS

      DO 100 I = 1, NUMMAT
         IF (NXK (3, MATMAP (2, I)) .EQ. 0) THEN
            INODE = 2
            NATTR = 1
            ATTR = 1.
            IF (I.LE.IGUESS)ENAME (I) = 'BEAM'
         ELSEIF (NXK (4, MATMAP (2, I)) .EQ. 0) THEN
            INODE = 3
            NATTR = 1
            ATTR = 1.
            IF (I.LE.IGUESS)ENAME (I) = 'BEAM'
            CALL MESSAGE('NOTE:  The connectivity numbering for 3-node')
            CALL MESSAGE('       beams/trusses has been fixed to')
            CALL MESSAGE('       conform to EXODUS convention (1-3-2)')
         ELSEIF (EIGHT) THEN
            INODE = 8
            NATTR = 0
            IF (I.LE.IGUESS)ENAME (I) = 'QUAD'
         ELSEIF (NINE) THEN
            INODE = 9
            NATTR = 0
            IF (I.LE.IGUESS)ENAME (I) = 'QUAD'
         ELSE
            INODE = 4
            NATTR = 0
            IF (I.LE.IGUESS)ENAME (I) = 'QUAD'
         ENDIF

C  NLOOP IS NEEDED TO WRITE SOMETHING OUT THE CURRENT COUNTER IS ZERO.
C  THIS IS DONE TO SOLVE A CRAY OPERATING SYSTEM [CTSS] PROBLEM
C  WHERE NULL RECORD WRITES ARE NOT DONE APPROPRIATELY

         WRITE (IUNIT, ERR = 110) MATMAP (1, I),
     &      MATMAP (3, I) - MATMAP (2, I)+1, INODE, NATTR
C... 8 or 9 node quads
         IF (INODE .EQ. 8 .or. inode .eq. 9) THEN
            write (iunit, err = 110) ((nxk(lcon(ii), k), ii=1, nnxk),
     $           k = matmap(2,i), matmap(3,i))
C... 3 node beam/truss
         ELSEIF (INODE .EQ. 3) THEN
            write (iunit, err = 110) ((nxk(lbar(ii), k), ii=1, inode),
     $           k = matmap(2,i), matmap(3,i))
C... 4 node quad or 2 node beam/truss
         ELSE
            WRITE (IUNIT, ERR = 110) ((NXK (J, K), J = 1, INODE),
     &         K = MATMAP (2, I), MATMAP (3, I))
         ENDIF
         NLOOP = MAX0 (1, NATTR*KKK)
         WRITE (IUNIT, ERR = 110) (ATTR, J = 1, NLOOP)
  100 CONTINUE

C  WRITE OUT NODAL BOUNDARY FLAGS

      NLOOP = MAX0 (1, NBCNOD)
      WRITE (IUNIT, ERR = 110) (NNFLG (I), I = 1, NLOOP)
      WRITE (IUNIT, ERR = 110) (NNLEN (I), I = 1, NLOOP)
      WRITE (IUNIT, ERR = 110) (NNPTR (I), I = 1, NLOOP)
      NLOOP = MAX0 (1, NNLIST)
      WRITE (IUNIT, ERR = 110) (NODES (I), I = 1, NLOOP)
      WRITE (IUNIT, ERR = 110) (WTNODE (I), I = 1, NLOOP)

C  WRITE OUT SIDE BOUNDARY FLAGS

C ... Fix up side set nodes and elements for 8 and 9 node elements.
C ... At this point, they are treated as two linear segments,
C ... They should be ends followed by middle

C    1-----3-----2 Now: 1 3 3 2 Correct: 1 2 3

      if (eight .or. nine) then
         ipn = 1
         ipe = 1
         do 130 ibc = 1, nbcsid

            ibee = nsptr(ibc)
            iene = nsptr(ibc) + nslen(ibc) - 1
            nsptr(ibc) = ipe
            nslen(ibc) = max(1, nslen(ibc)/2)
            do 115 iel = ibee, iene, 2
               nelems(ipe)   = nelems(iel)
               ipe = ipe + 1
 115        continue

            ibeg = nvptr(ibc)
            iend = nvptr(ibc) + nvlen(ibc) - 1
            nvptr(ibc) = ipn
            nvlen(ibc) = nvlen(ibc) / 4 * 3

            do 120 inod = ibeg, iend, 4
               nsiden(ipn)   = nsiden(inod)
               nsiden(ipn+2) = nsiden(inod+1)
               nsiden(ipn+1) = nsiden(inod+3)
               wtside(ipn)   = wtside(inod)
               wtside(ipn+2) = wtside(inod+1)
               wtside(ipn+1) = wtside(inod+3)
               ipn = ipn + 3
 120        continue
 130     continue
         nvlist = ipn - 1
         nslist = ipe - 1
      end if

      NLOOP = MAX0 (1, NBCSID)
      WRITE (IUNIT, ERR = 110) (NSFLG (I), I = 1, NLOOP)
      WRITE (IUNIT, ERR = 110) (NSLEN (I), I = 1, NLOOP)
      WRITE (IUNIT, ERR = 110) (NVLEN (I), I = 1, NLOOP)
      WRITE (IUNIT, ERR = 110) (NSPTR (I), I = 1, NLOOP)
      WRITE (IUNIT, ERR = 110) (NVPTR (I), I = 1, NLOOP)
      NLOOP = MAX0 (1, NSLIST)
      WRITE (IUNIT, ERR = 110) (NELEMS (I), I = 1, NLOOP)
      NLOOP = MAX0 (1, NVLIST)
      WRITE (IUNIT, ERR = 110) (NSIDEN (I), I = 1, NLOOP)
      WRITE (IUNIT, ERR = 110) (WTSIDE (I), I = 1, NLOOP)

C  WRITE OUT THE QA INFORMATION

      IHOLD = 1
      WRITE (IUNIT, ERR = 110)IHOLD
      WRITE (IUNIT, ERR = 110)VERSN1, VERSN2, DATE, TIME

C  WRITE THE HEADER INFORMATION

      IHOLD = 0
      WRITE (IUNIT, ERR = 110)IHOLD

C  WRITE THE COORDINATE NAMES AND ELEMENT NAMES

      WRITE (IUNIT)XNAME, YNAME
      IF (NUMMAT.LE.IGUESS)WRITE (IUNIT) (ENAME (I), I = 1, NUMMAT)

C  SUCCESSFUL WRITE COMPLETED

      CALL MESSAGE(' ')
      CALL MESSAGE(' ')
      CALL MESSAGE('GENESIS OUTPUT FILE SUCCESSFULLY WRITTEN')
      CALL MESSAGE(' ')
      ERR = .FALSE.
      RETURN

C  ERR DURING WRITE PROBLEMS

  110 CONTINUE
      CALL MESSAGE('ERR DURING WRITE TO OUTPUT FILE')
      CALL MESSAGE('      - NO FILE SAVED -')
      RETURN

      END
