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=======================================================================
      SUBROUTINE WELB (NDBOUT, NELBLK, VISELB, ALLELE, BLKTYP,
     &           NUMLNK, NUMATR, LINK, ATRIB, NUMELB, IXELB, IXELBO,
     &           IXELEM, NEWNOD, NODIX, IDELB, A, IA, C, MERR)
C=======================================================================

C   --The original version of this code was written by
C   --Amy Gilkey - revised 04/19/88
C   --*** RWELB *** (ALGEBRA) Read and write database element blocks
C   --RWELB was modified and renamed to WELB 8/25/95
C   --
C   --WELB writes the element block information to the database.
C   --Deleted elements are removed and nodes are renumbered.
C   --
C   --Parameters:
C   --   NDBOUT   - IN - the output database file
C   --   NELBLK   - IN - the number of element blocks
C   --   VISELB   - IN - true iff element block i is to be written
C   --   ALLELE   - IN - true iff all elements are selected
C   --   BLKTYP   - IN - element type for each element block
C   --   NUMLNK   - IN - Number of nodes per element for each element block
C   --   NUMATR   - IN - Number of attributes for each element block
C   --   LINK     - IN - Connectivity array for element blocks
C   --   ATRIB    - IN - Attribute array for element blocks
C   --   NUMELB   - I/O - the number of elements in each block; set if ALLELE
C   --   IXELB    - I/O - the cumulative element counts for each
C   --                     element block; set if ALLELE
C   --   IXELBO   - I/O - the cumulative element counts for each output block;
C   --                     set if ALLELE
C   --   IXELEM   - IN - the indices of the output elements
C   --                   (iff IXELBO <> IXELB)
C   --   NEWNOD   - IN - true iff nodes are renumbered
C   --   NODIX(i) - IN - the zoom mesh index for each node (iff NEWNOD)
C   --   A        - IN - the dynamic memory array
C   --   MERR     - OUT - memory error flag

      include 'exodusII.inc'

      INTEGER NDBOUT
      INTEGER NELBLK
      LOGICAL VISELB(NELBLK)
      LOGICAL ALLELE
      CHARACTER*(MXSTLN) BLKTYP(*)
      INTEGER NUMLNK(*)
      INTEGER NUMATR(*)
      INTEGER LINK(*)
      REAL    ATRIB(*)
      INTEGER NUMELB(*)
      INTEGER IXELB(0:NELBLK)
      INTEGER IXELBO(0:NELBLK)
      INTEGER IXELEM(*)
      LOGICAL NEWNOD
      INTEGER NODIX(*)
      INTEGER IDELB(*)
      DIMENSION A(1)
      INTEGER IA(1)
      CHARACTER*1 C(1)
      INTEGER MERR

      CHARACTER*(MXSTLN) NAEB
      INTEGER NELB, EBID, NLNK, NATR
      INTEGER NERR

      MERR  = 0
      ILNK  = 0
      IATR  = 0
      ISLNK = 0
      ISATR = 0

      IF (ALLELE) THEN
         IXELB(0) = 0
         IXELBO(0) = 0
      END IF

      MAXCON = NUMLNK(1)*NUMELB(1)
      MAXATR = NUMATR(1)*NUMELB(1)
      DO 90 I = 1, NELBLK
         NELB = NUMELB(I)
         NLNK = NUMLNK(I)
         NATR = NUMATR(I)
         IF (NELB*NLNK .GT. MAXCON) MAXCON = NELB*NLNK
         IF (NELB*NATR .GT. MAXATR) MAXATR = NELB*NATR
  90  CONTINUE

      if (allele) then
        call expclb(ndbout, IDELB, BLKTYP, NUMELB, NUMLNK, NUMATR,
     *    .TRUE., IERR)
      else
        call mdrsrv('IDSCR',  kidscr,  nelblk)
        call mdrsrv('NUMSCR', knumscr, nelblk)
        call mdrsrv('LNKSCR', klnkscr, nelblk)
        call mdrsrv('NATSCR', knatscr, nelblk)
        call mcrsrv('NAMSCR', knamscr, nelblk*mxstln)
        CALL MDSTAT (NERR, MEM)
        IF (NERR .GT. 0) then
          call memerr
          MERR = 1
          return
        end if
C     Loop from 1 to number of element blocks
        ielbo = 0
        DO IELB = 1, NELBLK
          if (viselb(ielb)) then
            ielbo = ielbo + 1
            itmp = isetarr(ia(kidscr),  ielbo, idelb(ielb))
            itmp = isetarr(ia(knatscr), ielbo, numatr(ielb))
            itmp = isetarr(ia(klnkscr), ielbo, numlnk(ielb))
            call cpynam(blktyp(ielb), c(knamscr), ielbo)
            NELBO = IXELBO(IELB) - IXELBO(IELB-1)
            itmp = isetarr(ia(knumscr), ielbo, nelbo)
          end if
        end do
C ... Wrap this call to handle character*(1) vs character*(mxstln) weirdness
        call blkout(ndbout, ia(kidscr), c(knamscr), ia(knumscr),
     *    ia(klnkscr), ia(knatscr))
        call mddel('IDSCR')
        call mddel('NUMSCR')
        call mddel('LNKSCR')
        call mddel('NATSCR')
        call mcdel('NAMSCR')
        CALL MDSTAT (NERR, MEM)
        IF (NERR .GT. 0) then
          call memerr
          MERR = 1
          return
        end if
      end if

C     Loop from 1 to number of element blocks
      DO 100 IELB = 1, NELBLK

C           These variable must be set here in order to calculate
C           the correct indices for the LINK and ATRIB arrays
C           The problem arises when the VISIBLE command is used
C           and not all element blocks are visible
            NELB = NUMELB(IELB)
            NLNK = NUMLNK(IELB)
            NATR = NUMATR(IELB)
            ISLNK = ILNK + 1
            ILNK = ILNK + (NLNK * NELB)
            ISATR = IATR + 1
            IATR = IATR + (NATR * NELB)

C        If write all elements or write this element block
         IF (ALLELE .OR. VISELB(IELB)) THEN

            EBID = IDELB(IELB)
            NAEB = BLKTYP(IELB)

            IF (ALLELE) THEN
               IXELB(IELB)  = IXELB(IELB-1)  + NELB
               IXELBO(IELB) = IXELBO(IELB-1) + NELB
            END IF

            NELBO = IXELBO(IELB) - IXELBO(IELB-1)

            if ((NELBO .NE. NELB)  .or. NEWNOD) then
               CALL MDRSRV('LNSCR', KLNSCR, MAX(NELB,NELBO)*NLNK)
               CALL MDRSRV('ATRSCR', KATSCR, MAX(NELB,NELBO)*NATR)
               CALL MDSTAT (NERR, MEM)
               IF (NERR .GT. 0) then
                  call memerr
                  MERR = 1
                  return
               end if
            else
               klnscr = 1
               katscr = 1
            end if

            IEL  = IXELB(IELB-1)+1
            IELO = IXELBO(IELB-1)+1

C           Write element block connectivity array
C           Write element block attributes
            CALL WCONAT (NDBOUT, NELB, NELBO, IEL, IXELEM(IELO),
     &           NLNK, NATR, MAX(1,NLNK), MAX(1,NATR),
     &           LINK(ISLNK), ATRIB(ISATR), NAEB,
     &           EBID, NEWNOD, NODIX,
     &           A(KLNSCR), A(KATSCR))

            IF (nelbo .ne. nelb  .or.  newnod) THEN
               CALL MDDEL ('LNSCR')
               CALL MDDEL ('ATRSCR')
               CALL MDSTAT (NERR, MEM)
               IF (NERR .GT. 0) then
                  call memerr
                  MERR = 1
                  return
               end if
            END IF

         END IF
  100 CONTINUE

      RETURN
      END

      integer function isetarr(intarr, ipos, ival)

      integer intarr(*)
      integer ipos

      intarr(ipos) = ival
      isetarr = ival
      return
      end

      subroutine cpynam(namei, nameo, idx)
      include 'exodusII.inc'

      character*(mxstln) namei
      character*(mxstln) nameo(*)
      nameo(idx) = namei
      return
      end

      subroutine blkout(ndbout, idelb, names, numelb, numlnk, numatr)
      include 'exodusII.inc'
      integer idelb(*)
      character*(mxstln) names(*)
      integer numelb(*)
      integer numlnk(*)
      integer numatr(*)
      call expclb(ndbout, idelb, names, numelb, numlnk, numatr,
     *  .true., ierr)
      return
      end
