You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
234 lines
7.4 KiB
234 lines
7.4 KiB
2 years ago
|
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
|