F 13.2 Renner Subsplines
SUBROUTINE RENN2D (N,XN,YN,NK,BETA,B,C,D,T,HELP,IMARK,IERR)
C
C*****************************************************************
C *
C The programm RENN2D computes the coefficient vectors B, C and *
C D, as well as the lengths T(I) of the parameter intervals of *
C a closed or open 2-dimensional parametric Renner spline. *
C The subsplines are represented in vector form: *
C *
C [X(T)]=[PIX(T)]=[XN(I)+B(I,1)*T+C(I,1)*T**2+D(I,1)*T**3] *
C [Y(T)]=[PIY(T)]=[YN(I)+B(I,2)*T+C(I,2)*T**2+D(I,2)*T**3] *
C *
C for I=0, ..., N-1 and T a point in the interval [0, T(I)]. *
C *
C *
C ASSUMPTIONS: *
C ============ 1. N >= 4 or NK >= 4 *
C 2. If 0.0 < BETA < 1.0: we must have *
C NK >= N + INT((N+1)/2); otherwise NK = N *
C 2. The node (XN(I), FN(I)) cannot be equal to *
C (XN(I+1),FN(I+1)) for all I = 0, ..., N-1 *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C N : Index of the last node *
C XN : DOUBLE PRECISION (NK+1)-vector XN(0:NK), containing *
C the x-coordinates XN(I) of the nodes for I=0,..., N *
C YN : DOUBLE PRECISION (NK+1)-vector YN(0:NK), containing *
C the y-coordinates YN(I) of the nodes for I=0,..., N *
C NK : NK = N + INT((N+1)/2), the maximal number of nodes *
C when using rounded corners, *
C i.e. for 0.0 < BETA < 1.0. *
C Without rounding of corners we must have: NK = N. *
C BETA : for 0.0 < BETA < 1.0 corners are rounded; otherwise *
C corners are kept as corners *
C *
C *
C AUXILIARY PARAMETERS: *
C ===================== *
C HELP : DOUBLE PRECISION array HELP(-2:NK+1,1:10) *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C N : Index of the last node. If 0.0 < BETA < 1.0 , then *
C the output value for N can differ from its input. *
C When corners are rounded, the node list can be en- *
C larged by at most INT((N+1)/2) points. *
C T : DOUBLE PRECISION NK-vector T(0:NK-1),] nodes *
C containing the parameter values ] and *
C XN : DOUBLE PRECISION vector XN(0:NK) ] coefficients *
C YN : DOUBLE PRECISION vector YN(0:NK) ] of the *
C B : DOUBLE PRECISION array B(0:NK-1,1:2) ] subsplines *
C C : DOUBLE PRECISION array C(0:NK-1,1:2) ] for *
C D : DOUBLE PRECISION array D(0:NK-1,1:2) ] I=0, ...,N-1.*
C If 0.0 < BETA < 1.0, then the nodes XN(I) and FN(I) *
C can be different from their input values for I=0,...*
C ..., N *
C *
C IMARK : Pointer *
C = 0, Subspline is not closed *
C = 1, Subspline is closed *
C *
C IERR : Error parameter *
C = 0, all is ok *
C = -1, N < 4 or NK < 4 *
C = -2, the assumption *
C (XN(I), FN(I)) not equal to (XN(I+1), FN(I+1)) *
C is violated for some I=0, ..., N-1 *
C = -3, NK < N+INT((N+1)/2) while 0.0 < BETA < 1.0 *
C *
C----------------------------------------------------------------*
C *
C Required subroutines: MACHPD *
C *
C*****************************************************************
C *
C Author : Gisela Engeln-Muellges *
C Date : 3.29.1993 *
C Source code: FORTRAN 77 *
C *
C*****************************************************************
C
C Declarations
C
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
DOUBLE PRECISION XN(0:NK), YN(0:NK), B(0:NK-1, 1:2),
+ C(0:NK-1, 1:2), D(0:NK-1, 1:2), T(0:NK-1),
+ HELP(-2:NK+1, 1:10)
C
C Check input parameters
C
IERR = 0
IF (N .LT. 4 .OR. NK .LT. 4) THEN
IERR = -1
RETURN
ENDIF
IF (BETA .GT. 0.0D0 .AND. BETA .LT. 1.0D0 .AND.
F NK .LT. N+INT(0.5D0*(N+1))) THEN
IERR = -3
RETURN
ENDIF
C
C Compute the machine constant
C
FMACHP = 1.0D0
5 FMACHP = 0.5D0 * FMACHP
IF (MACHPD(1.0D0+FMACHP) .EQ. 1) GOTO 5
FMACHP = 2.0D0 * FMACHP
EPS = 4.0D0 * FMACHP
C
C Calculate the chordal vectors; store their first and second coordinates
C in the first and second column of the auxiliary array HELP,
C the third column of HELP contains the length of these chordal vectors.
C
DO 10, I = 0, N-1
HELP(I, 1) = XN(I+1) - XN(I)
HELP(I, 2) = YN(I+1) - YN(I)
HELP(I, 3) = DSQRT(HELP(I, 1) * HELP(I, 1) +
F HELP(I, 2) * HELP(I, 2))
C
C We check that all chordal vectors are nonzero, thus
C verifying that consecutive nodes are distinct.
C
IF (HELP(I, 3) .LE. EPS) THEN
IERR = -2
RETURN
ELSE
C
C Columns 4 and 5 of HELP contain the first two components
C of the chordal unit vectors
C
HELP(I,4) = HELP(I,1)/HELP(I,3)
HELP(I,5) = HELP(I,2)/HELP(I,3)
ENDIF
10 CONTINUE
C
C We compute the area of the parellelograms generated by two
C consecutive chordal vectors (magnitude of their determinant)
C and store the results in column 6 of the auxiliary array HELP
C
DO 20, I = 0, N-2
HELP(I, 6) = DABS(HELP(I, 4) * HELP(I+1, 5) -
F HELP(I, 5) * HELP(I+1, 4))
20 CONTINUE
C
C Determine whether the curve is closed or not
C
IMARK = 0
IF (DABS(XN(0) - XN(N)) .LE. EPS .AND.
F DABS(YN(0) - YN(N)) .LE. EPS) THEN
IMARK = 1
ENDIF
C
C If 0.0 < BETA < 1.0, we round corners if such exist
C
IF (BETA .GT. 0.0D0 .AND. BETA .LT. 1.0D0 ) THEN
IF(IMARK .EQ. 1) THEN
C
C Curve closed
C
XL = HELP(N-2,6) + HELP(0,6)
XR = DABS(HELP(N-1,4)*HELP(0,5) - HELP(0,4)*HELP(N-1,5))
C
C Condition for a corner
C
IF(XL .LE. EPS .AND. XR .GT. EPS) THEN
C
C Relabel points
C
DO 30, I = 0,N-1
XN(I) = XN(I+1)
YN(I) = YN(I+1)
30 CONTINUE
XN(N) = XN(0)
YN(N) = YN(0)
C
C Relabel chordal vectors, their lengths, and the unit chordal vectors
C
DO 40, K = 1,5
HELP(N,K) = HELP(0,K)
40 CONTINUE
DO 50, I = 0, N-1
DO 60, K = 1,5
HELP(I,K) = HELP(I+1,K)
60 CONTINUE
50 CONTINUE
C
C Relabel areas
C
DO 70, I = 0,N-3
HELP(I,6) = HELP(I+1,6)
70 CONTINUE
HELP(N-2,6) = DABS(HELP(N-2,4)
F *HELP(N-1,5) - HELP(N-1,4) * HELP(N-2,5))
ENDIF
C
C Prepare loop
C
I = 1
IMAX = N - 1
HELP(-1,6) = DABS(HELP(N-1,4)*
F HELP(0,5) - HELP(0,4) * HELP(N-1,5))
HELP(N-1,6) = HELP(-1,6)
ELSE
C
C Curve is not closed
C
C
C Prepare loop
C
I = 2
IMAX = N-2
ENDIF
\hbox{\JDhspace\verb`
75 XL = HELP(I-2,6) + HELP(I,6)
XR = HELP(I-1,6)
C
C Round existing corners
C
IF(XL .LE. EPS .AND. XR .GT. EPS) THEN
C
C Shift index for points I to N
C
DO 80, J = N,I,-1
XN(J+1) = XN(J)
YN(J+1) = YN(J)
80 CONTINUE
\hbox{\JDhspace\verb`
C
C Relabel chordal vectors, their length, and chordal unit vectors
C for I to N-1
C
DO 90, J = N-1,I,-1
DO 100, K = 1,5
HELP(J+1,K) = HELP(J,K)
100 CONTINUE
90 CONTINUE
C
C Relabel areas indexed I to IMAX
C
DO 110, J = IMAX,I,-1
HELP(J+1,6) = HELP(J,6)
110 CONTINUE
C
C Create two new points I and I+1
C
XL = HELP(I-1,3)
XR = HELP(I+1,3)
XB = BETA * DMIN1(XL,XR)
XLAMDA = XB/XL
XMUE = XB/XR
XN(I) = XN(I) - XLAMDA*HELP(I-1,1)
YN(I) = YN(I) - XLAMDA*HELP(I-1,2)
XN(I+1) = XN(I+1) + XMUE*HELP(I+1,1)
YN(I+1) = YN(I+1) + XMUE*HELP(I+1,2)
C
C Recompute the new chordal vectors, their length, and the corresponding
C unit vectors for the three points I-1, I, I+1 and store
C
DO 120, J = I-1,I+1
HELP(J,1) = XN(J+1)-XN(J)
HELP(J,2) = YN(J+1)-YN(J)
HELP(J,3) = DSQRT(HELP(J,1) *
F HELP(J,1) + HELP(J,2) * HELP(J,2))
HELP(J,4) = HELP(J,1)/HELP(J,3)
HELP(J,5) = HELP(J,2)/HELP(J,3)
120 CONTINUE
C
C Recompute the areas for I-2, I-1, I, I+1
C
DO 130, J = I-2, I+1
HELP(J,6) = DABS(HELP(J,4) *
F HELP(J+1,5) - HELP(J+1,4) * HELP(J,5))
130 CONTINUE
C
C Increase point count
C
N = N+1
IMAX = IMAX + 1
ENDIF
C
C Set index for next point
C
I = I + 1
IF(I .LE. IMAX) GOTO 75
ENDIF
\hbox{\JDhspace\verb`
IF( IMARK .EQ. 1) THEN
C
C Curve is closed
C
C
C Prepare additional chordal vectors, lengths, unit chordal vectors
C for the four points -2, -1, N, N+1 and store
C
DO 140, I = N-2, N-1
DO 150 K = 1,5
HELP(I-N,K) = HELP(I,K)
150 CONTINUE
140 CONTINUE
DO 160, I = 0,1
DO 170 K = 1,5
HELP(I+N,K) = HELP(I,K)
170 CONTINUE
160 CONTINUE
ELSE
C
C Curve is not closed
C
DO 180, K = 1,2
HELP(-2,K) = 3.0D0 * HELP(0,K) -2.0D0 * HELP(1,K)
HELP(-1,K) = 2.0D0 * HELP(0,K) - HELP(1,K)
180 CONTINUE
C
C Compute additional chordal vectors, length, and unit chordal vectors
C for the 4 points -2, -1, N, N+1 and store
C
DO 190, I = -2,-1
HELP(I,3) = DSQRT(HELP(I,1) * HELP(I,1) +
F HELP(I,2) * HELP(I,2))
IF(HELP(I,3) .GT. EPS) THEN
HELP(I,4) = HELP(I,1)/HELP(I,3)
HELP(I,5) = HELP(I,2)/HELP(I,3)
ELSE
HELP(I,4) = 0.0D0
HELP(I,5) = 0.0D0
ENDIF
190 CONTINUE
DO 200, K = 1,2
HELP(N,K) = 2.0D0 * HELP(N-1,K) - HELP(N-2,K)
HELP(N+1,K) = 3.0D0 * HELP(N-1,K) - 2.0D0 * HELP(N-2,K)
200 CONTINUE
DO 210, I = N,N+1
HELP(I,3) = DSQRT(HELP(I,1) * HELP(I,1) +
F HELP(I,2) * HELP(I,2))
IF(HELP(I,3) .GT. EPS) THEN
HELP(I,4) = HELP(I,1)/HELP(I,3)
HELP(I,5) = HELP(I,2)/HELP(I,3)
ELSE
HELP(I,4) = 0.0D0
HELP(I,5) = 0.0D0
ENDIF
210 CONTINUE
ENDIF
C
C Compute additional areas at -2, -1, N-1, N
C
DO 220, I = -2, -1
HELP(I,6) = DABS(HELP(I,4) * HELP(I+1,5)
F - HELP(I+1,4) * HELP(I,5))
220 CONTINUE
DO 230, I = N-1, N
HELP(I,6) = DABS(HELP(I,4) * HELP(I+1,5)
F - HELP(I+1,4) * HELP(I,5))
230 CONTINUE
C
C Compute the left and right hand unit tangent vectors and
C store in columns 7, 8, and 9, 10 of HELP, respectively
C
DO 240, I = 0,N
XL = HELP(I-2,6)
XR = HELP(I,6)
IF(XL + XR .GT. EPS) THEN
ALPHA = XL/(XL + XR)
DO 250 K = 1,2
HELP(I,K+6) = HELP(I-1,K) +
F ALPHA * (HELP(I,K) - HELP(I-1,K))
250 CONTINUE
HELPT = DSQRT(HELP(I,7) * HELP(I,7) + HELP(I,8) * HELP(I,8))
HELP(I,7) = HELP(I,7)/HELPT
HELP(I,8) = HELP(I,8)/HELPT
HELP(I,9) = HELP(I,7)
HELP(I,10) = HELP(I,8)
ELSE
DO 260, K =4,5
HELP(I,K+3) = HELP(I-1,K)
HELP(I,K+5) = HELP(I,K)
260 CONTINUE
ENDIF
240 CONTINUE
DO 270, I = 0,N-1
C
C Compute the parameter interval lengths
C
TS1 = HELP(I,9) + HELP(I+1,7)
TS2 = HELP(I,10) + HELP(I+1,8)
A1 = 16.0D0 - (TS1*TS1 + TS2*TS2)
B1 = 6.0D0 * (HELP(I,1)*TS1 + HELP(I,2)*TS2)
C1 = 36.0D0 * HELP(I,3) * HELP(I,3)
T(I) = (-B1+DSQRT(B1*B1 + A1*C1))/A1
HELPT = 1.0D0/T(I)
C
C Compute spline coefficient vectors
C
DO 280, K = 1,2
B(I,K) = HELP(I,K+8)
C(I,K) = (3.0D0 * HELPT * HELP(I,K) -
F 2.0D0 * B(I,K) - HELP(I+1,K+6)) * HELPT
D(I,K) = ( B(I,K) + HELP(I+1,K+6) -
F 2.0D0 * HELPT *HELP(I,K)) * HELPT * HELPT
280 CONTINUE
270 CONTINUE
RETURN
END