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.
163 lines
4.5 KiB
163 lines
4.5 KiB
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 INNERH (MXND, NXH, NUID, LXK, KXL, NXL, LXN, KKK, LLL,
|
|
& NNN, NNNOLD, NH, ISTART, IAVAIL, NAVAIL, NOROOM, ERR)
|
|
C***********************************************************************
|
|
|
|
C SUBROUTINE INNERH = INSERT A ROW OF ELEMENTS AROUND A HOLE
|
|
|
|
C***********************************************************************
|
|
|
|
DIMENSION NUID(MXND), LXK(4, MXND)
|
|
DIMENSION KXL(2, 3*MXND), NXL(2, 3*MXND), LXN(4, MXND)
|
|
DIMENSION NXH(MXND)
|
|
|
|
LOGICAL ERR, NOROOM
|
|
|
|
ERR = .FALSE.
|
|
IF ((KKK + NH .GT. MXND) .OR. (LLL + 2*NH .GT. 3*MXND) .OR.
|
|
& (NNN + NH .GT. MXND)) THEN
|
|
NOROOM = .TRUE.
|
|
GO TO 200
|
|
ELSE
|
|
NOROOM = .FALSE.
|
|
END IF
|
|
|
|
C GENERATE LINES
|
|
|
|
LLLOLD = LLL
|
|
I1 = ISTART
|
|
DO 100 I = 1, NH
|
|
LLL = LLL + 1
|
|
NXL(1, LLL) = NXH(I1)
|
|
CALL ADDLXN(MXND, LXN, NUID, NAVAIL, IAVAIL, NXL(1, LLL),
|
|
& LLL, NNN, ERR, NOROOM)
|
|
IF (NOROOM .OR. ERR) GO TO 200
|
|
NXL(2, LLL) = NNNOLD + I
|
|
I1 = I1 + 1
|
|
IF (I1 .GT. NH) I1 = 1
|
|
100 CONTINUE
|
|
|
|
DO 110 I = 1, NH - 1
|
|
LLL = LLL + 1
|
|
NXL(1, LLL) = NNNOLD + I
|
|
NXL(2, LLL) = NNNOLD + I + 1
|
|
110 CONTINUE
|
|
LLL = LLL + 1
|
|
NXL(1, LLL) = NNN
|
|
NXL(2, LLL) = NNNOLD + 1
|
|
|
|
C MAKE SPACE IN LXN LIST FOR NEW NODES
|
|
|
|
IF (IAVAIL .LT. NNNOLD) THEN
|
|
JJ = IAVAIL
|
|
MAXLNK = 0
|
|
120 CONTINUE
|
|
IF (LXN(4, JJ) .LE. NNNOLD) THEN
|
|
JJ = LXN(4, JJ)
|
|
MAXLNK = MAXLNK + 1
|
|
IF (MAXLNK .GT. NNNOLD) THEN
|
|
CALL MESSAGE('INNERH - LXN LINKED LIST ERROR')
|
|
ERR = .TRUE.
|
|
GO TO 200
|
|
ELSE
|
|
GO TO 120
|
|
END IF
|
|
END IF
|
|
LXN(4, JJ) = NNNOLD + NH + 1
|
|
NAVAIL = NAVAIL - NH
|
|
ELSE IF (IAVAIL .GT. NNNOLD) THEN
|
|
DO 130 J = 1, IAVAIL - 1
|
|
IF (LXN(4, J) .LT. 0 .AND. ABS(LXN(4, J)) .GT. NNNOLD)
|
|
& LXN(4, J) = LXN(4, J) - NH
|
|
130 CONTINUE
|
|
JJ = NNNOLD + NH
|
|
DO 150 J = NNNOLD + 1, IAVAIL - 1
|
|
JJ = JJ + 1
|
|
DO 140 K = 1, 4
|
|
LXN(K, JJ) = LXN(K, J)
|
|
140 CONTINUE
|
|
150 CONTINUE
|
|
IAVAIL = JJ + 1
|
|
NAVAIL = NAVAIL - NH
|
|
ELSE
|
|
IAVAIL = NNN + 1
|
|
NAVAIL = MXND - NNN
|
|
END IF
|
|
|
|
C MARK NODES ON HOLE BOUNDARY
|
|
|
|
LXN(1, NNNOLD + 1) = LLLOLD + 1
|
|
LXN(2, NNNOLD + 1) = -(LLLOLD + 2*NH)
|
|
LXN(3, NNNOLD + 1) = LLLOLD + NH + 1
|
|
LXN(4, NNNOLD + 1) = 0
|
|
NNN = NNNOLD + 1
|
|
DO 160 I = 2, NH
|
|
NNN = NNN + 1
|
|
LXN(1, NNN) = LLLOLD + I
|
|
LXN(2, NNN) = -(LLLOLD + NH + I - 1)
|
|
LXN(3, NNN) = LLLOLD + NH + I
|
|
LXN(4, NNN) = 0
|
|
160 CONTINUE
|
|
|
|
C GENERATE ELEMENTS
|
|
|
|
DO 180 I = LLLOLD + 1, LLL
|
|
DO 170 J = 1, 2
|
|
KXL(J, I) = 0
|
|
170 CONTINUE
|
|
180 CONTINUE
|
|
|
|
I1 = ISTART
|
|
I2 = I1 + 1
|
|
IF (I2 .GT. NH) I2 = 1
|
|
DO 190 I = 1, NH - 1
|
|
CALL FNDLIN_FQ (MXND, LXN, NXH(I1), NXH(I2), LINE, ERR)
|
|
IF (ERR) GO TO 200
|
|
KKK = KKK + 1
|
|
LXK(1, KKK) = LINE
|
|
LXK(2, KKK) = LLLOLD + I
|
|
LXK(3, KKK) = LLLOLD + I + 1
|
|
LXK(4, KKK) = LLLOLD + I + NH
|
|
I1 = I1 + 1
|
|
IF (I1 .GT. NH) I1 = 1
|
|
I2 = I1 + 1
|
|
IF (I2 .GT. NH) I2 = 1
|
|
|
|
IF (KXL(1, LINE) .EQ. 0) THEN
|
|
KXL(1, LINE) = KKK
|
|
ELSE IF (KXL(2, LINE) .EQ. 0) THEN
|
|
KXL(2, LINE) = KKK
|
|
ELSE
|
|
CALL MESSAGE('KXL TABLE FULL')
|
|
END IF
|
|
KXL(2, LLLOLD + I) = KKK
|
|
KXL(1, LLLOLD + I + 1) = KKK
|
|
KXL(1, LLLOLD + I + NH) = KKK
|
|
190 CONTINUE
|
|
CALL FNDLIN_FQ (MXND, LXN, NXH(I1), NXH(I2), LINE, ERR)
|
|
IF (ERR) GO TO 200
|
|
KKK = KKK + 1
|
|
LXK(1, KKK) = LINE
|
|
LXK(2, KKK) = LLLOLD + NH
|
|
LXK(3, KKK) = LLLOLD + 1
|
|
LXK(4, KKK) = LLLOLD + 2*NH
|
|
|
|
IF (KXL(1, LINE) .EQ. 0) THEN
|
|
KXL(1, LINE) = KKK
|
|
ELSE IF (KXL(2, LINE) .EQ. 0) THEN
|
|
KXL(2, LINE) = KKK
|
|
ELSE
|
|
CALL MESSAGE('KXL TABLE FULL')
|
|
END IF
|
|
KXL(2, LLLOLD + NH) = KKK
|
|
KXL(1, LLLOLD + 1) = KKK
|
|
KXL(1, LLLOLD + 2*NH) = KKK
|
|
|
|
200 CONTINUE
|
|
RETURN
|
|
END
|
|
|