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 PCROSS (MXND, MXCORN, MLN, MXLOOP, MAXPRM, NUID,
     &   XN, YN, ZN, LXK, KXL, NXL, LXN, ANGLE, LNODES, BNSIZE, LINKPR,
     &   KPERIM, NODE, NODE1, NODE2, KKKOLD, LLLOLD, NNNOLD, IAVAIL,
     &   NAVAIL, DONE, XMIN, XMAX, YMIN, YMAX, ZMIN, ZMAX, DEV1, LLL,
     &   KKK, NNN, LCORN, NCORN, NLOOP, NEXTN1, KLOOP, GRAPH, VIDEO,
     &   KREG, NOROOM, ERR)
C***********************************************************************

C  SUBROUTINE PCROSS = CHECKS TO SEE IF ANY PERIMETERS CROSS AND HOOKS
C                      THEM TOGETHER IF THEY DO

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

      COMMON /TIMING/ TIMEA, TIMEP, TIMEC, TIMEPC, TIMEAJ, TIMES

      DIMENSION XN (MXND), YN (MXND), ZN (MXND), NUID (MXND)
      DIMENSION LXK (4, MXND), KXL (2, 3*MXND)
      DIMENSION NXL (2, 3*MXND), LXN (4, MXND)
      DIMENSION ANGLE (MXND), LNODES (MLN, MXND), BNSIZE (2, MXND)
      DIMENSION LCORN (MXCORN)
      DIMENSION NLOOP (MXLOOP), NEXTN1 (MXLOOP), LINKPR (3, MAXPRM)

      CHARACTER*3 DEV1

      LOGICAL DONE,  ERR, NOROOM, DONE1
      LOGICAL GRAPH, BOK, LCROSS, LMATCH
      LOGICAL VIDEO, PMATCH

C  FIND THE FIRST OVERLAPPING LINE STARTING AT THE CURRENT NODE

      CALL GETIME (TIME1)
      ERR = .FALSE.
      PMATCH = .TRUE.

  100 CONTINUE
      if (node1 .eq. 0) return
      N1 = NODE1
      KOUNT = 0

  110 CONTINUE
      N0 = LNODES (2, N1)
      N2 = LNODES (3, N1)
      N3 = LNODES (3, N2)
      KOUNT = KOUNT + 1

C  CHECK FOR COMPLETION

      IF ((N1 .EQ. NODE2) .AND. (KOUNT .GT. 1)) THEN
         GOTO 140
      ELSEIF (KOUNT .GT. NLOOP (1) + 1) THEN
         CALL MESAGE ('** PROBLEMS WITH LOOP CLOSING IN PCROSS **')
         ERR = .TRUE.
         GOTO 140
      ENDIF

C  LOOP THROUGH ALL THE REMAINING PERIMETERS CHECKING FOR CROSSINGS

      IPERIM = LINKPR (2, KPERIM)
  120 CONTINUE

      IF (IPERIM .EQ. KPERIM) THEN
         N1 = N2
         GOTO 110
      ENDIF

      KOUNT2 = 0
      N1TEST = LINKPR (1, IPERIM)

  130 CONTINUE
      N0TEST = LNODES (2, N1TEST)
      N2TEST = LNODES (3, N1TEST)
      N3TEST = LNODES (3, N2TEST)

      CALL INTSCT (XN(N1), YN(N1), XN(N2), YN(N2), XN(N1TEST),
     &   YN(N1TEST), XN(N2TEST), YN(N2TEST), U, W, LCROSS)
      IF (.NOT. LCROSS) THEN
         N1TEST = N2TEST
         KOUNT2 = KOUNT2 + 1
         IF (N1TEST .EQ. LINKPR (1, IPERIM)) THEN
            IPERIM = LINKPR (2, IPERIM)
            GOTO 120
         ELSEIF (KOUNT2 .GT. LINKPR (3, IPERIM)) THEN
            CALL MESAGE ('** PROBLEMS IN PCROSS WITH UNCLOSED '//
     &         'PERIMETER **')
            ERR = .TRUE.
            GOTO 140
         ENDIF
         GOTO 130
      ENDIF

C  AN INTERSECTION HAS OCCURRED.
C  GET THE BEST SEAM FROM THIS INTERSECTION

      IF ((GRAPH) .OR. (VIDEO)) THEN
         CALL RPLOTL (MXND, XN, YN, ZN, NXL, XMIN, XMAX,
     &      YMIN, YMAX, ZMIN, ZMAX, LLL, DEV1, KREG)
         IF (VIDEO) CALL SNAPIT (2)
         IF (GRAPH) THEN
            CALL LCOLOR ('YELOW')
            CALL D2NODE (MXND, XN, YN, N1, N2)
            CALL D2NODE (MXND, XN, YN, N1TEST, N2TEST)
            CALL LCOLOR ('WHITE')
            CALL SFLUSH
         ENDIF
      ENDIF
      CALL MATCH2 (MXND, MLN, XN, YN, NXL, LXN, LNODES, ANGLE, N0, N1,
     &   N2, N3, N0TEST, N1TEST, N2TEST, N3TEST, I1, I2, J1, J2,
     &   KOUNTL, LMATCH, LINKPR (3, IPERIM), NODE, U, W, NLOOP (1),
     &   PMATCH, ERR)
      IF (ERR) GOTO 140
      IF (GRAPH) THEN
         CALL LCOLOR ('PINK ')
         CALL D2NODE (MXND, XN, YN, I1, I2)
         CALL D2NODE (MXND, XN, YN, J1, J2)
         CALL LCOLOR ('WHITE')
         CALL SFLUSH
      ENDIF
      IF (.NOT. LMATCH) THEN
         IF (N1TEST .EQ. LINKPR (1, IPERIM)) THEN
            IPERIM = LINKPR (2, IPERIM)
            GOTO 120
         ELSEIF (KOUNT2 .GT. LINKPR (3, IPERIM)) THEN
            CALL MESAGE ('** PROBLEMS IN PCROSS WITH UNCLOSED '//
     &         'PERIMETER **')
            ERR = .TRUE.
            GOTO 140
         ENDIF
         GOTO 130
      ENDIF

C  NOW CHECK TO SEE IF THE ATTACHMENT WOULD CAUSE
C  LINES ON THE BOUNDARY TO CROSS

      CALL BCROSS (MXND, MLN, XN, YN, ZN, LXK, KXL, NXL, LXN, LNODES,
     &   I1, I2, J1, J2, NLOOP(1), BOK, LLL, XMIN, XMAX, YMIN, YMAX,
     &   ZMIN, ZMAX, DEV1, KREG, ERR)
      IF (ERR) GOTO 140
      IF (.NOT. BOK) THEN
         N1TEST = N2TEST
         KOUNT2 = KOUNT2 + 1
         IF (N1TEST .EQ. LINKPR (1, IPERIM)) THEN
            IPERIM = LINKPR (2, IPERIM)
            GOTO 120
         ELSEIF (KOUNT2 .GT. LINKPR (3, IPERIM)) THEN
            CALL MESAGE ('** PROBLEMS IN PCROSS WITH UNCLOSED '//
     &         'PERIMETER **')
            ERR = .TRUE.
            GOTO 140
         ENDIF
         GOTO 130
      ENDIF

C  NOW THAT THE APPROPRIATE COLLAPSE HAS BEEN FOUND, THE TWO LINES
C  MUST BE JOINED AND THE PERIMETER LINKS RESTABLISHED

      CALL SEW2 (MXND, MLN, NUID, LXK, KXL, NXL, LXN, LNODES,
     &   IAVAIL, NAVAIL, LLL, KKK, NNN, I1, I2, J1, J2, NOROOM, ERR)
      IF ((NOROOM) .OR. (ERR)) GOTO 140

C  UPDATE THE CURRENT NODE

      IF (J1 .EQ. NODE) THEN
         NDUM = NODE
         NODE = I2
         IF (NODE1 .EQ. NDUM) NODE1 = I2
         IF (NODE2 .EQ. NDUM) NODE2 = I2
      ELSEIF (J2 .EQ. NODE) THEN
         NDUM = NODE
         NODE = I1
         IF (NODE1 .EQ. NDUM) NODE1 = I1
         IF (NODE2 .EQ. NDUM) NODE2 = I1
      ENDIF

      NLOOP (1) = NLOOP (1) + LINKPR (3, IPERIM) - 2
      LINKPR (3, KPERIM) = NLOOP (1)
      JPERIM = LINKPR (2, IPERIM)
      IF (JPERIM .EQ. KPERIM) KPERIM = IPERIM
      LINKPR (1, IPERIM) = LINKPR (1, JPERIM)
      LINKPR (2, IPERIM) = LINKPR (2, JPERIM)
      LINKPR (3, IPERIM) = LINKPR (3, JPERIM)
      IF (LINKPR (2, KPERIM) .EQ. KPERIM) LINKPR (2, KPERIM) = 0

C  NOW SMOOTH AND PLOT THE CURRENT MESH

      NNN2 = 1
      CALL GETIME (TIME2)
      TIMEPC = TIMEPC + TIME2 - TIME1
      CALL FILSMO  (MXND, MLN, XN, YN, ZN, LXK, KXL, NXL, LXN, LLL, NNN,
     &   NNN2, LNODES, BNSIZE, NLOOP (1), XMIN, XMAX, YMIN, YMAX, ZMIN,
     &   ZMAX, DEV1, KREG)
      CALL GETIME (TIME1)
      IF ((GRAPH) .OR. (VIDEO)) THEN
         CALL RPLOTL (MXND, XN, YN, ZN, NXL, XMIN, XMAX,
     &      YMIN, YMAX, ZMIN, ZMAX, LLL, DEV1, KREG)
         IF (VIDEO) CALL SNAPIT (2)
         IF (GRAPH) THEN
            CALL LCOLOR ('YELOW')
            CALL D2NODE (MXND, XN, YN, I1, I2)
            CALL LCOLOR ('WHITE')
            CALL SFLUSH
         ENDIF
      ENDIF

C  NOW TRY TO PINCH THE CONNECTION

      CALL LUPANG (MXND, MLN, XN, YN, ZN, LXK, KXL, NXL, LXN, NLOOP (1),
     &   ANGLE, LNODES, I2, LLL, XMIN, XMAX, YMIN, YMAX, ZMIN, ZMAX,
     &   DEV1, KREG, ERR)
      IF (ERR) GOTO 140

      CALL GETIME (TIME2)
      TIMEPC = TIMEPC + TIME2 - TIME1
      CALL PINCH (MXND, MXCORN, MLN, NUID, XN, YN, ZN, LXK, KXL, NXL,
     &   LXN, ANGLE, LNODES, BNSIZE, NODE, NLOOP (1), KKKOLD, LLLOLD,
     &   NNNOLD, IAVAIL, NAVAIL, DONE1, XMIN, XMAX, YMIN, YMAX, ZMIN,
     &   ZMAX, DEV1, LLL, KKK, NNN, LCORN, NCORN, NODE1, NODE2, GRAPH,
     &   VIDEO, KREG, NOROOM, ERR)
      IF ((NOROOM) .OR. (ERR)) GOTO 140
      IF (LINKPR(2, KPERIM) .NE. 0) GO TO 100
      CALL GETIME (TIME1)

  140 CONTINUE
      CALL GETIME (TIME2)
      TIMEPC = TIMEPC + TIME2 - TIME1
      RETURN

      END
