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 GETSBC (MXND, MXNPER, NPER, NL, ML, MAXSBC, MAXPRM,
     &   NPRM, NID, LISTL, XN, YN, NUID, LXK, KXL, NXL, LSTSBC, NPERIM,
     &   KSBC, LCON, ISBOUN, LINKL, NSPF, IFSB, LISTSB, LINKSB, LLL,
     &   BAR, ERR)
C***********************************************************************

C  SUBROUTINE GETSBC = GETS THE SIDE BOUNDARY LIST

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

      DIMENSION NID (MXNPER, MAXPRM), NPERIM (MAXPRM)
      DIMENSION LISTL (NL), XN (MXND), YN (MXND), NUID (MXND)
      DIMENSION LXK (4, MXND), KXL (2, MXND*3), NXL (2, MXND*3)
      DIMENSION LCON (3, ML), ISBOUN (ML), LINKL (2, ML)
      DIMENSION NSPF (ML), IFSB (ML), LISTSB (2, ML), LINKSB (2, ML)
      DIMENSION LSTSBC (MAXSBC), NODES (4)

      LOGICAL EXTER, ERR, CCW, BAR, ADDLNK

      ERR = .TRUE.
      CCW = .TRUE.
      ADDLNK = .FALSE.
      NPERIM (1) = NPER

      DO 110 II = 1, NPRM
         DO 100 I = 1, NPERIM(II)
            IF (BAR) THEN
               NID (I, II) = IABS (NUID (I))
            ELSE
               IF (NID (I, II) .LT. 0) NID (I, II) = - NID (I, II)
            ENDIF
  100    CONTINUE
  110 CONTINUE

C  SORT THROUGH AND PICK OFF ELEMENTS WITH SIDE BOUNDARY CONDITIONS

      DO 240 I = 1, LLL
         IF (BAR) THEN
            I1 = LXK (1, I)
            I2 = LXK (2, I)
         ELSE
            I1 = NXL (1, I)
            I2 = NXL (2, I)
         ENDIF

C  SEE IF THE LINE IS CLEARLY INTERIOR

         IF (I1 .GT. 0 .AND. I2 .GT. 0) THEN
           if ((NUID (I1) .NE. 0) .AND. (NUID (I2) .NE. 0)) THEN
            LTEST = 0
            EXTER = .FALSE.

C  CHECK AGAINST THE PERIMETER LIST TO SEE IF IT IS TRULY EXTERIOR

            DO 130 JJ  =  1, NPRM
               DO 120 J = 1, NPERIM (JJ)
                  IF (ABS (NUID (I1)) .EQ. NID (J, JJ)) THEN
                     IF (J .EQ. 1) THEN
                        J1 = J + 1
                        J2 = NPERIM(JJ)
                     ELSEIF (J .EQ. NPERIM(JJ)) THEN
                        J1 = J - 1
                        J2 = 1
                     ELSE
                        J1 = J - 1
                        J2 = J + 1
                     ENDIF
                     IF ( (ABS (NUID (I2)) .EQ. NID (J1, JJ)) .OR.
     &                  (ABS (NUID (I2)) .EQ. NID (J2, JJ)) )
     &                  EXTER = .TRUE.
                     GOTO 140
                  ENDIF
  120          CONTINUE
  130       CONTINUE
  140       CONTINUE
            IF (EXTER) THEN

C  FIND THE LINE NUMBER IT BELONGS TO

               IF (ABS (NUID (I1)) .GT. 1000000000) THEN
                  LTEST =  (ABS (NUID (I1)) - 1000000000) / 100000
               ELSEIF (ABS (NUID (I2)) .GT. 1000000000) THEN
                  LTEST =  (ABS (NUID (I2)) - 1000000000) / 100000
               ELSE
                  NSUM = ABS (NUID (I1)) + ABS (NUID (I2))
                  DO 150 J = 1, NL
                     CALL LTSORT (ML, LINKL, LISTL (J), K, ADDLNK)
                     IF ((LCON (1, K) + LCON (2, K)) .EQ. NSUM) THEN
                        IF (( (LCON (1, K) .EQ. ABS (NUID (I1))) .AND.
     +                     (LCON (2, K) .EQ. ABS (NUID (I2)))) .OR.
     +                     ((LCON (1, K) .EQ. ABS (NUID (I2))) .AND.
     +                     (LCON (2, K) .EQ. ABS (NUID (I1))))) THEN
                           LTEST = LISTL (J)
                           GOTO 160
                        ENDIF
                     ENDIF
  150             CONTINUE
  160             CONTINUE
               ENDIF

C  FIND THE ELEMENT BOUNDARY FLAG IF THERE IS ONE

               IF (LTEST.LE.0) THEN
                  CALL MESSAGE(' ERROR IN SEARCHING NXL FOR '//
     &               'ELEMENT BCC')
                  RETURN
               ELSE
                  CALL LTSORT (ML, LINKL, LTEST, J, ADDLNK)
                  IF (ISBOUN (J) .GT. 0) THEN
                     IFLAG = ISBOUN (J)

C  CHECK TO MAKE SURE LINE IS LINKED TO FLAG
C  AND GET THE NEXT LINK  (NFLAG)

                     CALL LTSORT (ML, LINKSB, IFLAG, L, ADDLNK)
                     DO 170 JJ = IFSB (L), IFSB (L) + NSPF (L) - 1
                        IF (LISTSB (1, JJ) .LT. 0) THEN
                           CALL MESSAGE('PROBLEMS WITH SIDES IN '//
     &                        'FLAG LIST IN GETSBC')
                        ELSE
                           IF (LISTSB (1, JJ) .EQ. LTEST) THEN
                              NFLAG = LISTSB (2, JJ)
                              GOTO 180
                           ENDIF
                        ENDIF
  170                CONTINUE
                     WRITE (*, 10000)IFLAG
                     RETURN
  180                CONTINUE
                     IF (BAR) THEN
                        NELEM = I
                     ELSE
                        NELEM = KXL (1, I)
                        IF (NELEM .EQ. 0)NELEM = KXL (2, I)
                     ENDIF
                     KSBC = KSBC + 1
                     LSTSBC (KSBC) = - IFLAG
                     KSBC = KSBC + 1
                     if (ksbc .gt. maxsbc) stop 'maxsbc error'
                     LSTSBC (KSBC) = NELEM

C  GET THE CORRECT ELEMENT SIDE

                     IF (BAR) THEN
                        JSIDE = 1
                     ELSE
                        CALL GNXKA (MXND, XN, YN, NELEM, NODES, AREA,
     &                     LXK, NXL, CCW)
                        DO 190 J = 1, 4
                           IF (I1 .EQ. NODES (J)) THEN
                              JP1 = J + 1
                              JM1 = J - 1
                              IF (JP1 .EQ. 5)JP1 = 1
                              IF (JM1 .EQ. 0)JM1 = 4
                              IF (I2 .EQ. NODES (JP1)) THEN
                                 JSIDE = J
                                 GOTO 200
                              ELSEIF (I2 .EQ. NODES (JM1)) THEN
                                 JSIDE = JM1
                                 GOTO 200
                              ENDIF
                           ENDIF
  190                   CONTINUE
                        WRITE (*, 10010)NELEM
                        RETURN
  200                   CONTINUE
                     ENDIF
                     KSBC = KSBC + 1
                     LSTSBC (KSBC) = JSIDE

C  SEE IF ANY MORE FLAGS ARE ATTACHED TO THIS SIDE

  210                CONTINUE
                     IF (NFLAG .GT. 0) THEN

C  CHECK TO MAKE SURE LINE IS LINKED TO FLAG
C  AND GET THE NEXT LINK  (NFLAG)

                        IFLAG = NFLAG
                        CALL LTSORT (ML, LINKSB, IFLAG, L, ADDLNK)
                        DO 220 JJ = IFSB (L), IFSB (L) + NSPF (L)
                           IF (LISTSB (1, JJ) .EQ. LTEST) THEN
                              NFLAG = LISTSB (2, JJ)
                              GOTO 230
                           ENDIF
  220                   CONTINUE
                        WRITE (*, 10000)IFLAG
                        RETURN
  230                   CONTINUE
                        KSBC = KSBC + 1
                        LSTSBC (KSBC) = - IFLAG
                        KSBC = KSBC + 1
                        LSTSBC (KSBC) = NELEM
                        KSBC = KSBC + 1
                        LSTSBC (KSBC) = JSIDE
                        GOTO 210
                     ENDIF
                  ENDIF
               ENDIF
            ENDIF
         ENDIF
       END IF
  240 CONTINUE

      ERR = .FALSE.
      RETURN

10000 FORMAT (' SIDE BOUNDARY FLAG', I5, ' IS NOT PROPERLY LINKED')
10010 FORMAT (' ERROR FINDING CORRECT BOUNDARY SIDE ON ELEMENT', I5)
      END
