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.
165 lines
4.7 KiB
165 lines
4.7 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 INBOUN (MDIM, JJ, IFOUND, IIN, N1, N2, N3, N2OLD,
|
||
|
|
& MERGE, NOROOM, NEWNUM, NHOLD, IHOLD, IFLAG, INUM, IFIRST,
|
||
|
|
& LIST, LINK, IWT, JHOLD, ADDOLD)
|
||
|
|
C***********************************************************************
|
||
|
|
|
||
|
|
C SUBROUTINE INBOUN = INPUTS AND LINKS BOUNDARY FLAG INFORMATION
|
||
|
|
|
||
|
|
C***********************************************************************
|
||
|
|
|
||
|
|
C SUBROUTINE CALLED BY:
|
||
|
|
C READ = READS AND/OR MERGES QMESH CARD FILE(S)
|
||
|
|
C LINKBC = LINKS BOUNDARY FLAGS TO ENTITIES
|
||
|
|
|
||
|
|
C***********************************************************************
|
||
|
|
|
||
|
|
DIMENSION IHOLD(2, MDIM), IFLAG(MDIM)
|
||
|
|
DIMENSION INUM(MDIM), IFIRST(MDIM)
|
||
|
|
DIMENSION LIST(2, MDIM), LINK(2, MDIM)
|
||
|
|
DIMENSION IIN(IFOUND), IWT(3, MDIM)
|
||
|
|
|
||
|
|
LOGICAL NOROOM, MERGE, NEWNUM, ADDOLD, ADDLNK
|
||
|
|
|
||
|
|
NEWNUM = .FALSE.
|
||
|
|
NOROOM = .FALSE.
|
||
|
|
IZ = 0
|
||
|
|
IOLD = 0
|
||
|
|
|
||
|
|
IF ((JJ.LE.0) .OR. (JJ .GT. 10000)) THEN
|
||
|
|
WRITE(*, 10000) JJ
|
||
|
|
RETURN
|
||
|
|
END IF
|
||
|
|
|
||
|
|
NOROOM = .TRUE.
|
||
|
|
|
||
|
|
C GET THE CORRECT FLAG ID
|
||
|
|
|
||
|
|
IF (JJ .GT. N1) THEN
|
||
|
|
N1 = JJ
|
||
|
|
ELSE IF (MERGE) THEN
|
||
|
|
JHOLD = JJ
|
||
|
|
ADDLNK = .FALSE.
|
||
|
|
CALL LTSORT (MDIM, LINK, JJ, IPNTR, ADDLNK)
|
||
|
|
IF (IPNTR .GT. 0) THEN
|
||
|
|
IF (JHOLD .GT. NHOLD)NHOLD = JHOLD
|
||
|
|
CALL LTSORT (MDIM, IHOLD, JHOLD, IPNTR, ADDLNK)
|
||
|
|
IF (IPNTR .GT. 0) THEN
|
||
|
|
JJ = IPNTR
|
||
|
|
ELSE
|
||
|
|
JJ = N1 + 1
|
||
|
|
N1 = JJ
|
||
|
|
NEWNUM = .TRUE.
|
||
|
|
ADDLNK = .TRUE.
|
||
|
|
CALL LTSORT (MDIM, LINK, JJ, IZ, ADDLNK)
|
||
|
|
CALL LTSORT (MDIM, IHOLD, JHOLD, JJ, ADDLNK)
|
||
|
|
END IF
|
||
|
|
END IF
|
||
|
|
END IF
|
||
|
|
IF (N2 + 1 .GT. MDIM) RETURN
|
||
|
|
|
||
|
|
C GET THE OLD LOCATION OF THE FLAG IF IT IS THERE
|
||
|
|
|
||
|
|
ADDLNK = .FALSE.
|
||
|
|
CALL LTSORT (MDIM, LINK, JJ, IOLD, ADDLNK)
|
||
|
|
|
||
|
|
C IF THE FLAG CURRENTLY EXISTS, SHIFT THE FLAG DATA TO THE END
|
||
|
|
C OF THE CURRENT FLAG LIST, TO FACILITATE ADDING MORE ENTRIES
|
||
|
|
C TO THE OLD FLAG
|
||
|
|
|
||
|
|
IF (IOLD .GT. 0) THEN
|
||
|
|
|
||
|
|
C SHIFT THE OLD DEFINITION TO THE END OF THE LIST
|
||
|
|
|
||
|
|
IFLAG(N2 + 1) = IFLAG(IOLD)
|
||
|
|
INUM(N2 + 1) = INUM(IOLD)
|
||
|
|
IWT(1, N2 + 1) = IWT(1, IOLD)
|
||
|
|
IWT(2, N2 + 1) = IWT(2, IOLD)
|
||
|
|
IWT(3, N2 + 1) = IWT(3, IOLD)
|
||
|
|
IFIRST(N2 + 1) = N3 + 1
|
||
|
|
|
||
|
|
IF (IOLD .LT. N2) THEN
|
||
|
|
KOUNT = IFIRST(IOLD + 1) - IFIRST(IOLD)
|
||
|
|
ELSE IF (IOLD .EQ. N2) THEN
|
||
|
|
KOUNT = INUM(IOLD)
|
||
|
|
ELSE
|
||
|
|
CALL MESSAGE('IN INBOUN, ERROR REORDERING FLAG LIST')
|
||
|
|
RETURN
|
||
|
|
END IF
|
||
|
|
NLIST1 = IFIRST(IOLD)
|
||
|
|
NPLACE = N3
|
||
|
|
DO 100 I = NLIST1, NLIST1 + INUM(IOLD) - 1
|
||
|
|
NPLACE = NPLACE + 1
|
||
|
|
IF (NPLACE .GT. MDIM) RETURN
|
||
|
|
LIST(1, NPLACE) = LIST(1, I)
|
||
|
|
LIST(2, NPLACE) = LIST(2, I)
|
||
|
|
100 CONTINUE
|
||
|
|
|
||
|
|
C SLIDE ALL TRAILING FLAGS OVER TO FILL THE GAP IN THE LIST
|
||
|
|
C RESORT THE POINTER ARRAY AS THE LIST FILLS AND STEP N2OLD
|
||
|
|
C DOWN A NOTCH SO THESE WILL BE RELINKED IF NECESSARY
|
||
|
|
|
||
|
|
IF (N2OLD .GT. 0) N2OLD = N2OLD - 1
|
||
|
|
ADDLNK = .TRUE.
|
||
|
|
DO 110 I = IOLD, N2
|
||
|
|
IFLAG(I) = IFLAG(I + 1)
|
||
|
|
INUM(I) = INUM(I + 1)
|
||
|
|
IFIRST(I) = IFIRST(I + 1) - KOUNT
|
||
|
|
IWT(1, I) = IWT(1, I + 1)
|
||
|
|
IWT(2, I) = IWT(2, I + 1)
|
||
|
|
IWT(3, I) = IWT(3, I + 1)
|
||
|
|
CALL LTSORT (MDIM, LINK, IFLAG(I), I, ADDLNK)
|
||
|
|
110 CONTINUE
|
||
|
|
|
||
|
|
N3 = IFIRST(N2) + INUM(N2) - 1
|
||
|
|
DO 120 I = NLIST1, N3
|
||
|
|
IKOUNT = I + KOUNT
|
||
|
|
LIST(1, I) = LIST(1, IKOUNT)
|
||
|
|
LIST(2, I) = LIST(2, IKOUNT)
|
||
|
|
120 CONTINUE
|
||
|
|
ELSE
|
||
|
|
|
||
|
|
C LINK UP THE FLAG IN THE NEXT OPEN SLOT
|
||
|
|
|
||
|
|
ADDLNK = .TRUE.
|
||
|
|
N2 = N2 + 1
|
||
|
|
CALL LTSORT (MDIM, LINK, JJ, N2, ADDLNK)
|
||
|
|
IFLAG(N2) = JJ
|
||
|
|
IFIRST(N2) = N3 + 1
|
||
|
|
IWT(1, N2) = 0
|
||
|
|
IWT(2, N2) = 0
|
||
|
|
IWT(3, N2) = 0
|
||
|
|
END IF
|
||
|
|
|
||
|
|
C READ IN THE NEW FLAG LIST
|
||
|
|
|
||
|
|
DO 150 I = 1, IFOUND
|
||
|
|
JJ = IIN(I)
|
||
|
|
IF (JJ .EQ. 0) GO TO 160
|
||
|
|
|
||
|
|
C CHECK TO MAKE SURE THIS ENTITY IS NOT ALREADY IN THE LIST
|
||
|
|
|
||
|
|
DO 130 K = IFIRST(N2), N3
|
||
|
|
IF (LIST(1, K) .EQ. JJ) GO TO 140
|
||
|
|
130 CONTINUE
|
||
|
|
N3 = N3 + 1
|
||
|
|
IF (N3 .GT. MDIM) RETURN
|
||
|
|
LIST(1, N3) = JJ
|
||
|
|
LIST(2, N3) = 0
|
||
|
|
140 CONTINUE
|
||
|
|
150 CONTINUE
|
||
|
|
160 CONTINUE
|
||
|
|
|
||
|
|
INUM(N2) = N3 - IFIRST(N2) + 1
|
||
|
|
NOROOM = .FALSE.
|
||
|
|
RETURN
|
||
|
|
|
||
|
|
10000 FORMAT (' A FLAG NO. OF:', I7, ' IS NOT ALLOWED', /,
|
||
|
|
& ' THIS FLAG WILL NOT BE INPUT INTO DATABASE')
|
||
|
|
END
|