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.
377 lines
10 KiB
377 lines
10 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 TUCK (MXND, MLN, NUID, XN, YN, LXK, KXL, NXL, LXN,
|
||
|
|
& LNODES, IAVAIL, NAVAIL, LLL, KKK, NNN, N1, NLOOP, GRAPH,
|
||
|
|
& NOROOM, ERR)
|
||
|
|
C***********************************************************************
|
||
|
|
|
||
|
|
C SUBROUTINE TUCK = COLLAPSES TWO SIDE LINES INTO A ROW END NODE.
|
||
|
|
C THIS IS REFERRED TO AS A TUCK.
|
||
|
|
|
||
|
|
C***********************************************************************
|
||
|
|
|
||
|
|
DIMENSION XN (MXND), YN (MXND), NUID (MXND)
|
||
|
|
DIMENSION LXK (4, MXND), KXL (2, 3*MXND)
|
||
|
|
DIMENSION NXL (2, 3*MXND), LXN (4, MXND)
|
||
|
|
DIMENSION LNODES (MLN, MXND)
|
||
|
|
DIMENSION L1LIST(20)
|
||
|
|
|
||
|
|
LOGICAL GRAPH, ERR, NOROOM
|
||
|
|
|
||
|
|
ERR = .FALSE.
|
||
|
|
|
||
|
|
C CHECK TO MAKE SURE THAT THE NODE STILL EXISTS
|
||
|
|
|
||
|
|
IF (LXN (1, N1) .LE. 0) THEN
|
||
|
|
ERR = .TRUE.
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK - N1 DOES NOT EXIST **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
C GET ALL THE DEFINITIONS IN ORDER
|
||
|
|
|
||
|
|
N0 = LNODES (2, N1)
|
||
|
|
N2 = LNODES (3, N1)
|
||
|
|
L1 = LNODES (5, N0)
|
||
|
|
L2 = LNODES (5, N1)
|
||
|
|
KOLD = KXL (1, L1)
|
||
|
|
KL2 = KXL (1, L2)
|
||
|
|
|
||
|
|
C FIND L5 AND NC2
|
||
|
|
|
||
|
|
DO 100 I = 1, 4
|
||
|
|
LTEST = LXK (I, KOLD)
|
||
|
|
IF (LTEST .NE. L1) THEN
|
||
|
|
IF (NXL (1, LTEST) .EQ. N1) THEN
|
||
|
|
L5 = LTEST
|
||
|
|
NC2 = NXL (2, LTEST)
|
||
|
|
GOTO 110
|
||
|
|
ELSEIF (NXL (2, LTEST) .EQ. N1) THEN
|
||
|
|
L5 = LTEST
|
||
|
|
NC2 = NXL (1, LTEST)
|
||
|
|
GOTO 110
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
100 CONTINUE
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK FINDING L5 AND NC2 **')
|
||
|
|
ERR = .TRUE.
|
||
|
|
GOTO 290
|
||
|
|
110 CONTINUE
|
||
|
|
|
||
|
|
C FIND L4 AND NC1
|
||
|
|
|
||
|
|
DO 120 I = 1, 4
|
||
|
|
LTEST = LXK (I, KOLD)
|
||
|
|
IF ( (LTEST .NE. L1) .AND. (LTEST .NE. L5) ) THEN
|
||
|
|
IF (NXL (1, LTEST) .EQ. N0) THEN
|
||
|
|
L4 = LTEST
|
||
|
|
NC1 = NXL (2, LTEST)
|
||
|
|
GOTO 130
|
||
|
|
ELSEIF (NXL (2, LTEST) .EQ. N0) THEN
|
||
|
|
L4 = LTEST
|
||
|
|
NC1 = NXL (1, LTEST)
|
||
|
|
GOTO 130
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
120 CONTINUE
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK FINDING L4 AND NC1 **')
|
||
|
|
ERR = .TRUE.
|
||
|
|
GOTO 290
|
||
|
|
130 CONTINUE
|
||
|
|
|
||
|
|
C FIND L3
|
||
|
|
|
||
|
|
DO 140 I = 1, 4
|
||
|
|
LTEST = LXK (I, KOLD)
|
||
|
|
IF ( (LTEST .NE. L1) .AND. (LTEST .NE. L5) .AND.
|
||
|
|
& (LTEST .NE. L4) ) THEN
|
||
|
|
L3 = LTEST
|
||
|
|
GOTO 150
|
||
|
|
ENDIF
|
||
|
|
140 CONTINUE
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK FINDING L3 **')
|
||
|
|
ERR = .TRUE.
|
||
|
|
GOTO 290
|
||
|
|
150 CONTINUE
|
||
|
|
|
||
|
|
C FIND THE ELEMENT KL5
|
||
|
|
|
||
|
|
IF (KXL (1, L5) .EQ. KOLD) THEN
|
||
|
|
KL5 = KXL (2, L5)
|
||
|
|
ELSEIF (KXL (2, L5) .EQ. KOLD) THEN
|
||
|
|
KL5 = KXL (1, L5)
|
||
|
|
ELSE
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK FINDING KL5 **')
|
||
|
|
ERR = .TRUE.
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
C NOW THAT ALL THE NECESSARY VARIABLES HAVE BEEN DEFINED,
|
||
|
|
C START BY DELETING LINE L1, L2, AND L5
|
||
|
|
|
||
|
|
KXL (1, L1) = 0
|
||
|
|
KXL (2, L1) = 0
|
||
|
|
NXL (1, L1) = 0
|
||
|
|
NXL (2, L1) = 0
|
||
|
|
KXL (1, L2) = 0
|
||
|
|
KXL (2, L2) = 0
|
||
|
|
NXL (1, L2) = 0
|
||
|
|
NXL (2, L2) = 0
|
||
|
|
KXL (1, L5) = 0
|
||
|
|
KXL (2, L5) = 0
|
||
|
|
NXL (1, L5) = 0
|
||
|
|
NXL (2, L5) = 0
|
||
|
|
|
||
|
|
C NOW FIX THE KXL ARRAY FOR LINE L3 HAVING KL5 INSTEAD OF KOLD
|
||
|
|
|
||
|
|
IF (KXL (1, L3) .EQ. KOLD) THEN
|
||
|
|
KXL (1, L3) = KL5
|
||
|
|
ELSEIF (KXL (2, L3) .EQ. KOLD) THEN
|
||
|
|
KXL (2, L3) = KL5
|
||
|
|
ELSE
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK REPLACING KOLD FOR L3 **')
|
||
|
|
ERR = .TRUE.
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
C NOW FIX THE KXL ARRAY FOR LINE L3 HAVING KL5 INSTEAD OF KOLD
|
||
|
|
|
||
|
|
IF (KXL (1, L4) .EQ. KOLD) THEN
|
||
|
|
KXL (1, L4) = KL2
|
||
|
|
ELSEIF (KXL (2, L4) .EQ. KOLD) THEN
|
||
|
|
KXL (2, L4) = KL2
|
||
|
|
ELSE
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK REPLACING KOLD FOR L4 **')
|
||
|
|
ERR = .TRUE.
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
C FIX THE LINES PER ELEMENT ARRAY FOR ELEMENT KL5 TO REFLECT
|
||
|
|
C L3 TAKING L5'S PLACE
|
||
|
|
|
||
|
|
DO 160 I = 1, 4
|
||
|
|
IF (LXK (I, KL5) .EQ. L5) THEN
|
||
|
|
LXK (I, KL5) = L3
|
||
|
|
GOTO 170
|
||
|
|
ENDIF
|
||
|
|
160 CONTINUE
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK FINDING L5 IN KL5 **')
|
||
|
|
ERR = .TRUE.
|
||
|
|
GOTO 290
|
||
|
|
170 CONTINUE
|
||
|
|
|
||
|
|
C FIX THE LINES PER ELEMENT ARRAY FOR ELEMENT KL2 TO REFLECT
|
||
|
|
C L4 TAKING L2'S PLACE
|
||
|
|
|
||
|
|
DO 180 I = 1, 4
|
||
|
|
IF (LXK (I, KL2) .EQ. L2) THEN
|
||
|
|
LXK (I, KL2) = L4
|
||
|
|
GOTO 190
|
||
|
|
ENDIF
|
||
|
|
180 CONTINUE
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK FINDING L2 IN KL2 **')
|
||
|
|
ERR = .TRUE.
|
||
|
|
GOTO 290
|
||
|
|
190 CONTINUE
|
||
|
|
|
||
|
|
C RECONNECT ALL LINES CONNECTED TO N1 TO NC1 EXCEPT L5 AND L2
|
||
|
|
|
||
|
|
CALL GETLXN (MXND, LXN, N1, L1LIST, NL, ERR)
|
||
|
|
IF (ERR) THEN
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK GETTING N1 LINES **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
IF (GRAPH) CALL LCOLOR ('BLACK')
|
||
|
|
DO 200 I = 1, NL
|
||
|
|
LL = L1LIST (I)
|
||
|
|
IF ((GRAPH) .AND. (NXL (1, LL) .GT. 0) .AND.
|
||
|
|
& (NXL (2, LL) .GT. 0) )
|
||
|
|
& CALL D2NODE (MXND, XN, YN, NXL (1, LL), NXL (2, LL))
|
||
|
|
IF (NXL (1, LL) .EQ. N1) THEN
|
||
|
|
NXL (1, LL) = NC1
|
||
|
|
ELSEIF (NXL (2, LL) .EQ. N1) THEN
|
||
|
|
NXL (2, LL) = NC1
|
||
|
|
ENDIF
|
||
|
|
200 CONTINUE
|
||
|
|
IF (GRAPH) THEN
|
||
|
|
CALL LCOLOR ('WHITE')
|
||
|
|
CALL SFLUSH
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
C FIX LXN ARRAY
|
||
|
|
C UNHOOK L1, L2 AND L5 FROM N1
|
||
|
|
|
||
|
|
CALL DELLXN (MXND, LXN, NUID, NAVAIL, IAVAIL, N1,
|
||
|
|
& L1, NNN, ERR, NOROOM)
|
||
|
|
IF ((NOROOM) .OR. (ERR)) THEN
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK UNHOOKING L1 FROM N1 **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
CALL DELLXN (MXND, LXN, NUID, NAVAIL, IAVAIL, N1,
|
||
|
|
& L2, NNN, ERR, NOROOM)
|
||
|
|
IF ((NOROOM) .OR. (ERR)) THEN
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK UNHOOKING L2 FROM N1 **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
CALL DELLXN (MXND, LXN, NUID, NAVAIL, IAVAIL, N1,
|
||
|
|
& L5, NNN, ERR, NOROOM)
|
||
|
|
IF ((NOROOM) .OR. (ERR)) THEN
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK UNHOOKING L5 FROM N1 **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
C ADD ALL LINES STILL HOOKED TO N1 TO THE LIST OF LINES FOR NC1
|
||
|
|
|
||
|
|
DO 210 I = 1, NL
|
||
|
|
LL = L1LIST (I)
|
||
|
|
IF ((LL .NE. L2) .AND. (LL .NE. L5) .AND. (LL .NE. L1)) THEN
|
||
|
|
CALL ADDLXN (MXND, LXN, NUID, NAVAIL, IAVAIL,
|
||
|
|
& NC1, LL, NNN, ERR, NOROOM)
|
||
|
|
IF ((NOROOM) .OR. (ERR)) THEN
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK HOOKING N1'' LINES'//
|
||
|
|
& ' TO NC1 **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
210 CONTINUE
|
||
|
|
|
||
|
|
C DELETE N1
|
||
|
|
|
||
|
|
DO 220 I = 1, 3
|
||
|
|
LXN (I, N1) = 0
|
||
|
|
220 CONTINUE
|
||
|
|
LXN (4, N1) = IAVAIL
|
||
|
|
IAVAIL = N1
|
||
|
|
NAVAIL = NAVAIL+1
|
||
|
|
NUID (N1) = 0
|
||
|
|
|
||
|
|
C RECONNECT ALL LINES CONNECTED TO N2 TO N0 (EXCEPT L2)
|
||
|
|
|
||
|
|
CALL GETLXN (MXND, LXN, N2, L1LIST, NL, ERR)
|
||
|
|
IF (ERR) THEN
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK GETTING N2 LINES **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
IF (GRAPH) CALL LCOLOR ('BLACK')
|
||
|
|
DO 230 I = 1, NL
|
||
|
|
LL = L1LIST (I)
|
||
|
|
IF ((GRAPH) .AND. (NXL (1, LL) .GT. 0) .AND.
|
||
|
|
& (NXL (2, LL) .GT. 0) )
|
||
|
|
& CALL D2NODE (MXND, XN, YN, NXL (1, LL), NXL (2, LL))
|
||
|
|
IF (NXL (1, LL) .EQ. N2) THEN
|
||
|
|
NXL (1, LL) = N0
|
||
|
|
ELSEIF (NXL (2, LL) .EQ. N2) THEN
|
||
|
|
NXL (2, LL) = N0
|
||
|
|
ENDIF
|
||
|
|
230 CONTINUE
|
||
|
|
IF (GRAPH) THEN
|
||
|
|
CALL LCOLOR ('WHITE')
|
||
|
|
CALL SFLUSH
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
C FIX LXN ARRAY
|
||
|
|
C UNHOOK L2 FROM N2, L1 FROM N0, AND L5 FROM NC2
|
||
|
|
|
||
|
|
CALL DELLXN (MXND, LXN, NUID, NAVAIL, IAVAIL, N2,
|
||
|
|
& L2, NNN, ERR, NOROOM)
|
||
|
|
IF ((NOROOM) .OR. (ERR)) THEN
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK UNHOOKING L2 FROM N2 **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
CALL DELLXN (MXND, LXN, NUID, NAVAIL, IAVAIL, N0,
|
||
|
|
& L1, NNN, ERR, NOROOM)
|
||
|
|
IF ((NOROOM) .OR. (ERR)) THEN
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK UNHOOKING L1 FROM N0 **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
CALL DELLXN (MXND, LXN, NUID, NAVAIL, IAVAIL, NC2,
|
||
|
|
& L5, NNN, ERR, NOROOM)
|
||
|
|
IF ((NOROOM) .OR. (ERR)) THEN
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK UNHOOKING L1 FROM N0 **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
C ADD ALL LINES STILL HOOKED TO N2 TO THE LIST OF LINES FOR N0
|
||
|
|
|
||
|
|
DO 240 I = 1, NL
|
||
|
|
LL = L1LIST (I)
|
||
|
|
IF (LL .NE. L2) THEN
|
||
|
|
CALL ADDLXN (MXND, LXN, NUID, NAVAIL, IAVAIL,
|
||
|
|
& N0, LL, NNN, ERR, NOROOM)
|
||
|
|
IF ((NOROOM) .OR. (ERR)) THEN
|
||
|
|
CALL MESSAGE('** PROBLEMS IN TUCK HOOKING N2'' LINES'//
|
||
|
|
& ' TO N0 **')
|
||
|
|
GOTO 290
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
240 CONTINUE
|
||
|
|
|
||
|
|
C DELETE N2
|
||
|
|
|
||
|
|
DO 250 I = 1, 3
|
||
|
|
LXN (I, N2) = 0
|
||
|
|
250 CONTINUE
|
||
|
|
LXN (4, N2) = IAVAIL
|
||
|
|
IAVAIL = N2
|
||
|
|
NAVAIL = NAVAIL+1
|
||
|
|
NUID (N2) = 0
|
||
|
|
|
||
|
|
C NOW DELETE THE OLD ELEMENT
|
||
|
|
|
||
|
|
DO 260 I = 1, 4
|
||
|
|
LXK (I, KOLD) = 0
|
||
|
|
260 CONTINUE
|
||
|
|
|
||
|
|
C NOW FIX THE LNODES ARRAY
|
||
|
|
|
||
|
|
LNODES (3, N0) = LNODES (3, N2)
|
||
|
|
LNODES (2, LNODES (3, N2) ) = N0
|
||
|
|
LNODES (5, N0) = LNODES (5, N2)
|
||
|
|
|
||
|
|
NLOOP = NLOOP - 2
|
||
|
|
ERR = .FALSE.
|
||
|
|
|
||
|
|
C NOW REDRAW THE ELEMENTS
|
||
|
|
|
||
|
|
IF (GRAPH) THEN
|
||
|
|
CALL LCOLOR ('BLACK')
|
||
|
|
CALL D2NODE (MXND, XN, YN, N0, N1)
|
||
|
|
CALL D2NODE (MXND, XN, YN, NC2, N1)
|
||
|
|
CALL D2NODE (MXND, XN, YN, N2, N1)
|
||
|
|
CALL LCOLOR ('WHITE')
|
||
|
|
CALL GETLXN (MXND, LXN, N0, L1LIST, NL, ERR)
|
||
|
|
IF (ERR) GOTO 290
|
||
|
|
DO 270 II = 1, NL
|
||
|
|
IDRAW = L1LIST (II)
|
||
|
|
NODE1 = NXL (1, IDRAW)
|
||
|
|
NODE2 = NXL (2, IDRAW)
|
||
|
|
CALL D2NODE (MXND, XN, YN, NODE1, NODE2)
|
||
|
|
270 CONTINUE
|
||
|
|
CALL GETLXN (MXND, LXN, NC1, L1LIST, NL, ERR)
|
||
|
|
IF (ERR) GOTO 290
|
||
|
|
DO 280 II = 1, NL
|
||
|
|
IDRAW = L1LIST (II)
|
||
|
|
NODE1 = NXL (1, IDRAW)
|
||
|
|
NODE2 = NXL (2, IDRAW)
|
||
|
|
CALL D2NODE (MXND, XN, YN, NODE1, NODE2)
|
||
|
|
280 CONTINUE
|
||
|
|
CALL SFLUSH
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
C FLAG NODES FOR SMOOTHING
|
||
|
|
|
||
|
|
CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES, NC1, ERR)
|
||
|
|
IF (ERR) GOTO 290
|
||
|
|
CALL MARKSM (MXND, MLN, LXK, KXL, NXL, LXN, LNODES, NC2, ERR)
|
||
|
|
IF (ERR) GOTO 290
|
||
|
|
|
||
|
|
290 CONTINUE
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
END
|