End of file
Contents
Index

      SUBROUTINE AKIMA2(N,XN,FN,NK,BETA,B,C,D,ISWTCH,HELP,IERR)
C
C*****************************************************************
C                                                                *
C  The program AKIMA2 computes the coefficients  B(I), C(I) and  *
C  D(I) for I=0, ... , N-1 of an interpolating cubic AKIMA       *
C  spline, which can be either periodic or nonperiodic.          *
C  The computation of slopes in AKIMA2 follows the suggestion of *
C  R. Wodicka, see the literature quote below.                   *
C  The subspline has the representation                          *
C                                                                *
C  S(X)=FN(I)+B(I)(X-XN(I))+C(I)(X-XN(I))**2+D(I)(X-XN(I))**3    *
C                                                                *
C  for any point X in the subinterval [XN(I), XN(I+1)] for       *
C  I=0,..., N-1.                                                 *
C                                                                *
C                                                                *
C  ASSUMPTIONS:                                                  *
C  ============                                                  *
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                3. The nodes XN(I), I=0, ..., N, must be        *
C                   ordered monotonically, i.e., XN(I) < XN(I+1) *
C                   for 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 nodes XN(I) for I=0, ... , N                    *
C  FN      : DOUBLE PRECISION (NK+1)-vector FN(0:NK), containing *
C            the functional values FN(I) at XN(I) for I=0,...,N  *
C  NK      : NK = N+INT((N+1)/2) maximal number of nodes allowed *
C            when using rounded corners. If corners are not      *
C            rounded, we use: NK = N                             *
C  BETA    : If 0.0 < BETA < 1.0 the corners are rounded, other- *
C            wise corners are kept                               *
C            In the periodic case, we do not round a corner that *
C            may exist at XN(0) = XN(N), even if 0.0 < BETA < 1.0*
C  ISWTCH  : = 0, nonperiodic spline                             *
C            = 1, periodic spline                                *
C            In the periodic case, the interval [XN(0), XN(N)]   *
C            must be an interval of periodicity with FN(0) =     *
C            FN(N).                                              *
C                                                                *
C                                                                *
C  AUXILIARY VARIABLES:                                          *
C  ====================                                          *
C  HELP    : DOUBLE PRECISION array HELP(-2:NK+1,1:4)            *
C                                                                *
C                                                                *
C  OUTPUT PARAMETERS:                                            *
C  =================                                             *
C  N       : Number of the last node. If corners are rounded,    *
C            i.e., if 0.0 < BETA < 1.0 , then the output value   *
C            of N can differ from its input. When corners are    *
C            rounded, the set of nodes can maximally be enlarged *
C            by INT((N+1)/2) new nodes.                          *
C  XN      : DOUBLE PRECISION vector XN(0:NK) containing the     *
C            nodes XN(I), I=0,...,N. If 0.0 < BETA < 1.0, then   *
C            the output nodes can differ from the input nodes.   *
C  FN      : DOUBLE PRECISION vector FN(0:NK), containing the    *
C            functional values FN(I) at XN(I) for I = 0, ..., N. *
C            If 0.0 < BETA < 1.0, the node and functional values *
C            XN(I) and FN(I) can differ from their input values. *
C  B       : DOUBLE PRECISION vector B(0:NK-1) ] B, C and D con- *
C  C       : DOUBLE PRECISION vector C(0:NK-1) ] tain the coeffi-*
C  D       : DOUBLE PRECISION vector D(0:NK-1) ] cients of the   *
C                                     subspline for I=0 to NK-1. *
C                                                                *
C  IERR    : error parameter                                     *
C            = 0, all is ok                                      *
C            =-1, N < 4 or NK < 4                                *
C            =-2, the XN(I) are not monotonically ordered        *
C            =-3, NK < N+INT((N+1)/2) while 0.0 < BETA < 1.0     *
C                                                                *
C----------------------------------------------------------------*
C                                                                *
C  Required subroutine: MACHPD                                   *
C                                                                *
C*****************************************************************
C                                                                *
C  Author   : Gisela Engeln-Müllges                              *
C  Date     : 04.09.1993                                         *
C  Source   : FORTRAN 77                                         *
C                                                                *
C*****************************************************************
C                                                                *
C Literature : R. Wodicka,                                       *
C              Ergänzungen zu Akima's Steigungsformel,           *
C              Mitteilungen aus dem Mathematischen Seminar       *
C              Giessen, Heft 203, 1991                           *
C                                                                *
C*****************************************************************
C
C     Declarations
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION XN(0:NK), FN(0:NK), B(0:NK-1), C(0:NK-1),
     +                 D(0:NK-1), HELP(-2:NK+1, 1:4)
C
C     Check input
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
     F    .AND. NK   .LT. N+INT(0.5D0*(N+1))         ) THEN
            IERR = -3
            RETURN
      ENDIF
      IF ( ISWTCH .NE. 0 ) THEN
         ISWTCH = 1
      ENDIF
C
C     Compute 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     Compute the sizes of subintervals and store in the first
C     column of the auxiliary array HELP
C
      DO 10, I = 0, N-1
         HELP(I,1) = XN(I+1) - XN(I)
         IF ( HELP(I,1) .LE. EPS ) THEN
            IERR = -2
            RETURN
         ENDIF
   10 CONTINUE
C
C     Compute the secant slopes and store in the second column of HELP
C
      DO 20, I = 0, N-1
         HELP(I,2) = (FN(I+1)-FN(I))/HELP(I,1)
   20 CONTINUE
C
C     Find the magnitudes of the slope differences and store in column 3
C
      DO 30, I = 0, N-2
         HELP(I,3) = DABS(HELP(I+1,2)-HELP(I,2))
   30 CONTINUE
\hbox{\JDhspace\verb`
      IF ( DABS(FN(0)-FN(N)) .GT. EPS ) THEN
         ISWTCH = 0
      ENDIF
\hbox{\JDhspace\verb`
      IF ( BETA .GT. 0.0D0 .AND. BETA .LT. 1.0D0 ) THEN
         IF ( ISWTCH .EQ. 1 ) THEN
C
C     Prepare loop
C
            I = 1
            IMAX = N-1
            HELP(-1,3)  = DABS(HELP(0,2)-HELP(N-1,2))
            HELP(N-1,3) = HELP(-1,3)
         ELSE
            I = 2
            IMAX = N-2
         ENDIF
\hbox{\JDhspace\verb`
   35    XL = HELP(I-2,3) + HELP(I,3)
         XR = HELP(I-1,3)
C
C     Eliminate existing corners
C
         IF ( XL.LE.EPS .AND. XR.GT.EPS ) THEN
C
C     Relabel points I to N
C
            DO 40, J = N,I, -1
               XN(J+1) = XN(J)
               FN(J+1) = FN(J)
   40       CONTINUE
C
C     Shift data associated with points I to N-1
C
            DO 50, J = N-1, I, -1
               HELP(J+1,1) = HELP(J,1)
               HELP(J+1,2) = HELP(J,2)
   50       CONTINUE
C
C     Shift slope difference data for points I to IMAX
C
            DO 60, J = IMAX, I, -1
               HELP(J+1,3) = HELP(J,3)
   60       CONTINUE
C
C     Form additional points I and I+1
C
            XL = HELP(I-1,1)
            XR = HELP(I+1,1)
            XB = BETA*DMIN1(XL,XR)
            XLAMDA = XB/XL
            XMUE   = XB/XR
            XN(I) = XN(I) - XLAMDA*HELP(I-1,1)
            FN(I) = FN(I) - XLAMDA*(FN(I)-FN(I-1))
            XN(I+1) = XN(I+1) + XMUE*HELP(I+1,1)
            FN(I+1) = FN(I+1) + XMUE*(FN(I+2)-FN(I+1))
C
C     Compute new interval lengths
C
            DO 70, J = I-1, I+1
               HELP(J,1) = XN(J+1) -XN(J)
  70        CONTINUE
C
C     Compute new slope data
C
            HELP(I,2) = (FN(I+1)-FN(I))/HELP(I,1)
            DO 80, J = I-1, I
               HELP(J,3) = DABS(HELP(J+1,2)-HELP(J,2))
  80        CONTINUE
C
C     Increase number of nodes
C
            N = N+1
            IMAX = IMAX + 1
         ENDIF
C
C     Set index for the subsequent point
C
         I = I + 1
         IF ( I .LE. IMAX ) GOTO 35
      ENDIF
\hbox{\JDhspace\verb`
      IF ( ISWTCH .EQ. 1 ) THEN
C
C     In the periodic case, assign additional slopes
C
         HELP(-2,2)  = HELP(N-2,2)
         HELP(-1,2)  = HELP(N-1,2)
         HELP(N,2)   = HELP(0,2)
         HELP(N+1,2) = HELP(1,2)
         HELP(-1,1)  = HELP(N-1,1)
         HELP(N,1)   = HELP(0,1)
      ELSE
C
C     In the nonperiodic case, assign additional slopes as well
C
         HELP(-2,2)  = 3.0D0*HELP(0,2)   - 2.0D0*HELP(1,2)
         HELP(-1,2)  = 2.0D0*HELP(0,2)   - HELP(1,2)
         HELP(N,2)   = 2.0D0*HELP(N-1,2) - HELP(N-2,2)
         HELP(N+1,2) = 3.0D0*HELP(N-1,2) - 2.0D0*HELP(N-2,2)
         HELP(-1,1)  = HELP(1,1)
         HELP(N,1)   = HELP(N-2,1)
      ENDIF
C
C     Compute additional slope differences
C
      HELP(-2,3)  = DABS(HELP(-1,2)  - HELP(-2,2))
      HELP(-1,3)  = DABS(HELP(0,2)   - HELP(-1,2))
      HELP(N-1,3) = DABS(HELP(N,2)   - HELP(N-1,2))
      HELP(N,3)   = DABS(HELP(N+1,2) - HELP(N,2))
C
C     Compute the left and right handed slopes at points 0 to N-1
C     and store in column 4 of HELP and in B
C
      DO 90, I = 0, N-1
         XL = HELP(I-2,3)
         XR = HELP(I,3)
         IF ( XL+XR .GT. EPS ) THEN
            XL     = XL*HELP(I-1,1)
            XR     = XR*HELP(I,1)
            ALPHA = XL/(XL+XR)
            HELP(I,4) = HELP(I-1,2) + ALPHA*(HELP(I,2)-HELP(I-1,2))
            B(I) = HELP(I,4)
         ELSE
            HELP(I,4) = HELP(I-1,2)
            B(I) = HELP(I,2)
         ENDIF
   90 CONTINUE
C
C     Compute the left handed slope at point N
C
      XL = HELP(N-2,3)
      XR = HELP(N,3)
      IF (XL+XR .GT. EPS ) THEN
         XL    = XL*HELP(N-1,1)
         XR    = XR*HELP(N,1)
         ALPHA = XL/(XL+XR)
         HELP(N,4) = HELP(N-1,2) + ALPHA*(HELP(N,2)-HELP(N-1,2))
      ELSE
         HELP(N,4) = HELP(N-1,2)
      ENDIF
C
C     Compute the coefficients C(I) and D(I)
C
      DO 100, I = 0, N-1
         H = 1.0D0/HELP(I,1)
         C(I) = (3.0D0*HELP(I,2) - 2.0D0*B(I) - HELP(I+1,4))*H
         D(I) = (B(I) + HELP(I+1,4) - 2.0D0*HELP(I,2))*H*H
  100 CONTINUE
\hbox{\JDhspace\verb`
      RETURN
      END


Begin of file
Contents
Index