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.
269 lines
7.4 KiB
269 lines
7.4 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 RMESH (NPER, MXND, X, Y, NID, XN, YN, NUID, LXK, KXL,
|
|
& NXL, LXN, M1, M2, KKK, KKKOLD, NNN, NNNOLD, LLL, LLLOLD,
|
|
& IAVAIL, NAVAIL, ERR)
|
|
C***********************************************************************
|
|
|
|
C SUBROUTINE RMESH = GENERATES AN INITIAL LOGICAL RECTANGULAR MESH
|
|
C WHOSE PERIMETER IS (X (I), Y (I), I=1, N).
|
|
|
|
C***********************************************************************
|
|
|
|
C VARIABLES USED:
|
|
C X = X VALUES AROUND THE PERIMETER
|
|
C Y = Y VALUES AROUND THE PERIMETER
|
|
C NID = PERIMETER NODE UNIQUE ID'S
|
|
C N = NUMBER OF PERIMETER NODES
|
|
C M1 = THE NUMBER OF INTERVALS ON THE FIRST SIDE OF THE RECTANGLE
|
|
C IMAP = CONTROLS THE DEFINITION OF THE VALUES OF THE COORDINATE
|
|
C OF THE INTERIOR NODES.
|
|
C = 1 MEANS SET ALL COORDINATES TO 0.
|
|
C = 2 MEANS SET ALL COORDINATES TO THE CENTROID OF PERIMETER
|
|
C = 3 MEANS APPLY THE UNIT SQUARE TRANSFORMATION FROM
|
|
C W.A.COOK'S PAPER (THIOKOL REPORT AFRDL - TR - 71 - 51)
|
|
C ERR = .TRUE. IF ERRORS WERE ENCOUNTERED
|
|
C XN = GLOBAL X VALUES OF NODES
|
|
C YN = GLOBAL Y VALUES OF NODES
|
|
C NUID = GLOBAL NODE UNIQUE IDENTIFIERS
|
|
C LXK = LINES PER ELEMENT
|
|
C KXL = ELEMENTS PER LINE
|
|
C NXL = NODES PER LINE
|
|
C LXN = LINES PER NODE
|
|
C NOTE:
|
|
C FOR *XN TABLES A NEGATIVE FLAG IN THE FOURTH COLUMN MEANS
|
|
C GO TO THAT ROW FOR A CONTINUATION OF THE LIST. IN THAT ROW
|
|
C THE FIRST ELEMENT WILL BE NEGATED TO INDICATE THAT THIS IS
|
|
C A CONTINUATION ROW. (RMESH ITSELF GENERATES NO SUCH NEGATIVES.)
|
|
C A NEGATIVE FLAG IN THE SECOND COLUMN OF THE LXN ARRAY MEANS
|
|
C THAT THIS NODE IS A BOUNDARY NODE.
|
|
|
|
C***********************************************************************
|
|
|
|
DIMENSION X (NPER), Y (NPER), NID (NPER)
|
|
DIMENSION XN (MXND), YN (MXND), NUID (MXND)
|
|
DIMENSION LXK (4, MXND), KXL (2, 3 * MXND)
|
|
DIMENSION NXL (2, 3 * MXND), LXN (4, MXND)
|
|
|
|
LOGICAL ERR, NOROOM
|
|
|
|
C NOTE: NOROOM SHOULD NEVER BE TRUE WITH CROSS BEING CALLED IN RMESH.
|
|
C THUS, IT IS NEVER PASSED BACK TO QMESH.
|
|
|
|
KKK = M1 * M2 + KKKOLD
|
|
LLL = (M1 * (M2 + 1)) + (M2 * (M1 + 1)) + LLLOLD
|
|
NNN = (M1 + 1) * (M2 + 1) + NNNOLD
|
|
ERR = .TRUE.
|
|
|
|
C CHECK INPUT
|
|
|
|
IF (2 * (NPER / 2) .NE. NPER) THEN
|
|
CALL MESSAGE('IN RMESH, NO. OF PERIMETER NODES IS ODD')
|
|
RETURN
|
|
ELSEIF ( (M1 .LT. 1) .OR. (M2 .LT. 1)) THEN
|
|
WRITE ( * , 10000)NPER, M1
|
|
RETURN
|
|
ENDIF
|
|
|
|
C COMPUTE CONSTANTS
|
|
|
|
NLC = 2 * M1 + 1
|
|
M1P1 = M1 + 1
|
|
M2P1 = M2 + 1
|
|
|
|
C PRODUCE LXK ARRAY
|
|
|
|
C LINES FOR FIRST ELEMENT
|
|
|
|
LXK (1, KKKOLD + 1) = 1 + LLLOLD
|
|
LXK (2, KKKOLD + 1) = M1 + 1 + LLLOLD
|
|
LXK (3, KKKOLD + 1) = M1 + 2 + LLLOLD
|
|
LXK (4, KKKOLD + 1) = NLC + 1 + LLLOLD
|
|
|
|
C FIRST ROW (SHIFT FIRST ELEMENT TO SECOND, ETC.)
|
|
|
|
IF (M1 .GT. 1) THEN
|
|
DO 110 K = 2, M1
|
|
DO 100 I = 1, 4
|
|
LXK (I, K + KKKOLD) = LXK (I, K + KKKOLD - 1) + 1
|
|
100 CONTINUE
|
|
110 CONTINUE
|
|
ENDIF
|
|
|
|
C SUCCEEDING ROWS (SHIFT FIRST COLUMN TO SECOND, ETC.)
|
|
|
|
IF (M2 .GT. 1) THEN
|
|
K = M1 + KKKOLD
|
|
DO 140 K2 = 2, M2
|
|
DO 130 K1 = 1, M1
|
|
K = K + 1
|
|
KL = K - M1
|
|
DO 120 I = 1, 4
|
|
LXK (I, K) = LXK (I, KL) + NLC
|
|
120 CONTINUE
|
|
130 CONTINUE
|
|
140 CONTINUE
|
|
ENDIF
|
|
|
|
C PREPARE KXL TABLE BY USING SUBROUTINE CROSS ON THE LXK TABLE
|
|
|
|
CALL CCROSS (4, KKK, 2, LLL, LXK, KXL, KKKOLD + 1, LLLOLD + 1,
|
|
& NOROOM, ERR)
|
|
IF (ERR) RETURN
|
|
ERR = .TRUE.
|
|
|
|
C MAKE NXL TABLE
|
|
|
|
C FIRST DO HORIZONTAL LINES
|
|
|
|
DO 160 J = 1, M2P1
|
|
NODE = 1 + (J - 1) * (M1 + 1) + NNNOLD
|
|
L = 1 + ( (J - 1) * NLC) + LLLOLD
|
|
DO 150 I = 1, M1
|
|
NXL (1, L) = NODE
|
|
NXL (2, L) = NODE + 1
|
|
NODE = NODE + 1
|
|
L = L + 1
|
|
150 CONTINUE
|
|
160 CONTINUE
|
|
|
|
C NEXT DO VERTICAL LINES
|
|
|
|
DO 180 J = 1, M1P1
|
|
NODE = J + NNNOLD
|
|
L = J + M1 + LLLOLD
|
|
DO 170 I = 1, M2
|
|
NXL (1, L) = NODE
|
|
NXL (2, L) = NODE + M1P1
|
|
NODE = NODE + M1P1
|
|
L = L + NLC
|
|
170 CONTINUE
|
|
180 CONTINUE
|
|
|
|
C PREPARE LXN TABLE FROM NXL TABLE
|
|
|
|
CALL CCROSS (2, LLL, 4, NNN, NXL, LXN, LLLOLD + 1, NNNOLD + 1,
|
|
& NOROOM, ERR)
|
|
IF (ERR) RETURN
|
|
ERR = .TRUE.
|
|
|
|
C LINK - UP AVAILABLE LXN SPACE
|
|
|
|
IAVAIL = NNN + 1
|
|
NAVAIL = MXND - NNN
|
|
DO 190 I = IAVAIL, MXND
|
|
LXN (1, I) = 0
|
|
LXN (2, I) = 0
|
|
LXN (3, I) = 0
|
|
LXN (4, I) = I + 1
|
|
190 CONTINUE
|
|
|
|
C LOGICAL CONNECTION TABLES ARE COMPLETE
|
|
C FILL IN THE CO - ORDINATES OF THE INTERIOR POINTS
|
|
C USE THE UNIT SQUARE TRANSFORMATION (OF COOK / THIOKOL)
|
|
|
|
IF ( (M1 .GT. 1) .AND. (M2 .GT. 1)) THEN
|
|
|
|
C GET NODE NUMBERS FOR CORNERS
|
|
|
|
I1Z = M1 + 1
|
|
IZ1 = NPER - (M2 - 1)
|
|
I11 = M1 + M2 + 1
|
|
|
|
C COLUMN LOOP
|
|
|
|
DO 210 J = 2, M2
|
|
KL = NPER + 2 - J
|
|
KR = M1 + J
|
|
ETA = DBLE(J - 1) / DBLE(M2)
|
|
OMETA = 1.0 - ETA
|
|
|
|
C ROW LOOP
|
|
|
|
DO 200 I = 2, M1
|
|
KB = I
|
|
KT = IZ1 + 1 - I
|
|
EPS = DBLE(I - 1) / DBLE(M1)
|
|
OMEPS = 1.0 - EPS
|
|
IM = (J - 1) * M1P1 + I + NNNOLD
|
|
XN (IM) = (OMETA * X (KB)) + (ETA * X (KT)) +
|
|
& (OMEPS * X (KL)) + (EPS * X (KR)) -
|
|
& ((X (1) * OMETA * OMEPS) + (X (I1Z) * OMETA * EPS) +
|
|
& (X (IZ1) * ETA * OMEPS) + (X (I11) * ETA * EPS))
|
|
YN (IM) = (OMETA * Y (KB)) + (ETA * Y (KT)) +
|
|
& (OMEPS * Y (KL)) + (EPS * Y (KR)) -
|
|
& ((Y (1) * OMETA * OMEPS) + (Y (I1Z) * OMETA * EPS) +
|
|
& (Y (IZ1) * ETA * OMEPS) + (Y (I11) * ETA * EPS))
|
|
200 CONTINUE
|
|
210 CONTINUE
|
|
ENDIF
|
|
|
|
C DEFINE THE COORDINATES OF THE PERIMETER NODES.
|
|
C ALSO FLAG SECOND ELEMENTS OF LXN ARRAY TO INDICATE
|
|
C WHICH NODES ARE BOUNDARY NODES.
|
|
C DEFINE UNIQUE NODE ID NUMBERS ALSO.
|
|
|
|
DO 220 I = NNNOLD + 1, NNN
|
|
NUID (I) = 0
|
|
220 CONTINUE
|
|
|
|
C BOTTOM
|
|
|
|
IP = 0
|
|
DO 230 I = 1, M1P1
|
|
IM = I + NNNOLD
|
|
IP = IP + 1
|
|
LXN (2, IM) = - LXN (2, IM)
|
|
NUID (IM) = NID (IP)
|
|
XN (IM) = X (IP)
|
|
YN (IM) = Y (IP)
|
|
230 CONTINUE
|
|
|
|
C RIGHT
|
|
|
|
IP = M1P1
|
|
DO 240 I = 2, M2P1
|
|
IP = IP + 1
|
|
IM = IM + M1P1
|
|
LXN (2, IM) = - LXN (2, IM)
|
|
NUID (IM) = NID (IP)
|
|
XN (IM) = X (IP)
|
|
YN (IM) = Y (IP)
|
|
240 CONTINUE
|
|
|
|
C TOP
|
|
|
|
DO 250 I = 2, M1P1
|
|
IP = IP + 1
|
|
IM = IM - 1
|
|
LXN (2, IM) = - LXN (2, IM)
|
|
NUID (IM) = NID (IP)
|
|
XN (IM) = X (IP)
|
|
YN (IM) = Y (IP)
|
|
250 CONTINUE
|
|
|
|
C LEFT
|
|
|
|
DO 260 I = 2, M2
|
|
IP = IP + 1
|
|
IM = IM - M1P1
|
|
LXN (2, IM) = - LXN (2, IM)
|
|
NUID (IM) = NID (IP)
|
|
XN (IM) = X (IP)
|
|
YN (IM) = Y (IP)
|
|
260 CONTINUE
|
|
|
|
C EXIT
|
|
|
|
ERR = .FALSE.
|
|
|
|
RETURN
|
|
|
|
10000 FORMAT (' IN RMESH, N = ', I5, ' AND M1 = ', I5,
|
|
& ' ARE INCOMPATIBLE')
|
|
|
|
END
|
|
|