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 MESSAGE('** 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 MESSAGE('** 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 MESSAGE('** 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 MESSAGE('** 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