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.
361 lines
11 KiB
361 lines
11 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 DLINE (MP, ML, COOR, LINKP, KNUM, KT, IP1, IP2, IP3,
|
|
& NUMPLT, X1, Y1, TEST, GETMAX, XMIN, XMAX, YMIN, YMAX)
|
|
C***********************************************************************
|
|
|
|
C SUBROUTINE DLINE = DRAWS A LINE ACCORDING TO THE CURRENT DEFINITION
|
|
C OR SIMPLY GETS THE MAX/MIN FOR LINES GETMAX=.TRUE.
|
|
|
|
C***********************************************************************
|
|
|
|
C VARIABLES USED:
|
|
C IP1 = POINTER FOR THE FIRST POINT
|
|
C IP2 = POINTER FOR THE SECOND POINT
|
|
C IP3 = POINTER FOR THE THIRD POINT
|
|
|
|
C***********************************************************************
|
|
|
|
DIMENSION COOR (2, MP), LINKP (2, MP)
|
|
|
|
CHARACTER*72 DUMMY
|
|
|
|
LOGICAL NUMPLT, ADDLNK, TEST, GETMAX, ERR
|
|
|
|
PI = ATAN2(0.0, -1.0)
|
|
|
|
IF (TEST)WRITE (12, 10000)'SP', KNUM, ';'
|
|
ADDLNK = .FALSE.
|
|
|
|
C DEFINE FIRST POINT EXACTLY AND BRANCH
|
|
|
|
CALL LTSORT (MP, LINKP, IP1, IPNTR1, ADDLNK)
|
|
CALL LTSORT (MP, LINKP, IP2, IPNTR2, ADDLNK)
|
|
IF ((IPNTR1 .LE. 0).OR. (IPNTR2 .LE. 0))GOTO 140
|
|
IF (IP3 .NE. 0) THEN
|
|
CALL LTSORT (MP, LINKP, IABS (IP3), IPNTR3, ADDLNK)
|
|
IF (IPNTR3 .LE. 0)GOTO 140
|
|
ELSE
|
|
IPNTR3 = 0
|
|
ENDIF
|
|
X1 = COOR (1, IPNTR1)
|
|
Y1 = COOR (2, IPNTR1)
|
|
|
|
C STRAIGHT LINE GENERATION
|
|
|
|
IF (KT .EQ. 1) THEN
|
|
X2 = COOR (1, IPNTR2)
|
|
Y2 = COOR (2, IPNTR2)
|
|
IF (GETMAX) THEN
|
|
XMAX = AMAX1 (X1, X2, XMAX)
|
|
YMAX = AMAX1 (Y1, Y2, YMAX)
|
|
XMIN = AMIN1 (X1, X2, XMIN)
|
|
YMIN = AMIN1 (Y1, Y2, YMIN)
|
|
GOTO 140
|
|
ENDIF
|
|
XMID = (X1 + X2) * .5
|
|
YMID = (Y1 + Y2) * .5
|
|
|
|
C CORNER GENERATION
|
|
|
|
ELSEIF (KT .EQ. 2) THEN
|
|
X2 = COOR (1, IPNTR3)
|
|
Y2 = COOR (2, IPNTR3)
|
|
IF (GETMAX) THEN
|
|
XMAX = AMAX1 (X1, X2, COOR (1, IPNTR2), XMAX)
|
|
YMAX = AMAX1 (Y1, Y2, COOR (2, IPNTR2), YMAX)
|
|
XMIN = AMIN1 (X1, X2, COOR (1, IPNTR2), XMIN)
|
|
YMIN = AMIN1 (Y1, Y2, COOR (2, IPNTR2), YMIN)
|
|
GOTO 140
|
|
ENDIF
|
|
IF (TEST)WRITE (12, 10010)
|
|
& 'PU;PA', INT (X1 * 1000.), ', ',
|
|
& INT (Y1 * 1000.), ';PD;PA',
|
|
& INT (X2 * 1000.), ', ', INT (Y2 * 1000.), ';'
|
|
CALL MPD2VC (1, X1, Y1, X2, Y2)
|
|
XMID = X1 + ((X2 - X1) * .25)
|
|
YMID = Y1 + ((Y2 - Y1) * .25)
|
|
X1 = X2
|
|
Y1 = Y2
|
|
X2 = COOR (1, IPNTR2)
|
|
Y2 = COOR (2, IPNTR2)
|
|
|
|
C CIRCULAR ARC GENERATION
|
|
|
|
ELSEIF ((KT .EQ. 3).OR. (KT .EQ. 4).OR. (KT .EQ. 6)) THEN
|
|
CALL ARCPAR (MP, KT, KNUM, COOR, LINKP, IPNTR1, IPNTR2,
|
|
& IPNTR3, IP3, XCEN, YCEN, THETA1, THETA2, TANG, R1, R2, ERR,
|
|
& IDUM1, IDUM2, XK, XA)
|
|
IF (ERR) GOTO 140
|
|
|
|
C GENERATE THE CIRCLE
|
|
|
|
ANG = THETA1
|
|
DARC = .10
|
|
INC = INT (ABS (TANG) / DARC) + 1
|
|
IF (INC .LE. 6)INC = 6
|
|
DEL = TANG * (1.0 / DBLE(INC))
|
|
IEND = INC - 1
|
|
XK = (LOG (R2 / R1)) / (THETA2 - THETA1)
|
|
XA = R2 / EXP (XK * THETA2)
|
|
IF (GETMAX) THEN
|
|
XMAX = AMAX1 (X1, XMAX)
|
|
YMAX = AMAX1 (Y1, YMAX)
|
|
XMIN = AMIN1 (X1, XMIN)
|
|
YMIN = AMIN1 (Y1, YMIN)
|
|
ENDIF
|
|
DO 100 I = 1, IEND
|
|
ANG = ANG + DEL
|
|
RADIUS = XA * EXP (XK * ANG)
|
|
X2 = XCEN + COS (ANG) * RADIUS
|
|
Y2 = YCEN + SIN (ANG) * RADIUS
|
|
IF (GETMAX) THEN
|
|
XMAX = AMAX1 (X2, XMAX)
|
|
YMAX = AMAX1 (Y2, YMAX)
|
|
XMIN = AMIN1 (X2, XMIN)
|
|
YMIN = AMIN1 (Y2, YMIN)
|
|
ELSE
|
|
CALL MPD2VC (1, X1, Y1, X2, Y2)
|
|
ENDIF
|
|
IF (TEST)WRITE (12, 10010)
|
|
& 'PU;PA', INT (X1 * 1000.), ', ',
|
|
& INT (Y1 * 1000.), ';PD;PA',
|
|
& INT (X2 * 1000.), ', ', INT (Y2 * 1000.), ';'
|
|
X1 = X2
|
|
Y1 = Y2
|
|
IF (I .EQ. INC / 2) THEN
|
|
XMID = X1
|
|
YMID = Y1
|
|
ENDIF
|
|
100 CONTINUE
|
|
|
|
C ELIPSE GENERATION
|
|
|
|
ELSEIF (KT .EQ. 7) THEN
|
|
CALL ELPSPR (MP, KT, KNUM, COOR, LINKP, IPNTR1, IPNTR2, IPNTR3,
|
|
& IP3, XCEN, YCEN, THETA1, THETA2, TANG, IDUM1, IDUM2, AVALUE,
|
|
& BVALUE, ERR)
|
|
IF (ERR) GOTO 140
|
|
|
|
C GENERATE THE ELIPSE
|
|
|
|
IF (GETMAX) THEN
|
|
XMAX = AMAX1 (X1, XMAX)
|
|
YMAX = AMAX1 (Y1, YMAX)
|
|
XMIN = AMIN1 (X1, XMIN)
|
|
YMIN = AMIN1 (Y1, YMIN)
|
|
ENDIF
|
|
DARC = .10
|
|
INC = MAX0 (INT (ABS (TANG) / DARC) + 1, 15)
|
|
DEL = TANG * (1.0 / DBLE(INC))
|
|
IEND = INC - 1
|
|
ANG = THETA1
|
|
DO 110 I = 1, IEND
|
|
ANG = ANG + DEL
|
|
RADIUS = SQRT ( (AVALUE **2 * BVALUE **2) /
|
|
& ( (BVALUE **2 * COS (ANG) **2) +
|
|
& (AVALUE **2 * SIN (ANG) **2) ) )
|
|
X2 = XCEN + COS (ANG) * RADIUS
|
|
Y2 = YCEN + SIN (ANG) * RADIUS
|
|
IF (GETMAX) THEN
|
|
XMAX = AMAX1 (X2, XMAX)
|
|
YMAX = AMAX1 (Y2, YMAX)
|
|
XMIN = AMIN1 (X2, XMIN)
|
|
YMIN = AMIN1 (Y2, YMIN)
|
|
ELSE
|
|
CALL MPD2VC (1, X1, Y1, X2, Y2)
|
|
ENDIF
|
|
IF (TEST)WRITE (12, 10010)
|
|
& 'PU;PA', INT (X1 * 1000.), ', ',
|
|
& INT (Y1 * 1000.), ';PD;PA',
|
|
& INT (X2 * 1000.), ', ', INT (Y2 * 1000.), ';'
|
|
X1 = X2
|
|
Y1 = Y2
|
|
IF (I .EQ. INC / 2) THEN
|
|
XMID = X1
|
|
YMID = Y1
|
|
ENDIF
|
|
110 CONTINUE
|
|
|
|
C PARABOLA
|
|
|
|
ELSEIF (KT .EQ. 5) THEN
|
|
N = 50
|
|
FAC = 1.
|
|
DFF = .02
|
|
|
|
C CHECK LEGITIMACY OF DATA
|
|
|
|
XMID = (COOR (1, IPNTR1) + COOR (1, IPNTR2)) * 0.5
|
|
YMID = (COOR (2, IPNTR1) + COOR (2, IPNTR2)) * 0.5
|
|
DOT = (COOR (1, IPNTR2) - COOR (1, IPNTR1)) *
|
|
& (COOR (1, IPNTR3) - XMID) + (COOR (2, IPNTR2) -
|
|
& COOR (2, IPNTR1)) * (COOR (2, IPNTR3) - YMID)
|
|
PERP = SQRT ((COOR (1, IPNTR2) - COOR (1, IPNTR1)) **2 +
|
|
& (COOR (2, IPNTR2) - COOR (2, IPNTR1)) **2) *
|
|
& SQRT ((COOR (1, IPNTR3) - XMID) **2 +
|
|
& (COOR (2, IPNTR3) - YMID) **2)
|
|
IF (DOT .GE. 0.05 * PERP) THEN
|
|
CALL PLTFLU
|
|
WRITE (*, 10040)KNUM
|
|
GOTO 140
|
|
ENDIF
|
|
IF (GETMAX) THEN
|
|
XMAX = AMAX1 (X1, XMAX)
|
|
YMAX = AMAX1 (Y1, YMAX)
|
|
XMIN = AMIN1 (X1, XMIN)
|
|
YMIN = AMIN1 (Y1, YMIN)
|
|
ENDIF
|
|
|
|
C GET ARC LENGTH
|
|
|
|
HALFW = SQRT ((COOR (1, IPNTR2) - COOR (1, IPNTR1)) **2 +
|
|
& (COOR (2, IPNTR2) - COOR (2, IPNTR1)) **2) * 0.5
|
|
IF (HALFW .EQ. 0.) THEN
|
|
CALL PLTFLU
|
|
WRITE (*, 10020)KNUM
|
|
GOTO 140
|
|
ENDIF
|
|
HEIGHT = SQRT ((XMID - COOR (1, IPNTR3)) **2 + (YMID -
|
|
& COOR (2, IPNTR3)) **2)
|
|
COEF = HEIGHT / HALFW **2
|
|
TCOEF = 2.0 * COEF
|
|
|
|
C PARC IS A STATEMENT FUNCTION
|
|
|
|
PLEFT = PARC ( - TCOEF * HALFW, TCOEF)
|
|
ARCTOT = 2.0 * PARC (TCOEF * HALFW, TCOEF)
|
|
ARCDEL = DFF * ARCTOT
|
|
ARCNXT = ARCDEL
|
|
ARCNOW = 0.0
|
|
THETA = ATAN2 (COOR (2, IPNTR2) - COOR (2, IPNTR1),
|
|
& COOR (1, IPNTR2) - COOR (1, IPNTR1))
|
|
|
|
C CORRECT FOR ORIENTATION
|
|
|
|
CROSS = (COOR (1, IPNTR3) - XMID) * (COOR (2, IPNTR2) -
|
|
& COOR (2, IPNTR1)) - (COOR (2, IPNTR3) - YMID) *
|
|
& (COOR (1, IPNTR2) - COOR (1, IPNTR1))
|
|
IF (CROSS .LT. 0.0)THETA = THETA + PI
|
|
SINT = SIN (THETA)
|
|
COST = COS (THETA)
|
|
|
|
C FIND POINTS APPROXIMATELY BY INTEGRATION
|
|
|
|
XL = - HALFW
|
|
FL = SQRT (1.0 + (TCOEF * XL) **2)
|
|
KOUNT = 1
|
|
DELX = 2.0 * HALFW / 200.0
|
|
DO 120 I = 1, 100
|
|
FM = SQRT (1.0 + (TCOEF * (XL + DELX)) **2)
|
|
XR = - HALFW + DBLE(I) * 2.0 * DELX
|
|
FR = SQRT (1.0 + (TCOEF * XR) **2)
|
|
ARCOLD = ARCNOW
|
|
ARCNOW = ARCNOW + DELX * (FL + 4.0 * FM + FR) / 3.0
|
|
IF (ARCNOW .GE. ARCNXT) THEN
|
|
|
|
C COMPUTE POSITION IN LOCAL COORDINATE SYSTEM
|
|
|
|
FRAC = (ARCNXT - ARCOLD) / (ARCNOW - ARCOLD)
|
|
XK = XL + FRAC * 2.0 * DELX
|
|
YK = COEF * XK **2
|
|
|
|
C CORRECT FOR ORIENTATION PROBLEM
|
|
|
|
IF (CROSS .LT. 0.0)XK = - XK
|
|
|
|
C ROTATE IN LINE WITH GLOBAL COORDINATE SYSTEM
|
|
|
|
ROTX = XK * COST - YK * SINT
|
|
ROTY = YK * COST + XK * SINT
|
|
|
|
C RESTORE XK
|
|
|
|
IF (CROSS .LT. 0.0)XK = - XK
|
|
|
|
C TRANSLATE
|
|
|
|
KOUNT = KOUNT + 1
|
|
X2 = ROTX + COOR (1, IPNTR3)
|
|
Y2 = ROTY + COOR (2, IPNTR3)
|
|
IF (TEST)WRITE (12, 10010)
|
|
& 'PU;PA', INT (X1 * 1000.), ', ',
|
|
& INT (Y1 * 1000.), ';PD;PA',
|
|
& INT (X2 * 1000.), ', ', INT (Y2 * 1000.), ';'
|
|
IF (GETMAX) THEN
|
|
XMAX = AMAX1 (X2, XMAX)
|
|
YMAX = AMAX1 (Y2, YMAX)
|
|
XMIN = AMIN1 (X2, XMIN)
|
|
YMIN = AMIN1 (Y2, YMIN)
|
|
ELSE
|
|
CALL MPD2VC (1, X1, Y1, X2, Y2)
|
|
ENDIF
|
|
X1 = X2
|
|
Y1 = Y2
|
|
|
|
C PREPARE FOR NEXT POINT
|
|
|
|
IF (KOUNT .GE. N - 1)GOTO 130
|
|
ARCDEL = ARCDEL * FAC
|
|
ARCNXT = ARCNXT + ARCDEL
|
|
|
|
C RESTART INTEGRATION
|
|
|
|
XR = XK
|
|
FR = SQRT (1.0 + (TCOEF * XR) **2)
|
|
|
|
C CORRECT FOR INTEGRATION ERROR
|
|
|
|
ARCNOW = PARC (TCOEF * XR, TCOEF) - PLEFT
|
|
ENDIF
|
|
XL = XR
|
|
FL = FR
|
|
120 CONTINUE
|
|
130 CONTINUE
|
|
XMID = COOR (1, IPNTR3)
|
|
YMID = COOR (2, IPNTR3)
|
|
ENDIF
|
|
|
|
C NORMAL EXIT
|
|
C DEFINE LAST POINT EXACTLY
|
|
|
|
X2 = COOR (1, IPNTR2)
|
|
Y2 = COOR (2, IPNTR2)
|
|
IF (GETMAX) THEN
|
|
XMAX = AMAX1 (X2, XMAX)
|
|
YMAX = AMAX1 (Y2, YMAX)
|
|
XMIN = AMIN1 (X2, XMIN)
|
|
YMIN = AMIN1 (Y2, YMIN)
|
|
GOTO 140
|
|
ENDIF
|
|
IF (TEST)WRITE (12, 10010)
|
|
& 'PU;PA', INT (X1 * 1000.), ', ',
|
|
& INT (Y1 * 1000.), ';PD;PA',
|
|
& INT (X2 * 1000.), ', ', INT (Y2 * 1000.), ';'
|
|
CALL MPD2VC (1, X1, Y1, X2, Y2)
|
|
CALL PLTFLU
|
|
|
|
C PLOT THE LINE NUMBER IF DESIRED
|
|
|
|
IF (KNUM .GT. 0) THEN
|
|
CALL MP2PT (1, XMID, YMID, X1, Y1, MASK)
|
|
IF ((MOD (MASK, 2) .NE. 0).AND. (NUMPLT)) THEN
|
|
CALL GETDUM (KNUM, DUMMY, LEN)
|
|
CALL PLTXTH (X1, Y1, DUMMY (1:LEN))
|
|
ENDIF
|
|
ENDIF
|
|
|
|
140 CONTINUE
|
|
|
|
RETURN
|
|
|
|
10000 FORMAT (A2, I6, A1)
|
|
10010 FORMAT (A5, I10, A1, I10, A6, I10, A1, I10, A1)
|
|
10020 FORMAT (' ZERO LINE LENGTH ENCOUNTERED FOR LINE', I5)
|
|
10040 FORMAT (' POINTS GIVEN FOR LINE', I5, ' DO NOT DEFINE A PARABOLA')
|
|
|
|
END
|
|
|