C Copyright(C) 2011-2017 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 Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C 
C * Redistributions of source code must retain the above copyright
C    notice, this list of conditions and the following disclaimer.
C           
C * Redistributions in binary form must reproduce the above
C   copyright notice, this list of conditions and the following
C   disclaimer in the documentation and/or other materials provided
C   with the distribution.
C                         
C * Neither the name of NTESS nor the names of its
C   contributors may be used to endorse or promote products derived
C   from this software without specific prior written permission.
C                                                 
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C=======================================================================
      SUBROUTINE MAKCOL (LINK, NUMNP, NUMCOL, NEROW, IELCEN, ICOL1,
     &   IRBOT, IRTOP, IRBDIF,
     &   NPBROW, NPBCOL, NPTROW, NPTCOL)
C=======================================================================

C   --*** MAKCOL *** (GEN3D) Compute center block row x column
C   --   Written by Amy Gilkey - revised 04/26/88
C   --
C   --MAKCOL orders the elements in a center block by row and column.
C   --The elements have already been ordered into rows, so this routine
C   --needs to determine which column the first element of a row is in.
C   --It does this by comparing the rows on top and bottom of a given row.
C   --
C   --Parameters:
C   --   LINK - IN - the connectivity for the 2D elements, always 4 nodes
C   --   NUMNP - IN - the number of nodes
C   --   NUMCOL - IN - the number of columns in the center blocks
C   --   NEROW - IN - the number of element rows in the center blocks
C   --   IELCEN - IN - the element numbers of the center elements
C   --      by column and row (column 1 is not necessarily the center)
C   --   ICOL1 - IN/OUT - the column number of the first element in a row;
C   --      upon entry, 1 iff center row, else 0; destroyed
C   --   IRBOT, IRTOP - OUT - the row number of the row on top and bottom
C   --   IRBDIF - SCRATCH - size = NEROW
C   --   NPBROW, NPBCOL, NPTROW, NPTCOL - SCRATCH - size = NUMNP
C   --
C   --Common Variables:
C   --   Uses IX1, IX2, IX3, IX4 of /CENPAR/

      INCLUDE 'g3_cenpar.blk'

      INTEGER LINK(4,*)
      INTEGER IELCEN(NUMCOL,*)
      INTEGER ICOL1(*)
      INTEGER IRBOT(*), IRTOP(*)
      INTEGER IRBDIF(*)
      INTEGER NPBROW(*), NPBCOL(*), NPTROW(*), NPTCOL(*)

      LOGICAL PROBLM

      PROBLM = .FALSE.

C   --Find out the corresponding rows and columns for each node

      CALL INIINT (NUMNP, 0, NPBROW)
      CALL INIINT (NUMNP, 0, NPTROW)

      DO 20 IROW = 1, NEROW
         DO 10 ICOL = 1, NUMCOL
            IEL = IELCEN(ICOL,IROW)
            IF (IEL .LE. 0) GOTO 10
            INP = LINK(IX1,IEL)
            NPTROW(INP) = IROW
            NPTCOL(INP) = ICOL
            INP = LINK(IX4,IEL)
            NPBROW(INP) = IROW
            NPBCOL(INP) = ICOL
   10    CONTINUE
   20 CONTINUE

C   --Find the row on top and on bottom of each row and check column differences

      CALL INIINT (NEROW, 0, IRBOT)
      CALL INIINT (NEROW, 0, IRTOP)
      CALL INIINT (NEROW, 0, IRBDIF)

      DO 40 IROW = 1, NEROW
         DO 30 ICOL = 1, NUMCOL
            IEL = IELCEN(ICOL,IROW)
            IF (IEL .LE. 0) GOTO 30
            INP = LINK(IX1,IEL)

            ITROW = NPTROW(INP)

            IF (NPBROW(INP) .NE. 0) THEN
C            --Mark the bottom row and point back to this row
               IBROW = NPBROW(INP)
               IRBOT(ITROW) = IBROW
               IRTOP(IBROW) = ITROW
C            --Mark column differences
               IRBDIF(ITROW) = NPTCOL(INP) - NPBCOL(INP)
               GOTO 40
            END IF
   30    CONTINUE
   40 CONTINUE

C   --Check columns of bottom and top row

      DO 60 IROW = 1, NEROW

         DO 50 ICOL = 1, NUMCOL
            IEL = IELCEN(ICOL,IROW)
            IF (IEL .LE. 0) GOTO 50
            IB = LINK(IX1,IEL)
            IT = LINK(IX4,IEL)

C         --Check that node is not connected to two top or bottom rows
            IF (NPTROW(IB) .NE. IROW) PROBLM = .TRUE.
            IF (NPBROW(IT) .NE. IROW) PROBLM = .TRUE.

            IF (NPBROW(IB) .NE. 0) THEN
C            --Check that same bottom row this node
               IF (NPBROW(IB) .NE. IRBOT(IROW)) PROBLM = .TRUE.
C            --Check column difference
               IF ((NPTCOL(IB) - NPBCOL(IB)) .NE. IRBDIF(IROW))
     &            PROBLM = .TRUE.
            ELSE IF (NPTROW(IT) .NE. 0) THEN
C            --Check that same top row this node
               IF (NPTROW(IT) .NE. IRTOP(IROW)) PROBLM = .TRUE.
C            --Check column difference
               ITROW = NPTROW(IT)
               IF ((NPTCOL(IT) - NPBCOL(IT)) .NE. IRBDIF(ITROW))
     &            PROBLM = .TRUE.
            END IF

   50    CONTINUE
   60 CONTINUE

C   --Get the column numbers of non-center rows by following a chain of rows
C   --through the top rows

      DO 90 IROW = 1, NEROW
C      --Start at a center row
         IF (ICOL1(IROW) .NE. 1) GOTO 90

         NROW = IROW
   70    CONTINUE
C      --Check the row if it has top-bottom row pairing
         IF (IRBOT(NROW) .GT. 0) THEN
            IBROW = IRBOT(NROW)

C         --Calculate the column from the paired row column and offset
            ICOL = ICOL1(NROW) + IRBDIF(NROW)

            IF ((ICOL1(IBROW) .GT. 1) .OR. (ICOL .LE. 0)) THEN
C            --If the paired row is already marked, stop chain
               IF (ICOL .LE. 0) PROBLM = .TRUE.
               IF (ICOL1(IBROW) .NE. ICOL) PROBLM = .TRUE.
               ICOL = 1
            END IF

            IF ((ICOL .GT. 1) .AND. (ICOL .LE. NUMCOL)) THEN
C            --Chain to the paired row
               ICOL1(IBROW) = ICOL
               NROW = IBROW

               GOTO 70
            END IF
         END IF

         NROW = IROW
   80    CONTINUE
C      --Check the row if it has top-bottom row pairing
         IF (IRTOP(NROW) .GT. 0) THEN
            ITROW = IRTOP(NROW)

C         --Calculate the column from the paired row column and offset
            ICOL = ICOL1(NROW) - IRBDIF(ITROW)

            IF ((ICOL1(ITROW) .GE. 1) .OR. (ICOL .LE. 0)) THEN
C            --If the paired row is already marked, stop chain
               IF (ICOL .LE. 0) PROBLM = .TRUE.
               IF (ICOL1(ITROW) .NE. ICOL) PROBLM = .TRUE.
               ICOL = 1
            END IF

            IF ((ICOL .GT. 1) .AND. (ICOL .LE. NUMCOL)) THEN
C            --Chain to the paired row
               ICOL1(ITROW) = ICOL
               NROW = ITROW

               GOTO 80
            END IF
         END IF
   90 CONTINUE

C   --Shift rows over if not on first column

      NROW = NEROW
      NEROW = 0
      DO 120 IROW = 1, NROW
C      --Eliminate row if its first column is too big
         IF ((ICOL1(IROW) .LT. 1) .OR. (ICOL1(IROW) .GT. NUMCOL)) THEN
            ICOL1(IROW) = 0

         ELSE
            NEROW = NEROW + 1

            IC = NUMCOL - ICOL1(IROW) + 1
            DO 100 ICOL = NUMCOL, ICOL1(IROW), -1
               IELCEN(ICOL,NEROW) = IELCEN(IC,IROW)
               IC = IC - 1
  100       CONTINUE
            DO 110 ICOL = 1, ICOL1(IROW)-1
               IELCEN(ICOL,NEROW) = 0
  110       CONTINUE

            ICOL1(IROW) = NEROW
         END IF
  120 CONTINUE

C   --Connect the row top/bottom pointers to the renumbered rows

      DO 130 IROW = 1, NEROW
         IR = IRTOP(IROW)
         IF (IR .GT. 0) IRTOP(IROW) = ICOL1(IR)
         IR = IRBOT(IROW)
         IF (IR .GT. 0) IRBOT(IROW) = ICOL1(IR)
  130 CONTINUE

      RETURN
      END
