End of file
Contents
Index



F 10.2.2 Non-Parametric Hermite Splines


      SUBROUTINE HERMIT (N,MARG,X,Y,Y1,BC1,BCN,IREP,A,B,C,D,E,F,
     1                 IERR,H,SUPER,AINFER,PRAEC,DEXT,AR1,AR2,AR3)
C
C*****************************************************************
C                                                                *
C     HERMIT computes the coefficients of a hermite polynomial   *
C     spline of fifth degree.                                    *
C                                                                *
C     NOTE: If several splines are to be computed for the same   *
C           nodes X(I), but for different function values Y(I)   *
C           or derivaltives Y1(I), then the user must set IREP=1 *
C           for the second, third, ... call of HERMIT. In this   *
C           setting the formation and transformation of the      *
C           matrix is not repeated and thus one saves ca 4N      *
C           operations in each case.                             *
C           This occurs naturally when computing parametric      *
C           splines, see SUBROUTINE PARMIT.                      *
C                                                                *
C                                                                *
C     INPUT PARAMETERS:                                          *
C     =================                                          *
C     N       number of nodes X(I)                               *
C     MARG    index for the endpoint condition:                  *
C               MARG = 1 : Periodic spline                       *
C               MARG = 2 : Natural spline                        *
C               MARG = 3 : User specified second derivatives at  *
C                          the end points                        *
C                          In this case the program expects that *
C                           2    2                               *
C                          D Y/DX ( X(1) )  is in BC1  and       *
C                           2    2                               *
C                          D Y/DX ( X(N) )  in BCN.              *
C               MARG = 4 : The user specifies the curvature radii*
C                          R1, RN of the spline at the end points*
C                          In this case the program expects      *
C                          R1 in BC1    and    RN in BCN.        *
C                          Re. concavity : If the radius is      *
C                          positive, the curvature circle is     *
C                          centered above the spline and the     *
C                          curve is concave up. For a negative   *
C                          radius the curve will be concave down.*
C               MARG = 5 : The user specifies the third end point*
C                          derivatives.                          *
C                          In this case the program expects      *
C                           3    3                               *
C                          D Y/DX  ( X(1) )  in BC1  and         *
C                           3    3                               *
C                          D Y/DX  ( X(N) )  in BCN.             *
C     X       vector X(1:N); the nodes X(1),...,X(N),,,,,        *
C     Y       vector Y(1:N); the given functional values         *
C                            Y(1),...,Y(N)                       *
C     Y1      vector Y1(1:N); the given derivatives at the nodes *
C                             DY/DX( X(1) ), ..., DY/DX( X(N) )  *
C     BC1     )  end point conditions for MARG = 3,4 or 5 as     *
C     BCN     )  stipulated by  MARG. left blank for other values*
C             )  of MARG.                                        *
C     IREP    If IREP is not equal to 0, the program assumes that*
C             it is called repeatedly for the same nodes. The    *
C             system matrix is not recomputed in this case.      *
C                                                                *
C                                                                *
C     OUTPUT PARAMETERS:                                         *
C     ==================                                         *
C     A       )                                                  *
C     B       )  N-vectors ..(1:N);                              *
C     C       )  the coefficients of the spline polynomial       *
C     D       )                                                  *
C     E       )                                                  *
C     F       )                                                  *
C     IERR    error code                                         *
C               IERR = 0 : no error                              *
C               IERR > 0 : input error, no spline was computed.  *
C                          In detail:                            *
C               IERR = 1 : MARG < 1  or  MARG > 5                *
C               IERR = 2 : N < 3                                 *
C               IERR = 3 : X(I) not ordered monotonically        *
C               IERR = 4 : Periodic spline specified for non-    *
C                          periodic input:                       *
C                          Y(1).NE.Y(N)  or  Y1(1).NE.Y1(N)      *
C               MARG = 5 : One of the curvature radii is zero    *
C                                                                *
C                                                                *
C     AUXILIARY PARAMETERS:                                      *
C     =====================                                      *
C     H       ) auxiliary vectors ..(1:N);                       *
C     SUPER   ) for repeated calls with IREP = 1 these vectors   *
C     AINFER  ) (except DEXT) must not be altered between calls. *
C     PRAEC   )                                                  *
C     DEXT    )                                                  *
C     AR1     )                                                  *
C     AR2     )                                                  *
C     AR3     )                                                  *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  Subroutines required: CYCTR, CYCTRS, TRIDIG, FDEXT            *
C                                                                *
C*****************************************************************
C                                                                *
C  Author   : Elmar Pohl                                         *
C  Date     : 09.28.1985                                         *
C  Source   : FORTRAN 77                                         *
C                                                                *
C*****************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DOUBLE PRECISION A(N),B(N),C(N),D(N),E(N),F(N)
      DOUBLE PRECISION SUPER(N),DEXT(N),PRAEC(N),AINFER(N)
      DOUBLE PRECISION X(N),Y(N),Y1(N),H(N),AR1(N),AR2(N),AR3(N)
      DOUBLE PRECISION FDEXT
      IF(IREP .NE. 0) GOTO 4
      IERR=0
      IF(MARG .LT. 1 .OR. MARG .GT. 5) GOTO 501
      IF(N .LT. 3) GOTO 502
      NM1=N-1
      NM2=N-2
      NM3=N-3
      DO 3 I=1,NM1
           HI=X(I+1)-X(I)
           IF(HI .LE. 0.0D0) GOTO 503
           H(I)=HI
    3 CONTINUE
      H(N)=H(1)
      IF(MARG .NE. 4) GOTO2
      IF(BC1 .EQ. 0.0D0 .OR. BCN .EQ. 0.0D0) GOTO 505
    2 ALPHA=1.0D0
      IF(MARG .EQ. 5) ALPHA=8.0D0/9.0D0
      IF(N .NE. 3) GOTO 18
      PRAEC(1)=3.0D0*ALPHA*(1.0D0/H(1)+1.0D0/H(2))
      GOTO 7
   18 REC1=ALPHA/H(1)
      DO 8 I=1,NM3
           REC2=1.0D0/H(I+1)
           PRAEC(I)=3.0D0*(REC1+REC2)
           SUPER(I)=-REC2
           AINFER(I+1)=-REC2
           REC1=REC2
    8 CONTINUE
      PRAEC(NM2)=3.0D0*(1.0D0/H(NM2)+ALPHA/H(NM1))
    7 IF(MARG .NE. 1) GOTO 9
      REC1=1.0D0/H(NM1)
      REC2=1.0D0/H(1)
      PRAEC(NM1)=3.0D0*(REC1+REC2)
      AR2(1)=-REC2
      AINFER(NM1)=-REC1
      AR1(1)=-REC2
      SUPER(NM2)=-REC1
      IF(N .NE. 3) GOTO 9
      SUPER(1)=SUPER(1)-REC2
      AINFER(2)=AINFER(2)-REC2
      GOTO 9
    4 NM1=N-1
      NM2=N-2
    9 CONTINUE
      DO 6 I=1,N
           A(I)=Y(I)
           B(I)=Y1(I)
    6 CONTINUE
      IF(MARG .EQ. 1 .AND. (A(1) .NE. A(N) .OR.
     &                      B(1) .NE. B(N))) GOTO 504
      GOTO (101,101,103,104,105) MARG
  101 BETA1=0.0D0
      BETA2=0.0D0
      GOTO 200
  103 BETA1=0.5D0*BC1/H(1)
      BETA2=0.5D0*BCN/H(NM1)
      GOTO 200
  104 Y21=(1.0D0+B(1)*B(1))**1.5D0/BC1
      Y2N=(1.0D0+B(N)*B(N))**1.5D0/BCN
      BETA1=0.5D0*Y21/H(1)
      BETA2=0.5D0*Y2N/H(NM1)
      GOTO 200
  105 HSQ=H(1)*H(1)
      BETA1=10.0D0*(A(2)-A(1))/3.0D0/H(1)/HSQ-2.0D0*
     1          (2.0D0*B(2)+3.0D0*B(1))/3.0D0/HSQ-BC1/18.0D0
      HSQ=H(NM1)*H(NM1)
      BETA2=-10.0D0*(A(N)-A(NM1))/3.0D0/H(NM1)/HSQ
      BETA2=BETA2+2.0D0*(3.0D0*B(N)+2.0D0*B(NM1))/3.0D0/HSQ+BCN/18.0D0
  200 REC1=1.0D0/H(1)
      A1=A(1)
      A2=A(2)
      B1=B(1)
      B2=B(2)
      DO 10 I=1,NM2
            REC2=1.0D0/H(I+1)
            A3=A(I+2)
            B3=B(I+2)
            DEXT(I)=FDEXT(A1,A2,A3,B1,B2,B3,REC1,REC2)
            A1=A2
            A2=A3
            B1=B2
            B2=B3
            REC1=REC2
   10 CONTINUE
      DEXT(1)=DEXT(1)+BETA1
      DEXT(NM2)=DEXT(NM2)+BETA2
      IF(MARG .NE. 1) GOTO 17
      DEXT(NM1)=FDEXT(A1,A2,A(2),B1,B2,B(2),REC1,1.0D0/H(N))
      IF(N .NE. 3) GOTO 11
      CALL TRIDIG(2,DEXT,AINFER,SUPER,PRAEC,IREP
     1             ,C,ISING,AR1,AR2,AR3)
      GOTO 19
   11 IF(IREP .NE. 0) GOTO 22
      CALL CYCTR(NM1,AINFER,PRAEC,SUPER,AR1,AR2,DEXT,C,IERR1)
      GOTO 19
   22 CALL CYCTRS(NM1,AINFER,PRAEC,SUPER,AR1,AR2,DEXT,C)
   19 DO 14 I=1,NM1
            NMI=N-I
            C(NMI+1)=C(NMI)
   14 CONTINUE
      C(1)=C(N)
      GOTO 13
   17 CALL TRIDIG(NM2,DEXT,AINFER,SUPER,PRAEC,IREP
     1             ,C,ISING,AR1,AR2,AR3)
      DO 12 I=1,NM2
            NMI=N-I
            C(NMI)=C(NMI-1)
   12 CONTINUE
      GOTO (11,202,203,204,205) MARG
  202 C(1)=0.0D0
      C(N)=0.0D0
      GOTO 13
  203 C(1)=0.5D0*BC1
      C(N)=0.5D0*BCN
      GOTO 13
  204 C(1)=0.5D0*Y21
      C(N)=0.5D0*Y2N
      GOTO 13
  205 CONTINUE
      C(1)=H(1)*BETA1+C(2)/3.0D0
      C(N)=H(NM1)*BETA2+C(NM1)/3.0D0
   13 DO 15 I=1,NM1
            D(I)=10.0D0*(A(I+1)-A(I))/H(I)-2.0D0*(2.0D0*B(I+1)+
     &                                            3.0D0*B(I))
            D(I)=(D(I)/H(I)+C(I+1)-3.0D0*C(I))/H(I)
   15 CONTINUE
      D(N)=D(NM1)-(2.0D0*(B(N)-B(NM1))/H(NM1)-2.0D0*(C(N)+
     &                                               C(NM1)))/H(NM1)
      DO 16 I=1,NM1
            HI=H(I)
            E(I)=(0.5D0*(B(I+1)-B(I))/HI-C(I))/HI
            E(I)=(E(I)-0.25D0*(D(I+1)+5.0D0*D(I)))/HI
            F(I)=(((C(I+1)-C(I))/HI-3.0D0*D(I))/HI-
     &                              6.0D0*E(I))/HI/10.0D0
   16 CONTINUE
      RETURN
  501 IERR=1
      RETURN
  502 IERR=2
      RETURN
  503 IERR=3
      RETURN
  504 IERR=4
      RETURN
  505 IERR=5
      RETURN
      END
C
C

      DOUBLE PRECISION FUNCTION FDEXT (A1,A2,A3,B1,B2,B3,REC1,REC2)
C
C*****************************************************************
C                                                                *
C     Function routine needed for SUBROUTINE HERMIT.             *
C     FDEXT computes one element of the right hand side of the   *
C     system of equations.                                       *
C                                                                *
C*****************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      REC1SQ=REC1*REC1
      REC2SQ=REC2*REC2
      FDEXT=10.0D0*((A3-A2)*REC2*REC2SQ-(A2-A1)*REC1*REC1SQ)
      FDEXT=FDEXT+4.0D0*(B1*REC1SQ-1.5D0*(REC2SQ-REC1SQ)*B2-
     &                   B3*REC2SQ)
      RETURN
      END
C
C

      DOUBLE PRECISION FUNCTION HMTVAL (N,X0,A,B,C,D,E,F,X,OUTP)
C
C*****************************************************************
C                                                                *
C     HMTVAL evaluates functional values of a hermite spline of  *
C     fifth degree S(X) together with its first 5 derivatives at *
C     X=X0.                                                      *
C                                                                *
C     While one could use this program to make an equidistant    *
C     value table for the function for plotting, this is not     *
C     advised since HMTVAL performs an expensive interval search *
C     for each value. Moreover one would not normally want to    *
C     find all derivatives. For a table of values we recommend   *
C     programs like HMTAB instead.                               *
C                                                                *
C                                                                *
C     INPUT PARAMETERS:                                          *
C     =================                                          *
C     N       number of nodes X(I)                               *
C     X0      x-value whose function value is desired            *
C     A       )                                                  *
C     B       )  vectors ..(1:N);                                *
C     C       )  the coefficients of the polynomial spline       *
C     D       )                                                  *
C     E       )                                                  *
C     F       )                                                  *
C     X       vector X(1:N); the nodes  X(1), ..., X(N)          *
C                                                                *
C                                                                *
C     OUTPUT PARAMETERS:                                         *
C     ==================                                         *
C     OUTP    vector OUTP(1:5) for the derivatives:              *
C                        (K)                                     *
C             OUTP(K) = S    (X0)  for K = 1, ..., 5             *
C     HMTVAL functional value of the hermite spline of fifth     *
C            degree S(X).                                        *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  Subroutines required: none                                    *
C                                                                *
C*****************************************************************
C                                                                *
C  Author   : Elmar Pohl                                         *
C  Date     : 09.28.1985                                         *
C  Source   : FORTRAN 77                                         *
C                                                                *
C*****************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DOUBLE PRECISION X(N),A(N),B(N),C(N),D(N),E(N),F(N),OUTP(5)
      I=1
      K=N
    1 M=(I+K)/2
      IF (M .EQ. I) GOTO 5
         IF (X0 .LT. X(M)) GOTO 2
            I=M
            GOTO 1
    2       K=M
            GOTO 1
    5 X1=X0-X(I)
      HMTVAL=(((F(I)*X1+E(I))*X1+D(I))*X1+C(I))*X1+B(I)
      HMTVAL=HMTVAL*X1+A(I)
      OUTP(1)=((5.0D0*F(I)*X1+4.0D0*E(I))*X1+3.0D0*D(I))*X1+
     &                                       2.0D0*C(I)
      OUTP(1)=OUTP(1)*X1+B(I)
      OUTP(2)=((20.0D0*F(I)*X1+12.0D0*E(I))*X1+6.0D0*D(I))*X1+
     &                                         2.0D0*C(I)
      OUTP(3)=(60.0D0*F(I)*X1+24.0D0*E(I))*X1+6.0D0*D(I)
      OUTP(4)=120.0D0*F(I)*X1+24.0D0*E(I)
      OUTP(5)=120.0D0*F(I)
      RETURN
      END
C
C

      SUBROUTINE TRIDIG (N,A,B,C,D,IREP,X,ISING,GAMMA,ALPHA,G)
C
C*****************************************************************
C                                                                *
C     TRIDIG solves a tridiagonal linear system of equations by  *
C     using a condensed Gauss algorithm.                         *
C     If one wants to solve several systems for different right  *
C     hand sides, one must set IREP different from 0 for the     *
C     second and subsequent calls of TRIDIG with the same system *
C     matrix. Then the matrix will not be recomputed nor factored*
C     again for a saving of 2N-2 operations.                     *
C                                                                *
C                                                                *
C     INPUT PARAMETERS:                                          *
C     =================                                          *
C     N       size of the matrix                                 *
C     A       vector A(1:N);  right hand side                    *
C     B       vector B(1:N);  lower codiagonal                   *
C     C       vector C(1:N);  upper codiagonal                   *
C     D       vector D(1:N);  main diagonal                      *
C     IREP    If IREP differs from 0, then the program assumes   *
C             that it is in a repeat call with the same system   *
C             matrix. The program does not reconfigure the system*
C             matrix and its factors in this case.               *
C                                                                *
C                                                                *
C     OUTPUT PARAMETERS:                                         *
C     ==================                                         *
C     X       vector X(1:N); the solution                        *
C     ISING   )  1, if the matrix is numerically singular        *
C             )     (no solution computed)                       *
C             )  0, otherwise                                    *
C                                                                *
C                                                                *
C     AUXILIARY PARAMETERS:                                      *
C     =====================                                      *
C     GAMMA   ) N-vectors ..(1:N);                               *
C     ALPHA   ) for repeated calls with IREP.NE.0 the vectors    *
C     G       ) GAMMA and ALPHA must nit be altered.             *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  Subroutines required: none                                    *
C                                                                *
C*****************************************************************
C                                                                *
C  Author   : Elmar Pohl                                         *
C  Date     : 09.28.1985                                         *
C  Source   : FORTRAN 77                                         *
C                                                                *
C*****************************************************************
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
      DOUBLE PRECISION A(N),B(N),C(N),D(N),X(N),GAMMA(N),ALPHA(N),
     +                 G(N)
      IF (IREP .NE. 0) GOTO 11
         ISING=0
         NM1=N-1
         ALPHA(1)=D(1)
         IF (ALPHA(1) .EQ. 0.0D0) GOTO 6
         IF(N .EQ. 1) GOTO 2
         DO 1 I=1,NM1
              GAMMA(I)=C(I)/ALPHA(I)
              ALPH=D(I+1)-B(I+1)*GAMMA(I)
              IF(ALPH .EQ. 0.0D0) GOTO 6
              ALPHA(I+1)=ALPH
    1    CONTINUE
   11 IF(N .GT. 1) GOTO 3
    2    X(1)=A(1)/ALPHA(1)
         RETURN
    3 G(1)=A(1)/ALPHA(1)
      DO 4 I=2,N
           G(I)=(A(I)-B(I)*G(I-1))/ALPHA(I)
    4 CONTINUE
      X(N)=G(N)
      NM1=N-1
      DO 5 I=1,NM1
           K=N-I
           X(K)=G(K)-GAMMA(K)*X(K+1)
    5 CONTINUE
      RETURN
    6 ISING=1
      RETURN
      END


Begin of file
Contents
Index