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.
320 lines
10 KiB
320 lines
10 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 GETWT (MP, ML, MXLPS, NIX, ILIST, XLIST, ILINE, LCON,
|
|
& LTYPE, COOR, LINKP, FRACT, ADDLNK, ERR)
|
|
C***********************************************************************
|
|
|
|
C SUBROUTINE GETWT = GETS A WEIGHT BASED ON A PERCENTAGE DISTANCE ALONG
|
|
C THE GIVEN SIDE LINE LIST.
|
|
|
|
C***********************************************************************
|
|
|
|
C SUBROUTINE CALLED BY:
|
|
C ADDWT = ADDS THE WEIGHTING FACTORS TO ANY NODES WITH
|
|
C FLAGS CONTAINING WEIGHTS
|
|
|
|
C***********************************************************************
|
|
|
|
C VARIABLES USED:
|
|
C FRACT = THE FRACTION OF TOTAL DISTANCE ALONG THE X AXIS
|
|
C (TAKES BACK THE WEIGHT OR Y VALUE AT THAT % DISTANCE)
|
|
|
|
C***********************************************************************
|
|
|
|
DIMENSION ILIST (MXLPS), XLIST (MXLPS)
|
|
DIMENSION ILINE (ML), LCON (3, ML), LTYPE (ML)
|
|
DIMENSION COOR (2, MP), LINKP (2, MP)
|
|
|
|
LOGICAL ADDLNK, ERR
|
|
|
|
ADDLNK = .FALSE.
|
|
ERR = .FALSE.
|
|
PI = ATAN2(0.0, -1.0)
|
|
TWOPI = 2.*PI
|
|
|
|
C GET THE X VALUE
|
|
|
|
X = FRACT* (XLIST (NIX)-XLIST (1))+XLIST (1)
|
|
|
|
C FIND THE LINE THIS BELONGS TO
|
|
|
|
DO 100 I = 1, NIX-1
|
|
IF ((X.LE.XLIST (I+1)).AND. (X.GE.XLIST (I))) THEN
|
|
IL = ILIST (I)
|
|
GOTO 110
|
|
ENDIF
|
|
100 CONTINUE
|
|
CALL MESSAGE('PROBLEMS IN GETWT - NO X SPAN FOUND')
|
|
ERR = .TRUE.
|
|
RETURN
|
|
|
|
110 CONTINUE
|
|
|
|
C NOW GET THE Y VALUE FOR THE X AND THE LINE (AND TYPE OF LINE) GIVEN
|
|
|
|
KT = LTYPE (IL)
|
|
CALL LTSORT (MP, LINKP, LCON (1, IL), IP1, ADDLNK)
|
|
CALL LTSORT (MP, LINKP, LCON (2, IL), IP2, ADDLNK)
|
|
CALL LTSORT (MP, LINKP, IABS (LCON (3, IL)), IP3, ADDLNK)
|
|
IF (LCON (3, IL).LT.0)IP3 = -IP3
|
|
|
|
C CHECK FOR EXACT LINE END PLACEMENT
|
|
|
|
EPS = ABS (XLIST (NIX)-XLIST (1))*.00001
|
|
IF (ABS (X-COOR (1, IP1)).LT.EPS) THEN
|
|
FRACT = COOR (2, IP1)
|
|
RETURN
|
|
ELSEIF (ABS (X-COOR (1, IP2)).LT.EPS) THEN
|
|
FRACT = COOR (2, IP2)
|
|
RETURN
|
|
ENDIF
|
|
|
|
C GET INTERMEDIATE Y VALUE BASED ON THE LINE TYPE
|
|
|
|
C FIRST - STRAIGHT LINES
|
|
|
|
IF (KT.EQ.1) THEN
|
|
IF (COOR (1, IP1).GT.COOR (1, IP2)) THEN
|
|
IHOLD = IP1
|
|
IP1 = IP2
|
|
IP2 = IHOLD
|
|
ENDIF
|
|
XFRACT = (X-COOR (1, IP1))/ (COOR (1, IP2)-COOR (1, IP1))
|
|
FRACT = (XFRACT* (COOR (2, IP2)-COOR (2, IP1)))+COOR (2, IP1)
|
|
|
|
C NEXT - CORNER LINES
|
|
|
|
ELSEIF (KT.EQ.2) THEN
|
|
IF (COOR (1, IP1).GT.COOR (1, IP2)) THEN
|
|
IHOLD = IP1
|
|
IP1 = IP2
|
|
IP2 = IHOLD
|
|
ENDIF
|
|
IF (COOR (1, IP3).GT.X) THEN
|
|
IP2 = IP3
|
|
XFRACT = (X-COOR (1, IP1))/ (COOR (1, IP2)-COOR (1, IP1))
|
|
FRACT = (XFRACT * (COOR (2, IP2) - COOR (2, IP1)))
|
|
& + COOR (2, IP1)
|
|
ELSEIF (COOR (1, IP3).LT.X) THEN
|
|
IP1 = IP3
|
|
XFRACT = (X-COOR (1, IP1))/ (COOR (1, IP2)-COOR (1, IP1))
|
|
FRACT = (XFRACT* (COOR (2, IP2) - COOR (2, IP1)))
|
|
& + COOR (2, IP1)
|
|
ELSE
|
|
FRACT = COOR (2, IP3)
|
|
ENDIF
|
|
|
|
C NEXT - ARCS
|
|
|
|
ELSEIF ((KT.EQ.3).OR. (KT.EQ.4).OR. (KT.EQ.6)) THEN
|
|
|
|
C ARCWITH CENTER GIVEN
|
|
C ARCGOES FROM 1ST POINT TO 2ND IN *COUNTER-CLOCKWISE* DIRECTION.
|
|
|
|
IF (KT.EQ.3) THEN
|
|
XCEN = COOR (1, IABS (IP3))
|
|
YCEN = COOR (2, IABS (IP3))
|
|
|
|
C CIRCLE WITH THIRD POINT ON ARC.
|
|
|
|
ELSEIF (KT.EQ.4) THEN
|
|
THETA1 = ATAN2 (COOR (2, IP3)-COOR (2, IP1), COOR (1, IP3)-
|
|
& COOR (1, IP1))+PI/2.0
|
|
THETA2 = ATAN2 (COOR (2, IP3)-COOR (2, IP2), COOR (1, IP3)-
|
|
& COOR (1, IP2))+PI/2.0
|
|
DET = -COS (THETA1)*SIN (THETA2)+COS (THETA2)*SIN (THETA1)
|
|
X1 = 0.5 * (COOR (1, IP1)+COOR (1, IP3))
|
|
Y1 = 0.5 * (COOR (2, IP1)+COOR (2, IP3))
|
|
X2 = 0.5 * (COOR (1, IP2)+COOR (1, IP3))
|
|
Y2 = 0.5 * (COOR (2, IP2)+COOR (2, IP3))
|
|
R = (-SIN (THETA2) * (X2-X1)+COS (THETA2) * (Y2-Y1))/DET
|
|
XCEN = X1 + R * COS (THETA1)
|
|
YCEN = Y1 + R * SIN (THETA1)
|
|
|
|
C CIRCLE WITH RADIUS GIVEN
|
|
|
|
ELSEIF (KT.EQ.6) THEN
|
|
DX = 0.5 * (COOR (1, IP2)-COOR (1, IP1))
|
|
DY = 0.5 * (COOR (2, IP2)-COOR (2, IP1))
|
|
CHORD = SQRT (DX*DX+DY*DY)
|
|
R = ABS (COOR (1, IABS (IP3)))
|
|
IF (R.LE.CHORD) THEN
|
|
XCEN = 0.5 * (COOR (1, IP1)+COOR (1, IP2))
|
|
YCEN = 0.5 * (COOR (2, IP1)+COOR (2, IP2))
|
|
ELSE
|
|
ARM = SQRT (R * R-CHORD * CHORD)
|
|
IF (IP3.LT.0) THEN
|
|
XCEN = COOR (1, IP1)+DX+ARM * DY/CHORD
|
|
YCEN = COOR (2, IP1)+DY-ARM * DX/CHORD
|
|
ELSE
|
|
XCEN = COOR (1, IP1)+DX-ARM * DY/CHORD
|
|
YCEN = COOR (2, IP1)+DY+ARM * DX/CHORD
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
R1 = SQRT ((COOR (1, IP1)-XCEN) **2 + (COOR (2, IP1)-YCEN) **2)
|
|
R2 = SQRT ((COOR (1, IP2)-XCEN) **2 + (COOR (2, IP2)-YCEN) **2)
|
|
IF ((R1.EQ.0.).OR. (R2.EQ.0.)) THEN
|
|
ERR = .TRUE.
|
|
WRITE (*, 10000)ILINE (IL)
|
|
RETURN
|
|
ENDIF
|
|
THETA1 = ATAN2 (COOR (2, IP1)-YCEN, COOR (1, IP1)-XCEN)
|
|
THETA2 = ATAN2 (COOR (2, IP2)-YCEN, COOR (1, IP2)-XCEN)
|
|
|
|
C ARCWITH THE CENTER GIVEN
|
|
|
|
IF (KT.EQ.3) THEN
|
|
IF ((IP3.GE.0).AND. (THETA2.LE.THETA1))THETA2 = THETA2+TWOPI
|
|
IF ((IP3.LT.0).AND. (THETA1.LE.THETA2))THETA1 = THETA1+TWOPI
|
|
TANG = THETA2-THETA1
|
|
|
|
C CIRCULAR ARC WITH 3RD POINT ON ARC - CLOCKWISE OR COUNTER-CLOCKWISE
|
|
|
|
ELSEIF (KT.EQ.4) THEN
|
|
THETA3 = ATAN2 (COOR (2, IP3)-YCEN, COOR (1, IP3)-XCEN)
|
|
IF (THETA2.LE.THETA1)THETA2 = THETA2+TWOPI
|
|
IF (THETA3.LE.THETA1)THETA3 = THETA3+TWOPI
|
|
TANG = THETA2-THETA1
|
|
IF (THETA3.GT.THETA2)TANG = - (TWOPI-TANG)
|
|
|
|
C CIRCULAR ARC WITH RADIUS GIVEN - CLOCKWISE OR COUNTER-CLOCKWISE
|
|
|
|
ELSEIF (KT.EQ.6) THEN
|
|
IF ((IP3.GE.0).AND. (THETA2.LE.THETA1))THETA2 = THETA2+TWOPI
|
|
IF ((IP3.LT.0).AND. (THETA1.LE.THETA2))THETA1 = THETA1+TWOPI
|
|
TANG = THETA2-THETA1
|
|
ENDIF
|
|
|
|
C NOW ITERATE UNTIL THE X VALUE IS WITHIN SOME EPSILON
|
|
|
|
AA = (LOG (R2/R1))/ (THETA2-THETA1)
|
|
BB = R2/EXP (AA * THETA2)
|
|
ANG = THETA1
|
|
EPS = ABS (COOR (1, IP1)-COOR (1, IP2)) * .000001
|
|
DO 140 I = 1, 10
|
|
DEL = TANG * .1
|
|
DO 120 J = 1, 10
|
|
ANG = ANG+DEL
|
|
RADIUS = BB * EXP (AA * ANG)
|
|
XTEST = XCEN+COS (ANG) * RADIUS
|
|
IF (EPS.GE.ABS (XTEST-X)) THEN
|
|
FRACT = YCEN+SIN (ANG) * RADIUS
|
|
GOTO 150
|
|
ELSEIF ((COOR (1, IP1) .LT. COOR (1, IP2))
|
|
& .AND. (XTEST .GT. X)) THEN
|
|
ANG = ANG-DEL
|
|
TANG = DEL
|
|
GOTO 130
|
|
ELSEIF ((COOR (1, IP1) .GT. COOR (1, IP2))
|
|
& .AND. (XTEST .LT. X)) THEN
|
|
ANG = ANG-DEL
|
|
TANG = DEL
|
|
GOTO 130
|
|
ENDIF
|
|
120 CONTINUE
|
|
130 CONTINUE
|
|
140 CONTINUE
|
|
ERR = .TRUE.
|
|
WRITE (*, 10010)ILINE (IL)
|
|
RETURN
|
|
150 CONTINUE
|
|
|
|
C FINALLY PARABOLAS
|
|
|
|
ELSEIF (KT.EQ.5) THEN
|
|
|
|
C CHECK LEGITIMACY OF DATA
|
|
|
|
IF (COOR (1, IP1).GT.COOR (1, IP2)) THEN
|
|
IJK = IP1
|
|
IP1 = IP2
|
|
IP2 = IJK
|
|
ENDIF
|
|
XMID = (COOR (1, IP1)+COOR (1, IP2)) * 0.5
|
|
YMID = (COOR (2, IP1)+COOR (2, IP2)) * 0.5
|
|
DOT = (COOR (1, IP2)-COOR (1, IP1)) * (COOR (1, IP3)-XMID)
|
|
& + (COOR (2, IP2)-COOR (2, IP1)) * (COOR (2, IP3)-YMID)
|
|
PERP = SQRT ((COOR (1, IP2)-COOR (1, IP1)) **2+ (COOR (2, IP2)-
|
|
& COOR (2, IP1)) **2) * SQRT ((COOR (1, IP3)-XMID) **2
|
|
& + (COOR (2, IP3) - YMID) **2)
|
|
IF (DOT.GE.0.05 * PERP) THEN
|
|
WRITE (*, 10020)ILINE (IL)
|
|
ERR = .TRUE.
|
|
RETURN
|
|
ENDIF
|
|
|
|
C GET TRANSFORMATION TO PARABOLA COORDINATE SYSTEM (Y = 4AX **2)
|
|
|
|
HALFW = SQRT ((COOR (1, IP2)-COOR (1, IP1)) **2 +
|
|
& (COOR (2, IP2) - COOR (2, IP1)) **2) *0.5
|
|
HEIGHT = SQRT ((XMID-COOR (1, IP3)) **2 +
|
|
& (YMID - COOR (2, IP3)) **2)
|
|
IF ((HEIGHT.EQ.0).OR. (HALFW.EQ.0.)) THEN
|
|
WRITE (*, 10030)ILINE (IL)
|
|
ERR = .TRUE.
|
|
RETURN
|
|
ENDIF
|
|
A = HEIGHT/ (HALFW **2)
|
|
XTOP = COOR (1, IP3)
|
|
YTOP = COOR (2, IP3)
|
|
THETA = ATAN2 (YMID-YTOP, XMID-XTOP)
|
|
SINT = SIN (THETA)
|
|
COST = COS (THETA)
|
|
IF (SINT.EQ.0.0) THEN
|
|
WRITE (*, 10040)ILINE (IL)
|
|
ERR = .TRUE.
|
|
RETURN
|
|
ENDIF
|
|
COTT = COST/SINT
|
|
|
|
C FIND THE EQUATION OF THE LINE FOR X = CONSTANT IN NEW COORDINATES
|
|
|
|
X0 = X-XTOP
|
|
B = - (SINT * X0)- (COTT * COST * X0)
|
|
|
|
C IF THE LINE HAS A ZERO SLOPE, THEN FIND THE SIMPLE SOLUTION
|
|
|
|
IF (COTT.EQ.0.0) THEN
|
|
YNEW = B
|
|
ELSE
|
|
DIVIS = 1.- (4. * COTT * A * B)
|
|
IF (DIVIS.LT.0.0) THEN
|
|
WRITE (*, 10050)ILINE (IL)
|
|
ERR = .TRUE.
|
|
RETURN
|
|
ENDIF
|
|
XDIVIS = SQRT (DIVIS)
|
|
Y1 = (1.+XDIVIS)/ (2. * COTT * A)
|
|
Y2 = (1.-XDIVIS)/ (2. * COTT * A)
|
|
IF ((ABS (Y1).LE.HALFW).AND. (ABS (Y2).GT.HALFW)) THEN
|
|
YNEW = Y1
|
|
ELSEIF ((ABS (Y2).LE.HALFW).AND. (ABS (Y1).GT.HALFW)) THEN
|
|
YNEW = Y2
|
|
ELSE
|
|
WRITE (*, 10060)ILINE (IL)
|
|
ENDIF
|
|
ENDIF
|
|
|
|
C TRANSLATE THIS XNEW TO A Y VALUE
|
|
|
|
XNEW = A * YNEW * YNEW
|
|
FRACT = (XNEW * SINT)+ (YNEW * COST)+YTOP
|
|
ENDIF
|
|
|
|
RETURN
|
|
|
|
10000 FORMAT (' POINTS GIVEN FOR LINE', I5, ' DO NOT DEFINE AN ARC')
|
|
10010 FORMAT (' NO X ON ARC LINE', I5, ' FOUND IN GETWT')
|
|
10020 FORMAT (' POINTS FOR LINE', I5, ' DOES NOT DEFINE A PARABOLA')
|
|
10030 FORMAT (' ZERO LINE LENGTH FOR PARABOLA LINE', I5, ' IN GETWT')
|
|
10040 FORMAT (' PARABOLA ALIGNMENT PROBLEMS FOR LINE', I5, ' IN GETWT')
|
|
10050 FORMAT (' PARABOLA INTERSECTION PROBLEMS FOR LINE', I5,
|
|
& ' IN GETWT')
|
|
10060 FORMAT (' PARABOLA SOLUTION PROBLEMS FOR LINE', I5, ' IN GETWT')
|
|
|
|
END
|
|
|