| 12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273 |
- *DECK DFSPVD
- SUBROUTINE DFSPVD (T, K, X, ILEFT, VNIKX, NDERIV)
- C***BEGIN PROLOGUE DFSPVD
- C***SUBSIDIARY
- C***PURPOSE Subsidiary to DFC
- C***LIBRARY SLATEC
- C***TYPE DOUBLE PRECISION (BSPLVD-S, DFSPVD-D)
- C***AUTHOR (UNKNOWN)
- C***DESCRIPTION
- C
- C **** Double Precision Version of BSPLVD ****
- C Calculates value and deriv.s of all B-splines which do not vanish at X
- C
- C Fill VNIKX(J,IDERIV), J=IDERIV, ... ,K with nonzero values of
- C B-splines of order K+1-IDERIV , IDERIV=NDERIV, ... ,1, by repeated
- C calls to DFSPVN
- C
- C***SEE ALSO DFC
- C***ROUTINES CALLED DFSPVN
- C***REVISION HISTORY (YYMMDD)
- C 780801 DATE WRITTEN
- C 890531 Changed all specific intrinsics to generic. (WRB)
- C 890831 Modified array declarations. (WRB)
- C 890911 Removed unnecessary intrinsics. (WRB)
- C 891214 Prologue converted to Version 4.0 format. (BAB)
- C 900328 Added TYPE section. (WRB)
- C***END PROLOGUE DFSPVD
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- DIMENSION T(*),VNIKX(K,*)
- DIMENSION A(20,20)
- C***FIRST EXECUTABLE STATEMENT DFSPVD
- CALL DFSPVN(T,K+1-NDERIV,1,X,ILEFT,VNIKX(NDERIV,NDERIV))
- IF (NDERIV .LE. 1) GO TO 99
- IDERIV = NDERIV
- DO 15 I=2,NDERIV
- IDERVM = IDERIV-1
- DO 11 J=IDERIV,K
- 11 VNIKX(J-1,IDERVM) = VNIKX(J,IDERIV)
- IDERIV = IDERVM
- CALL DFSPVN(T,0,2,X,ILEFT,VNIKX(IDERIV,IDERIV))
- 15 CONTINUE
- C
- DO 20 I=1,K
- DO 19 J=1,K
- 19 A(I,J) = 0.D0
- 20 A(I,I) = 1.D0
- KMD = K
- DO 40 M=2,NDERIV
- KMD = KMD-1
- FKMD = KMD
- I = ILEFT
- J = K
- 21 JM1 = J-1
- IPKMD = I + KMD
- DIFF = T(IPKMD) - T(I)
- IF (JM1 .EQ. 0) GO TO 26
- IF (DIFF .EQ. 0.D0) GO TO 25
- DO 24 L=1,J
- 24 A(L,J) = (A(L,J) - A(L,J-1))/DIFF*FKMD
- 25 J = JM1
- I = I - 1
- GO TO 21
- 26 IF (DIFF .EQ. 0.) GO TO 30
- A(1,1) = A(1,1)/DIFF*FKMD
- C
- 30 DO 40 I=1,K
- V = 0.D0
- JLOW = MAX(I,M)
- DO 35 J=JLOW,K
- 35 V = A(I,J)*VNIKX(J,M) + V
- 40 VNIKX(I,M) = V
- 99 RETURN
- END
|
