

*DECK DPBCO
      SUBROUTINE DPBCO (ABD, LDA, N, M, RCOND, Z, INFO)
C***BEGIN PROLOGUE  DPBCO
C***PURPOSE  Factor a real symmetric positive definite matrix stored in
C            band form and estimate the condition number of the matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B2
C***TYPE      DOUBLE PRECISION (SPBCO-S, DPBCO-D, CPBCO-C)
C***KEYWORDS  BANDED, CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION, POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPBCO factors a double precision symmetric positive definite
C     matrix stored in band form and estimates the condition of the
C     matrix.
C
C     If  RCOND  is not needed, DPBFA is slightly faster.
C     To solve  A*X = B , follow DPBCO by DPBSL.
C     To compute  INVERSE(A)*C , follow DPBCO by DPBSL.
C     To compute  DETERMINANT(A) , follow DPBCO by DPBDI.
C
C     On Entry
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                the matrix to be factored.  The columns of the upper
C                triangle are stored in the columns of ABD and the
C                diagonals of the upper triangle are stored in the
C                rows of ABD .  See the comments below for details.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C                LDA must be .GE. M + 1 .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        M       INTEGER
C                the number of diagonals above the main diagonal.
C                0 .LE. M .LT.  N .
C
C     On Return
C
C        ABD     an upper triangular matrix  R , stored in band
C                form, so that  A = TRANS(R)*R .
C                If  INFO .NE. 0 , the factorization is not complete.
C
C        RCOND   DOUBLE PRECISION
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.  If INFO .NE. 0 , RCOND is unchanged.
C
C        Z       DOUBLE PRECISION(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is singular to working precision, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C                If  INFO .NE. 0 , Z  is unchanged.
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  signals an error condition.  The leading minor
C                     of order  K  is not positive definite.
C
C     Band Storage
C
C           If  A  is a symmetric positive definite band matrix,
C           the following program segment will set up the input.
C
C                   M = (band width above diagonal)
C                   DO 20 J = 1, N
C                      I1 = MAX(1, J-M)
C                      DO 10 I = I1, J
C                         K = I-J+M+1
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           This uses  M + 1  rows of  A , except for the  M by M
C           upper left triangle, which is ignored.
C
C     Example:  If the original matrix is
C
C           11 12 13  0  0  0
C           12 22 23 24  0  0
C           13 23 33 34 35  0
C            0 24 34 44 45 46
C            0  0 35 45 55 56
C            0  0  0 46 56 66
C
C     then  N = 6 , M = 2  and  ABD  should contain
C
C            *  * 13 24 35 46
C            * 12 23 34 45 56
C           11 22 33 44 55 66
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DASUM, DAXPY, DDOT, DPBFA, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPBCO
      INTEGER LDA,N,M,INFO
      DOUBLE PRECISION ABD(LDA,*),Z(*)
      DOUBLE PRECISION RCOND
C
      DOUBLE PRECISION DDOT,EK,T,WK,WKM
      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM
      INTEGER I,J,J2,K,KB,KP1,L,LA,LB,LM,MU
C
C     FIND NORM OF A
C
C***FIRST EXECUTABLE STATEMENT  DPBCO
      DO 30 J = 1, N
         L = MIN(J,M+1)
         MU = MAX(M+2-J,1)
         Z(J) = DASUM(L,ABD(MU,J),1)
         K = J - L
         IF (M .LT. MU) GO TO 20
         DO 10 I = MU, M
            K = K + 1
            Z(K) = Z(K) + ABS(ABD(I,J))
   10    CONTINUE
   20    CONTINUE
   30 CONTINUE
      ANORM = 0.0D0
      DO 40 J = 1, N
         ANORM = MAX(ANORM,Z(J))
   40 CONTINUE
C
C     FACTOR
C
      CALL DPBFA(ABD,LDA,N,M,INFO)
      IF (INFO .NE. 0) GO TO 180
C
C        RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C        ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
C        THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C        GROWTH IN THE ELEMENTS OF W  WHERE  TRANS(R)*W = E .
C        THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C        SOLVE TRANS(R)*W = E
C
         EK = 1.0D0
         DO 50 J = 1, N
            Z(J) = 0.0D0
   50    CONTINUE
         DO 110 K = 1, N
            IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K))
            IF (ABS(EK-Z(K)) .LE. ABD(M+1,K)) GO TO 60
               S = ABD(M+1,K)/ABS(EK-Z(K))
               CALL DSCAL(N,S,Z,1)
               EK = S*EK
   60       CONTINUE
            WK = EK - Z(K)
            WKM = -EK - Z(K)
            S = ABS(WK)
            SM = ABS(WKM)
            WK = WK/ABD(M+1,K)
            WKM = WKM/ABD(M+1,K)
            KP1 = K + 1
            J2 = MIN(K+M,N)
            I = M + 1
            IF (KP1 .GT. J2) GO TO 100
               DO 70 J = KP1, J2
                  I = I - 1
                  SM = SM + ABS(Z(J)+WKM*ABD(I,J))
                  Z(J) = Z(J) + WK*ABD(I,J)
                  S = S + ABS(Z(J))
   70          CONTINUE
               IF (S .GE. SM) GO TO 90
                  T = WKM - WK
                  WK = WKM
                  I = M + 1
                  DO 80 J = KP1, J2
                     I = I - 1
                     Z(J) = Z(J) + T*ABD(I,J)
   80             CONTINUE
   90          CONTINUE
  100       CONTINUE
            Z(K) = WK
  110    CONTINUE
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
C
C        SOLVE  R*Y = W
C
         DO 130 KB = 1, N
            K = N + 1 - KB
            IF (ABS(Z(K)) .LE. ABD(M+1,K)) GO TO 120
               S = ABD(M+1,K)/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
  120       CONTINUE
            Z(K) = Z(K)/ABD(M+1,K)
            LM = MIN(K-1,M)
            LA = M + 1 - LM
            LB = K - LM
            T = -Z(K)
            CALL DAXPY(LM,T,ABD(LA,K),1,Z(LB),1)
  130    CONTINUE
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
C
         YNORM = 1.0D0
C
C        SOLVE TRANS(R)*V = Y
C
         DO 150 K = 1, N
            LM = MIN(K-1,M)
            LA = M + 1 - LM
            LB = K - LM
            Z(K) = Z(K) - DDOT(LM,ABD(LA,K),1,Z(LB),1)
            IF (ABS(Z(K)) .LE. ABD(M+1,K)) GO TO 140
               S = ABD(M+1,K)/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
               YNORM = S*YNORM
  140       CONTINUE
            Z(K) = Z(K)/ABD(M+1,K)
  150    CONTINUE
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
         YNORM = S*YNORM
C
C        SOLVE  R*Z = W
C
         DO 170 KB = 1, N
            K = N + 1 - KB
            IF (ABS(Z(K)) .LE. ABD(M+1,K)) GO TO 160
               S = ABD(M+1,K)/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
               YNORM = S*YNORM
  160       CONTINUE
            Z(K) = Z(K)/ABD(M+1,K)
            LM = MIN(K-1,M)
            LA = M + 1 - LM
            LB = K - LM
            T = -Z(K)
            CALL DAXPY(LM,T,ABD(LA,K),1,Z(LB),1)
  170    CONTINUE
C        MAKE ZNORM = 1.0
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
         YNORM = S*YNORM
C
         IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
         IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
  180 CONTINUE
      RETURN
      END
*DECK DPBDI
      SUBROUTINE DPBDI (ABD, LDA, N, M, DET)
C***BEGIN PROLOGUE  DPBDI
C***PURPOSE  Compute the determinant of a symmetric positive definite
C            band matrix using the factors computed by DPBCO or DPBFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D3B2
C***TYPE      DOUBLE PRECISION (SPBDI-S, DPBDI-D, CPBDI-C)
C***KEYWORDS  BANDED, DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK,
C             MATRIX, POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPBDI computes the determinant
C     of a double precision symmetric positive definite band matrix
C     using the factors computed by DPBCO or DPBFA.
C     If the inverse is needed, use DPBSL  N  times.
C
C     On Entry
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                the output from DPBCO or DPBFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        M       INTEGER
C                the number of diagonals above the main diagonal.
C
C     On Return
C
C        DET     DOUBLE PRECISION(2)
C                determinant of original matrix in the form
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. DET(1) .LT. 10.0
C                or  DET(1) .EQ. 0.0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPBDI
      INTEGER LDA,N,M
      DOUBLE PRECISION ABD(LDA,*)
      DOUBLE PRECISION DET(2)
C
      DOUBLE PRECISION S
      INTEGER I
C***FIRST EXECUTABLE STATEMENT  DPBDI
C
C     COMPUTE DETERMINANT
C
      DET(1) = 1.0D0
      DET(2) = 0.0D0
      S = 10.0D0
      DO 50 I = 1, N
         DET(1) = ABD(M+1,I)**2*DET(1)
         IF (DET(1) .EQ. 0.0D0) GO TO 60
   10    IF (DET(1) .GE. 1.0D0) GO TO 20
            DET(1) = S*DET(1)
            DET(2) = DET(2) - 1.0D0
         GO TO 10
   20    CONTINUE
   30    IF (DET(1) .LT. S) GO TO 40
            DET(1) = DET(1)/S
            DET(2) = DET(2) + 1.0D0
         GO TO 30
   40    CONTINUE
   50 CONTINUE
   60 CONTINUE
      RETURN
      END
*DECK DPBFA
      SUBROUTINE DPBFA (ABD, LDA, N, M, INFO)
C***BEGIN PROLOGUE  DPBFA
C***PURPOSE  Factor a real symmetric positive definite matrix stored in
C            in band form.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B2
C***TYPE      DOUBLE PRECISION (SPBFA-S, DPBFA-D, CPBFA-C)
C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPBFA factors a double precision symmetric positive definite
C     matrix stored in band form.
C
C     DPBFA is usually called by DPBCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C
C     On Entry
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                the matrix to be factored.  The columns of the upper
C                triangle are stored in the columns of ABD and the
C                diagonals of the upper triangle are stored in the
C                rows of ABD .  See the comments below for details.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C                LDA must be .GE. M + 1 .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        M       INTEGER
C                the number of diagonals above the main diagonal.
C                0 .LE. M .LT. N .
C
C     On Return
C
C        ABD     an upper triangular matrix  R , stored in band
C                form, so that  A = TRANS(R)*R .
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  if the leading minor of order  K  is not
C                     positive definite.
C
C     Band Storage
C
C           If  A  is a symmetric positive definite band matrix,
C           the following program segment will set up the input.
C
C                   M = (band width above diagonal)
C                   DO 20 J = 1, N
C                      I1 = MAX(1, J-M)
C                      DO 10 I = I1, J
C                         K = I-J+M+1
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPBFA
      INTEGER LDA,N,M,INFO
      DOUBLE PRECISION ABD(LDA,*)
C
      DOUBLE PRECISION DDOT,T
      DOUBLE PRECISION S
      INTEGER IK,J,JK,K,MU
C***FIRST EXECUTABLE STATEMENT  DPBFA
         DO 30 J = 1, N
            INFO = J
            S = 0.0D0
            IK = M + 1
            JK = MAX(J-M,1)
            MU = MAX(M+2-J,1)
            IF (M .LT. MU) GO TO 20
            DO 10 K = MU, M
               T = ABD(K,J) - DDOT(K-MU,ABD(IK,JK),1,ABD(MU,J),1)
               T = T/ABD(M+1,JK)
               ABD(K,J) = T
               S = S + T*T
               IK = IK - 1
               JK = JK + 1
   10       CONTINUE
   20       CONTINUE
            S = ABD(M+1,J) - S
            IF (S .LE. 0.0D0) GO TO 40
            ABD(M+1,J) = SQRT(S)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END
*DECK DPBSL
      SUBROUTINE DPBSL (ABD, LDA, N, M, B)
C***BEGIN PROLOGUE  DPBSL
C***PURPOSE  Solve a real symmetric positive definite band system
C            using the factors computed by DPBCO or DPBFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B2
C***TYPE      DOUBLE PRECISION (SPBSL-S, DPBSL-D, CPBSL-C)
C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX,
C             POSITIVE DEFINITE, SOLVE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPBSL solves the double precision symmetric positive definite
C     band system  A*X = B
C     using the factors computed by DPBCO or DPBFA.
C
C     On Entry
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                the output from DPBCO or DPBFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        M       INTEGER
C                the number of diagonals above the main diagonal.
C
C        B       DOUBLE PRECISION(N)
C                the right hand side vector.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal.  Technically this indicates
C        singularity, but it is usually caused by improper subroutine
C        arguments.  It will not occur if the subroutines are called
C        correctly, and  INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL DPBCO(ABD,LDA,N,RCOND,Z,INFO)
C           IF (RCOND is too small .OR. INFO .NE. 0) GO TO ...
C           DO 10 J = 1, P
C              CALL DPBSL(ABD,LDA,N,C(1,J))
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPBSL
      INTEGER LDA,N,M
      DOUBLE PRECISION ABD(LDA,*),B(*)
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,LA,LB,LM
C
C     SOLVE TRANS(R)*Y = B
C
C***FIRST EXECUTABLE STATEMENT  DPBSL
      DO 10 K = 1, N
         LM = MIN(K-1,M)
         LA = M + 1 - LM
         LB = K - LM
         T = DDOT(LM,ABD(LA,K),1,B(LB),1)
         B(K) = (B(K) - T)/ABD(M+1,K)
   10 CONTINUE
C
C     SOLVE R*X = Y
C
      DO 20 KB = 1, N
         K = N + 1 - KB
         LM = MIN(K-1,M)
         LA = M + 1 - LM
         LB = K - LM
         B(K) = B(K)/ABD(M+1,K)
         T = -B(K)
         CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1)
   20 CONTINUE
      RETURN
      END
*DECK DPCHBS
      SUBROUTINE DPCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF,
     +   NDIM, KORD, IERR)
C***BEGIN PROLOGUE  DPCHBS
C***PURPOSE  Piecewise Cubic Hermite to B-Spline converter.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3
C***TYPE      DOUBLE PRECISION (PCHBS-S, DPCHBS-D)
C***KEYWORDS  B-SPLINES, CONVERSION, CUBIC HERMITE INTERPOLATION,
C             PIECEWISE CUBIC INTERPOLATION
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Computing and Mathematics Research Division
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C *Usage:
C
C        INTEGER  N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR
C        PARAMETER  (INCFD = ...)
C        DOUBLE PRECISION  X(nmax), F(INCFD,nmax), D(INCFD,nmax),
C       *      T(2*nmax+4), BCOEF(2*nmax)
C
C        CALL DPCHBS (N, X, F, D, INCFD, KNOTYP, NKNOTS, T, BCOEF,
C       *             NDIM, KORD, IERR)
C
C *Arguments:
C
C     N:IN  is the number of data points, N.ge.2 .  (not checked)
C
C     X:IN  is the real array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.   (not checked)
C           nmax, the dimension of X, must be .ge.N.
C
C     F:IN  is the real array of dependent variable values.
C           F(1+(I-1)*INCFD) is the value corresponding to X(I).
C           nmax, the second dimension of F, must be .ge.N.
C
C     D:IN  is the real array of derivative values at the data points.
C           D(1+(I-1)*INCFD) is the value corresponding to X(I).
C           nmax, the second dimension of D, must be .ge.N.
C
C     INCFD:IN  is the increment between successive values in F and D.
C           This argument is provided primarily for 2-D applications.
C           It may have the value 1 for one-dimensional applications,
C           in which case F and D may be singly-subscripted arrays.
C
C     KNOTYP:IN  is a flag to control the knot sequence.
C           The knot sequence T is normally computed from X by putting
C           a double knot at each X and setting the end knot pairs
C           according to the value of KNOTYP:
C              KNOTYP = 0:  Quadruple knots at X(1) and X(N).  (default)
C              KNOTYP = 1:  Replicate lengths of extreme subintervals:
C                           T( 1 ) = T( 2 ) = X(1) - (X(2)-X(1))  ;
C                           T(M+4) = T(M+3) = X(N) + (X(N)-X(N-1)).
C              KNOTYP = 2:  Periodic placement of boundary knots:
C                           T( 1 ) = T( 2 ) = X(1) - (X(N)-X(N-1));
C                           T(M+4) = T(M+3) = X(N) + (X(2)-X(1))  .
C              Here M=NDIM=2*N.
C           If the input value of KNOTYP is negative, however, it is
C           assumed that NKNOTS and T were set in a previous call.
C           This option is provided for improved efficiency when used
C           in a parametric setting.
C
C     NKNOTS:INOUT  is the number of knots.
C           If KNOTYP.GE.0, then NKNOTS will be set to NDIM+4.
C           If KNOTYP.LT.0, then NKNOTS is an input variable, and an
C              error return will be taken if it is not equal to NDIM+4.
C
C     T:INOUT  is the array of 2*N+4 knots for the B-representation.
C           If KNOTYP.GE.0, T will be returned by DPCHBS with the
C              interior double knots equal to the X-values and the
C              boundary knots set as indicated above.
C           If KNOTYP.LT.0, it is assumed that T was set by a
C              previous call to DPCHBS.  (This routine does **not**
C              verify that T forms a legitimate knot sequence.)
C
C     BCOEF:OUT  is the array of 2*N B-spline coefficients.
C
C     NDIM:OUT  is the dimension of the B-spline space.  (Set to 2*N.)
C
C     KORD:OUT  is the order of the B-spline.  (Set to 4.)
C
C     IERR:OUT  is an error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           "Recoverable" errors:
C              IERR = -4  if KNOTYP.GT.2 .
C              IERR = -5  if KNOTYP.LT.0 and NKNOTS.NE.(2*N+4).
C
C *Description:
C     DPCHBS computes the B-spline representation of the PCH function
C     determined by N,X,F,D.  To be compatible with the rest of PCHIP,
C     DPCHBS includes INCFD, the increment between successive values of
C     the F- and D-arrays.
C
C     The output is the B-representation for the function:  NKNOTS, T,
C     BCOEF, NDIM, KORD.
C
C *Caution:
C     Since it is assumed that the input PCH function has been
C     computed by one of the other routines in the package PCHIP,
C     input arguments N, X, INCFD are **not** checked for validity.
C
C *Restrictions/assumptions:
C     1. N.GE.2 .  (not checked)
C     2. X(i).LT.X(i+1), i=1,...,N .  (not checked)
C     3. INCFD.GT.0 .  (not checked)
C     4. KNOTYP.LE.2 .  (error return if not)
C    *5. NKNOTS = NDIM+4 = 2*N+4 .  (error return if not)
C    *6. T(2*k+1) = T(2*k) = X(k), k=1,...,N .  (not checked)
C
C       * Indicates this applies only if KNOTYP.LT.0 .
C
C *Portability:
C     Argument INCFD is used only to cause the compiler to generate
C     efficient code for the subscript expressions (1+(I-1)*INCFD) .
C     The normal usage, in which DPCHBS is called with one-dimensional
C     arrays F and D, is probably non-Fortran 77, in the strict sense,
C     but it works on all systems on which DPCHBS has been tested.
C
C *See Also:
C     PCHIC, PCHIM, or PCHSP can be used to determine an interpolating
C        PCH function from a set of data.
C     The B-spline routine DBVALU can be used to evaluate the
C        B-representation that is output by DPCHBS.
C        (See BSPDOC for more information.)
C
C***REFERENCES  F. N. Fritsch, "Representations for parametric cubic
C                 splines," Computer Aided Geometric Design 6 (1989),
C                 pp.79-82.
C***ROUTINES CALLED  DPCHKT, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   870701  DATE WRITTEN
C   900405  Converted Fortran to upper case.
C   900405  Removed requirement that X be dimensioned N+1.
C   900406  Modified to make PCHKT a subsidiary routine to simplify
C           usage.  In the process, added argument INCFD to be com-
C           patible with the rest of PCHIP.
C   900410  Converted prologue to SLATEC 4.0 format.
C   900410  Added calls to XERMSG and changed constant 3. to 3 to
C           reduce single/double differences.
C   900411  Added reference.
C   900430  Produced double precision version.
C   900501  Corrected declarations.
C   930317  Minor cosmetic changes.  (FNF)
C   930514  Corrected problems with dimensioning of arguments and
C           clarified DESCRIPTION.  (FNF)
C   930604  Removed  NKNOTS from DPCHKT call list.  (FNF)
C***END PROLOGUE  DPCHBS
C
C*Internal Notes:
C
C**End
C
C  Declare arguments.
C
      INTEGER  N, INCFD, KNOTYP, NKNOTS, NDIM, KORD, IERR
      DOUBLE PRECISION  X(*), F(INCFD,*), D(INCFD,*), T(*), BCOEF(*)
C
C  Declare local variables.
C
      INTEGER  K, KK
      DOUBLE PRECISION  DOV3, HNEW, HOLD
      CHARACTER*8  LIBNAM, SUBNAM
C***FIRST EXECUTABLE STATEMENT  DPCHBS
C
C  Initialize.
C
      NDIM = 2*N
      KORD = 4
      IERR = 0
      LIBNAM = 'SLATEC'
      SUBNAM = 'DPCHBS'
C
C  Check argument validity.  Set up knot sequence if OK.
C
      IF ( KNOTYP.GT.2 )  THEN
         IERR = -1
         CALL XERMSG (LIBNAM, SUBNAM, 'KNOTYP GREATER THAN 2', IERR, 1)
         RETURN
      ENDIF
      IF ( KNOTYP.LT.0 )  THEN
         IF ( NKNOTS.NE.NDIM+4 )  THEN
            IERR = -2
            CALL XERMSG (LIBNAM, SUBNAM,
     *                    'KNOTYP.LT.0 AND NKNOTS.NE.(2*N+4)', IERR, 1)
            RETURN
         ENDIF
      ELSE
C          Set up knot sequence.
         NKNOTS = NDIM + 4
         CALL DPCHKT (N, X, KNOTYP, T)
      ENDIF
C
C  Compute B-spline coefficients.
C
      HNEW = T(3) - T(1)
      DO 40  K = 1, N
         KK = 2*K
         HOLD = HNEW
C          The following requires mixed mode arithmetic.
         DOV3 = D(1,K)/3
         BCOEF(KK-1) = F(1,K) - HOLD*DOV3
C          The following assumes T(2*K+1) = X(K).
         HNEW = T(KK+3) - T(KK+1)
         BCOEF(KK) = F(1,K) + HNEW*DOV3
   40 CONTINUE
C
C  Terminate.
C
      RETURN
C------------- LAST LINE OF DPCHBS FOLLOWS -----------------------------
      END
*DECK DPCHCE
      SUBROUTINE DPCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR)
C***BEGIN PROLOGUE  DPCHCE
C***SUBSIDIARY
C***PURPOSE  Set boundary conditions for DPCHIC
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      DOUBLE PRECISION (PCHCE-S, DPCHCE-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C          DPCHCE:  DPCHIC End Derivative Setter.
C
C    Called by DPCHIC to set end derivatives as requested by the user.
C    It must be called after interior derivative values have been set.
C                      -----
C
C    To facilitate two-dimensional applications, includes an increment
C    between successive values of the D-array.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  IC(2), N, IERR
C        DOUBLE PRECISION  VC(2), X(N), H(N), SLOPE(N), D(INCFD,N)
C
C        CALL  DPCHCE (IC, VC, N, X, H, SLOPE, D, INCFD, IERR)
C
C   Parameters:
C
C     IC -- (input) integer array of length 2 specifying desired
C           boundary conditions:
C           IC(1) = IBEG, desired condition at beginning of data.
C           IC(2) = IEND, desired condition at end of data.
C           ( see prologue to DPCHIC for details. )
C
C     VC -- (input) real*8 array of length 2 specifying desired boundary
C           values.  VC(1) need be set only if IC(1) = 2 or 3 .
C                    VC(2) need be set only if IC(2) = 2 or 3 .
C
C     N -- (input) number of data points.  (assumes N.GE.2)
C
C     X -- (input) real*8 array of independent variable values.  (the
C           elements of X are assumed to be strictly increasing.)
C
C     H -- (input) real*8 array of interval lengths.
C     SLOPE -- (input) real*8 array of data slopes.
C           If the data are (X(I),Y(I)), I=1(1)N, then these inputs are:
C                  H(I) =  X(I+1)-X(I),
C              SLOPE(I) = (Y(I+1)-Y(I))/H(I),  I=1(1)N-1.
C
C     D -- (input) real*8 array of derivative values at the data points.
C           The value corresponding to X(I) must be stored in
C                D(1+(I-1)*INCFD),  I=1(1)N.
C          (output) the value of D at X(1) and/or X(N) is changed, if
C           necessary, to produce the requested boundary conditions.
C           no other entries in D are changed.
C
C     INCFD -- (input) increment between successive values in D.
C           This argument is provided primarily for 2-D applications.
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           Warning errors:
C              IERR = 1  if IBEG.LT.0 and D(1) had to be adjusted for
C                        monotonicity.
C              IERR = 2  if IEND.LT.0 and D(1+(N-1)*INCFD) had to be
C                        adjusted for monotonicity.
C              IERR = 3  if both of the above are true.
C
C    -------
C    WARNING:  This routine does no validity-checking of arguments.
C    -------
C
C  Fortran intrinsics used:  ABS.
C
C***SEE ALSO  DPCHIC
C***ROUTINES CALLED  DPCHDF, DPCHST, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820218  DATE WRITTEN
C   820805  Converted to SLATEC library version.
C   870707  Corrected XERROR calls for d.p. name(s).
C   890206  Corrected XERROR calls.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated AUTHOR section in prologue.  (WRB)
C   930503  Improved purpose.  (FNF)
C***END PROLOGUE  DPCHCE
C
C  Programming notes:
C     1. The function DPCHST(ARG1,ARG2)  is assumed to return zero if
C        either argument is zero, +1 if they are of the same sign, and
C        -1 if they are of opposite sign.
C     2. One could reduce the number of arguments and amount of local
C        storage, at the expense of reduced code clarity, by passing in
C        the array WK (rather than splitting it into H and SLOPE) and
C        increasing its length enough to incorporate STEMP and XTEMP.
C     3. The two monotonicity checks only use the sufficient conditions.
C        Thus, it is possible (but unlikely) for a boundary condition to
C        be changed, even though the original interpolant was monotonic.
C        (At least the result is a continuous function of the data.)
C**End
C
C  DECLARE ARGUMENTS.
C
      INTEGER  IC(2), N, INCFD, IERR
      DOUBLE PRECISION  VC(2), X(*), H(*), SLOPE(*), D(INCFD,*)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  IBEG, IEND, IERF, INDEX, J, K
      DOUBLE PRECISION  HALF, STEMP(3), THREE, TWO, XTEMP(4), ZERO
      SAVE ZERO, HALF, TWO, THREE
      DOUBLE PRECISION  DPCHDF, DPCHST
C
C  INITIALIZE.
C
      DATA  ZERO /0.D0/,  HALF/.5D0/,  TWO/2.D0/, THREE/3.D0/
C
C***FIRST EXECUTABLE STATEMENT  DPCHCE
      IBEG = IC(1)
      IEND = IC(2)
      IERR = 0
C
C  SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL.
C
      IF ( ABS(IBEG).GT.N )  IBEG = 0
      IF ( ABS(IEND).GT.N )  IEND = 0
C
C  TREAT BEGINNING BOUNDARY CONDITION.
C
      IF (IBEG .EQ. 0)  GO TO 2000
      K = ABS(IBEG)
      IF (K .EQ. 1)  THEN
C        BOUNDARY VALUE PROVIDED.
         D(1,1) = VC(1)
      ELSE IF (K .EQ. 2)  THEN
C        BOUNDARY SECOND DERIVATIVE PROVIDED.
         D(1,1) = HALF*( (THREE*SLOPE(1) - D(1,2)) - HALF*VC(1)*H(1) )
      ELSE IF (K .LT. 5)  THEN
C        USE K-POINT DERIVATIVE FORMULA.
C        PICK UP FIRST K POINTS, IN REVERSE ORDER.
         DO 10  J = 1, K
            INDEX = K-J+1
C           INDEX RUNS FROM K DOWN TO 1.
            XTEMP(J) = X(INDEX)
            IF (J .LT. K)  STEMP(J) = SLOPE(INDEX-1)
   10    CONTINUE
C                 -----------------------------
         D(1,1) = DPCHDF (K, XTEMP, STEMP, IERF)
C                 -----------------------------
         IF (IERF .NE. 0)  GO TO 5001
      ELSE
C        USE 'NOT A KNOT' CONDITION.
         D(1,1) = ( THREE*(H(1)*SLOPE(2) + H(2)*SLOPE(1))
     *             - TWO*(H(1)+H(2))*D(1,2) - H(1)*D(1,3) ) / H(2)
      ENDIF
C
      IF (IBEG .GT. 0)  GO TO 2000
C
C  CHECK D(1,1) FOR COMPATIBILITY WITH MONOTONICITY.
C
      IF (SLOPE(1) .EQ. ZERO)  THEN
         IF (D(1,1) .NE. ZERO)  THEN
            D(1,1) = ZERO
            IERR = IERR + 1
         ENDIF
      ELSE IF ( DPCHST(D(1,1),SLOPE(1)) .LT. ZERO)  THEN
         D(1,1) = ZERO
         IERR = IERR + 1
      ELSE IF ( ABS(D(1,1)) .GT. THREE*ABS(SLOPE(1)) )  THEN
         D(1,1) = THREE*SLOPE(1)
         IERR = IERR + 1
      ENDIF
C
C  TREAT END BOUNDARY CONDITION.
C
 2000 CONTINUE
      IF (IEND .EQ. 0)  GO TO 5000
      K = ABS(IEND)
      IF (K .EQ. 1)  THEN
C        BOUNDARY VALUE PROVIDED.
         D(1,N) = VC(2)
      ELSE IF (K .EQ. 2)  THEN
C        BOUNDARY SECOND DERIVATIVE PROVIDED.
         D(1,N) = HALF*( (THREE*SLOPE(N-1) - D(1,N-1)) +
     *                                           HALF*VC(2)*H(N-1) )
      ELSE IF (K .LT. 5)  THEN
C        USE K-POINT DERIVATIVE FORMULA.
C        PICK UP LAST K POINTS.
         DO 2010  J = 1, K
            INDEX = N-K+J
C           INDEX RUNS FROM N+1-K UP TO N.
            XTEMP(J) = X(INDEX)
            IF (J .LT. K)  STEMP(J) = SLOPE(INDEX)
 2010    CONTINUE
C                 -----------------------------
         D(1,N) = DPCHDF (K, XTEMP, STEMP, IERF)
C                 -----------------------------
         IF (IERF .NE. 0)  GO TO 5001
      ELSE
C        USE 'NOT A KNOT' CONDITION.
         D(1,N) = ( THREE*(H(N-1)*SLOPE(N-2) + H(N-2)*SLOPE(N-1))
     *             - TWO*(H(N-1)+H(N-2))*D(1,N-1) - H(N-1)*D(1,N-2) )
     *                                                         / H(N-2)
      ENDIF
C
      IF (IEND .GT. 0)  GO TO 5000
C
C  CHECK D(1,N) FOR COMPATIBILITY WITH MONOTONICITY.
C
      IF (SLOPE(N-1) .EQ. ZERO)  THEN
         IF (D(1,N) .NE. ZERO)  THEN
            D(1,N) = ZERO
            IERR = IERR + 2
         ENDIF
      ELSE IF ( DPCHST(D(1,N),SLOPE(N-1)) .LT. ZERO)  THEN
         D(1,N) = ZERO
         IERR = IERR + 2
      ELSE IF ( ABS(D(1,N)) .GT. THREE*ABS(SLOPE(N-1)) )  THEN
         D(1,N) = THREE*SLOPE(N-1)
         IERR = IERR + 2
      ENDIF
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      RETURN
C
C  ERROR RETURN.
C
 5001 CONTINUE
C     ERROR RETURN FROM DPCHDF.
C   *** THIS CASE SHOULD NEVER OCCUR ***
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHCE', 'ERROR RETURN FROM DPCHDF',
     +   IERR, 1)
      RETURN
C------------- LAST LINE OF DPCHCE FOLLOWS -----------------------------
      END
*DECK DPCHCI
      SUBROUTINE DPCHCI (N, H, SLOPE, D, INCFD)
C***BEGIN PROLOGUE  DPCHCI
C***SUBSIDIARY
C***PURPOSE  Set interior derivatives for DPCHIC
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      DOUBLE PRECISION (PCHCI-S, DPCHCI-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C          DPCHCI:  DPCHIC Initial Derivative Setter.
C
C    Called by DPCHIC to set derivatives needed to determine a monotone
C    piecewise cubic Hermite interpolant to the data.
C
C    Default boundary conditions are provided which are compatible
C    with monotonicity.  If the data are only piecewise monotonic, the
C    interpolant will have an extremum at each point where monotonicity
C    switches direction.
C
C    To facilitate two-dimensional applications, includes an increment
C    between successive values of the D-array.
C
C    The resulting piecewise cubic Hermite function should be identical
C    (within roundoff error) to that produced by DPCHIM.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N
C        DOUBLE PRECISION  H(N), SLOPE(N), D(INCFD,N)
C
C        CALL  DPCHCI (N, H, SLOPE, D, INCFD)
C
C   Parameters:
C
C     N -- (input) number of data points.
C           If N=2, simply does linear interpolation.
C
C     H -- (input) real*8 array of interval lengths.
C     SLOPE -- (input) real*8 array of data slopes.
C           If the data are (X(I),Y(I)), I=1(1)N, then these inputs are:
C                  H(I) =  X(I+1)-X(I),
C              SLOPE(I) = (Y(I+1)-Y(I))/H(I),  I=1(1)N-1.
C
C     D -- (output) real*8 array of derivative values at data points.
C           If the data are monotonic, these values will determine a
C           a monotone cubic Hermite function.
C           The value corresponding to X(I) is stored in
C                D(1+(I-1)*INCFD),  I=1(1)N.
C           No other entries in D are changed.
C
C     INCFD -- (input) increment between successive values in D.
C           This argument is provided primarily for 2-D applications.
C
C    -------
C    WARNING:  This routine does no validity-checking of arguments.
C    -------
C
C  Fortran intrinsics used:  ABS, MAX, MIN.
C
C***SEE ALSO  DPCHIC
C***ROUTINES CALLED  DPCHST
C***REVISION HISTORY  (YYMMDD)
C   820218  DATE WRITTEN
C   820601  Modified end conditions to be continuous functions of
C           data when monotonicity switches in next interval.
C   820602  1. Modified formulas so end conditions are less prone
C             to over/underflow problems.
C           2. Minor modification to HSUM calculation.
C   820805  Converted to SLATEC library version.
C   870813  Minor cosmetic changes.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated AUTHOR section in prologue.  (WRB)
C   930503  Improved purpose.  (FNF)
C***END PROLOGUE  DPCHCI
C
C  Programming notes:
C     1. The function  DPCHST(ARG1,ARG2)  is assumed to return zero if
C        either argument is zero, +1 if they are of the same sign, and
C        -1 if they are of opposite sign.
C**End
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD
      DOUBLE PRECISION  H(*), SLOPE(*), D(INCFD,*)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, NLESS1
      DOUBLE PRECISION  DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, HSUM,
     *      HSUMT3, THREE, W1, W2, ZERO
      SAVE ZERO, THREE
      DOUBLE PRECISION  DPCHST
C
C  INITIALIZE.
C
      DATA  ZERO /0.D0/, THREE/3.D0/
C***FIRST EXECUTABLE STATEMENT  DPCHCI
      NLESS1 = N - 1
      DEL1 = SLOPE(1)
C
C  SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION.
C
      IF (NLESS1 .GT. 1)  GO TO 10
      D(1,1) = DEL1
      D(1,N) = DEL1
      GO TO 5000
C
C  NORMAL CASE  (N .GE. 3).
C
   10 CONTINUE
      DEL2 = SLOPE(2)
C
C  SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE
C     SHAPE-PRESERVING.
C
      HSUM = H(1) + H(2)
      W1 = (H(1) + HSUM)/HSUM
      W2 = -H(1)/HSUM
      D(1,1) = W1*DEL1 + W2*DEL2
      IF ( DPCHST(D(1,1),DEL1) .LE. ZERO)  THEN
         D(1,1) = ZERO
      ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO)  THEN
C        NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES.
         DMAX = THREE*DEL1
         IF (ABS(D(1,1)) .GT. ABS(DMAX))  D(1,1) = DMAX
      ENDIF
C
C  LOOP THROUGH INTERIOR POINTS.
C
      DO 50  I = 2, NLESS1
         IF (I .EQ. 2)  GO TO 40
C
         HSUM = H(I-1) + H(I)
         DEL1 = DEL2
         DEL2 = SLOPE(I)
   40    CONTINUE
C
C        SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC.
C
         D(1,I) = ZERO
         IF ( DPCHST(DEL1,DEL2) .LE. ZERO)  GO TO 50
C
C        USE BRODLIE MODIFICATION OF BUTLAND FORMULA.
C
         HSUMT3 = HSUM+HSUM+HSUM
         W1 = (HSUM + H(I-1))/HSUMT3
         W2 = (HSUM + H(I)  )/HSUMT3
         DMAX = MAX( ABS(DEL1), ABS(DEL2) )
         DMIN = MIN( ABS(DEL1), ABS(DEL2) )
         DRAT1 = DEL1/DMAX
         DRAT2 = DEL2/DMAX
         D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2)
C
   50 CONTINUE
C
C  SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE
C     SHAPE-PRESERVING.
C
      W1 = -H(N-1)/HSUM
      W2 = (H(N-1) + HSUM)/HSUM
      D(1,N) = W1*DEL1 + W2*DEL2
      IF ( DPCHST(D(1,N),DEL2) .LE. ZERO)  THEN
         D(1,N) = ZERO
      ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO)  THEN
C        NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES.
         DMAX = THREE*DEL2
         IF (ABS(D(1,N)) .GT. ABS(DMAX))  D(1,N) = DMAX
      ENDIF
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      RETURN
C------------- LAST LINE OF DPCHCI FOLLOWS -----------------------------
      END
*DECK DPCHCM
      SUBROUTINE DPCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR)
C***BEGIN PROLOGUE  DPCHCM
C***PURPOSE  Check a cubic Hermite function for monotonicity.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3
C***TYPE      DOUBLE PRECISION (PCHCM-S, DPCHCM-D)
C***KEYWORDS  CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION,
C             PCHIP, PIECEWISE CUBIC INTERPOLATION, UTILITY ROUTINE
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Computing & Mathematics Research Division
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C *Usage:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, ISMON(N), IERR
C        DOUBLE PRECISION  X(N), F(INCFD,N), D(INCFD,N)
C        LOGICAL  SKIP
C
C        CALL  DPCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR)
C
C *Arguments:
C
C     N:IN  is the number of data points.  (Error return if N.LT.2 .)
C
C     X:IN  is a real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F:IN  is a real*8 array of function values.  F(1+(I-1)*INCFD) is
C           the value corresponding to X(I).
C
C     D:IN  is a real*8 array of derivative values.  D(1+(I-1)*INCFD) is
C           is the value corresponding to X(I).
C
C     INCFD:IN  is the increment between successive values in F and D.
C           (Error return if  INCFD.LT.1 .)
C
C     SKIP:INOUT  is a logical variable which should be set to
C           .TRUE. if the user wishes to skip checks for validity of
C           preceding parameters, or to .FALSE. otherwise.
C           This will save time in case these checks have already
C           been performed.
C           SKIP will be set to .TRUE. on normal return.
C
C     ISMON:OUT  is an integer array indicating on which intervals the
C           PCH function defined by  N, X, F, D  is monotonic.
C           For data interval [X(I),X(I+1)],
C             ISMON(I) = -3  if function is probably decreasing;
C             ISMON(I) = -1  if function is strictly decreasing;
C             ISMON(I) =  0  if function is constant;
C             ISMON(I) =  1  if function is strictly increasing;
C             ISMON(I) =  2  if function is non-monotonic;
C             ISMON(I) =  3  if function is probably increasing.
C                If ABS(ISMON)=3, this means that the D-values are near
C                the boundary of the monotonicity region.  A small
C                increase produces non-monotonicity; decrease, strict
C                monotonicity.
C           The above applies to I=1(1)N-1.  ISMON(N) indicates whether
C              the entire function is monotonic on [X(1),X(N)].
C
C     IERR:OUT  is an error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C          (The ISMON-array has not been changed in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C
C *Description:
C
C          DPCHCM:  Piecewise Cubic Hermite -- Check Monotonicity.
C
C     Checks the piecewise cubic Hermite function defined by  N,X,F,D
C     for monotonicity.
C
C     To provide compatibility with DPCHIM and DPCHIC, includes an
C     increment between successive values of the F- and D-arrays.
C
C *Cautions:
C     This provides the same capability as old DPCHMC, except that a
C     new output value, -3, was added February 1989.  (Formerly, -3
C     and +3 were lumped together in the single value 3.)  Codes that
C     flag nonmonotonicity by "IF (ISMON.EQ.2)" need not be changed.
C     Codes that check via "IF (ISMON.GE.3)" should change the test to
C     "IF (IABS(ISMON).GE.3)".  Codes that declare monotonicity via
C     "IF (ISMON.LE.1)" should change to "IF (IABS(ISMON).LE.1)".
C
C***REFERENCES  F. N. Fritsch and R. E. Carlson, Monotone piecewise
C                 cubic interpolation, SIAM Journal on Numerical Ana-
C                 lysis 17, 2 (April 1980), pp. 238-246.
C***ROUTINES CALLED  DCHFCM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820518  DATE WRITTEN
C   820804  Converted to SLATEC library version.
C   831201  Reversed order of subscripts of F and D, so that the
C           routine will work properly when INCFD.GT.1 .  (Bug!)
C   870707  Corrected XERROR calls for d.p. name(s).
C   890206  Corrected XERROR calls.
C   890209  Added possible ISMON value of -3 and modified code so
C           that 1,3,-1 produces ISMON(N)=2, rather than 3.
C   890306  Added caution about changed output.
C   890407  Changed name from DPCHMC to DPCHCM, as requested at the
C           March 1989 SLATEC CML meeting, and made a few other
C           minor modifications necessitated by this change.
C   890407  Converted to new SLATEC format.
C   890407  Modified DESCRIPTION to LDOC format.
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920429  Revised format and order of references.  (WRB,FNF)
C***END PROLOGUE  DPCHCM
C
C  Fortran intrinsics used:  ISIGN.
C  Other routines used:  CHFCM, XERMSG.
C
C ----------------------------------------------------------------------
C
C  Programming notes:
C
C     An alternate organization would have separate loops for computing
C     ISMON(i), i=1,...,NSEG, and for the computation of ISMON(N).  The
C     first loop can be readily parallelized, since the NSEG calls to
C     CHFCM are independent.  The second loop can be cut short if
C     ISMON(N) is ever equal to 2, for it cannot be changed further.
C
C     To produce a single precision version, simply:
C        a. Change DPCHCM to PCHCM wherever it occurs,
C        b. Change DCHFCM to CHFCM wherever it occurs, and
C        c. Change the double precision declarations to real.
C
C  DECLARE ARGUMENTS.
C
      INTEGER N, INCFD, ISMON(N), IERR
      DOUBLE PRECISION  X(N), F(INCFD,N), D(INCFD,N)
      LOGICAL  SKIP
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER I, NSEG
      DOUBLE PRECISION  DELTA
      INTEGER DCHFCM
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  DPCHCM
      IF (SKIP)  GO TO 5
C
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
      SKIP = .TRUE.
C
C  FUNCTION DEFINITION IS OK -- GO ON.
C
    5 CONTINUE
      NSEG = N - 1
      DO 90  I = 1, NSEG
         DELTA = (F(1,I+1)-F(1,I))/(X(I+1)-X(I))
C                   -------------------------------
         ISMON(I) = DCHFCM (D(1,I), D(1,I+1), DELTA)
C                   -------------------------------
         IF (I .EQ. 1)  THEN
            ISMON(N) = ISMON(1)
         ELSE
C           Need to figure out cumulative monotonicity from following
C           "multiplication table":
C
C                    +        I S M O N (I)
C                     +  -3  -1   0   1   3   2
C                      +------------------------+
C               I   -3 I -3  -3  -3   2   2   2 I
C               S   -1 I -3  -1  -1   2   2   2 I
C               M    0 I -3  -1   0   1   3   2 I
C               O    1 I  2   2   1   1   3   2 I
C               N    3 I  2   2   3   3   3   2 I
C              (N)   2 I  2   2   2   2   2   2 I
C                      +------------------------+
C           Note that the 2 row and column are out of order so as not
C           to obscure the symmetry in the rest of the table.
C
C           No change needed if equal or constant on this interval or
C           already declared nonmonotonic.
            IF ( (ISMON(I).NE.ISMON(N)) .AND. (ISMON(I).NE.0)
     .                                  .AND. (ISMON(N).NE.2) )  THEN
               IF ( (ISMON(I).EQ.2) .OR. (ISMON(N).EQ.0) )  THEN
                  ISMON(N) =  ISMON(I)
               ELSE IF (ISMON(I)*ISMON(N) .LT. 0)  THEN
C                 This interval has opposite sense from curve so far.
                  ISMON(N) = 2
               ELSE
C                 At this point, both are nonzero with same sign, and
C                 we have already eliminated case both +-1.
                  ISMON(N) = ISIGN (3, ISMON(N))
               ENDIF
            ENDIF
         ENDIF
   90 CONTINUE
C
C  NORMAL RETURN.
C
      IERR = 0
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHCM',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHCM', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      RETURN
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHCM',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      RETURN
C------------- LAST LINE OF DPCHCM FOLLOWS -----------------------------
      END
*DECK DPCHCS
      SUBROUTINE DPCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR)
C***BEGIN PROLOGUE  DPCHCS
C***SUBSIDIARY
C***PURPOSE  Adjusts derivative values for DPCHIC
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      DOUBLE PRECISION (PCHCS-S, DPCHCS-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C         DPCHCS:  DPCHIC Monotonicity Switch Derivative Setter.
C
C     Called by  DPCHIC  to adjust the values of D in the vicinity of a
C     switch in direction of monotonicity, to produce a more "visually
C     pleasing" curve than that given by  DPCHIM .
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, IERR
C        DOUBLE PRECISION  SWITCH, H(N), SLOPE(N), D(INCFD,N)
C
C        CALL  DPCHCS (SWITCH, N, H, SLOPE, D, INCFD, IERR)
C
C   Parameters:
C
C     SWITCH -- (input) indicates the amount of control desired over
C           local excursions from data.
C
C     N -- (input) number of data points.  (assumes N.GT.2 .)
C
C     H -- (input) real*8 array of interval lengths.
C     SLOPE -- (input) real*8 array of data slopes.
C           If the data are (X(I),Y(I)), I=1(1)N, then these inputs are:
C                  H(I) =  X(I+1)-X(I),
C              SLOPE(I) = (Y(I+1)-Y(I))/H(I),  I=1(1)N-1.
C
C     D -- (input) real*8 array of derivative values at the data points,
C           as determined by DPCHCI.
C          (output) derivatives in the vicinity of switches in direction
C           of monotonicity may be adjusted to produce a more "visually
C           pleasing" curve.
C           The value corresponding to X(I) is stored in
C                D(1+(I-1)*INCFD),  I=1(1)N.
C           No other entries in D are changed.
C
C     INCFD -- (input) increment between successive values in D.
C           This argument is provided primarily for 2-D applications.
C
C     IERR -- (output) error flag.  should be zero.
C           If negative, trouble in DPCHSW.  (should never happen.)
C
C    -------
C    WARNING:  This routine does no validity-checking of arguments.
C    -------
C
C  Fortran intrinsics used:  ABS, MAX, MIN.
C
C***SEE ALSO  DPCHIC
C***ROUTINES CALLED  DPCHST, DPCHSW
C***REVISION HISTORY  (YYMMDD)
C   820218  DATE WRITTEN
C   820617  Redesigned to (1) fix  problem with lack of continuity
C           approaching a flat-topped peak (2) be cleaner and
C           easier to verify.
C           Eliminated subroutines PCHSA and PCHSX in the process.
C   820622  1. Limited fact to not exceed one, so computed D is a
C             convex combination of DPCHCI value and DPCHSD value.
C           2. Changed fudge from 1 to 4 (based on experiments).
C   820623  Moved PCHSD to an inline function (eliminating MSWTYP).
C   820805  Converted to SLATEC library version.
C   870707  Corrected conversion to double precision.
C   870813  Minor cosmetic changes.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Modified spacing in computation of DFLOC.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated AUTHOR section in prologue.  (WRB)
C   930503  Improved purpose.  (FNF)
C***END PROLOGUE  DPCHCS
C
C  Programming notes:
C     1. The function  DPCHST(ARG1,ARG2)  is assumed to return zero if
C        either argument is zero, +1 if they are of the same sign, and
C        -1 if they are of opposite sign.
C**End
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD, IERR
      DOUBLE PRECISION  SWITCH, H(*), SLOPE(*), D(INCFD,*)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, INDX, K, NLESS1
      DOUBLE PRECISION  DEL(3), DEXT, DFLOC, DFMX, FACT, FUDGE, ONE,
     *      SLMAX, WTAVE(2), ZERO
      SAVE ZERO, ONE, FUDGE
      DOUBLE PRECISION  DPCHST
C
C  DEFINE INLINE FUNCTION FOR WEIGHTED AVERAGE OF SLOPES.
C
      DOUBLE PRECISION  DPCHSD, S1, S2, H1, H2
      DPCHSD(S1,S2,H1,H2) = (H2/(H1+H2))*S1 + (H1/(H1+H2))*S2
C
C  INITIALIZE.
C
      DATA  ZERO /0.D0/,  ONE/1.D0/
      DATA  FUDGE /4.D0/
C***FIRST EXECUTABLE STATEMENT  DPCHCS
      IERR = 0
      NLESS1 = N - 1
C
C  LOOP OVER SEGMENTS.
C
      DO 900  I = 2, NLESS1
         IF ( DPCHST(SLOPE(I-1),SLOPE(I)) )  100, 300, 900
C             --------------------------
C
  100    CONTINUE
C
C....... SLOPE SWITCHES MONOTONICITY AT I-TH POINT .....................
C
C           DO NOT CHANGE D IF 'UP-DOWN-UP'.
            IF (I .GT. 2)  THEN
               IF ( DPCHST(SLOPE(I-2),SLOPE(I)) .GT. ZERO)  GO TO 900
C                   --------------------------
            ENDIF
            IF (I .LT. NLESS1)  THEN
               IF ( DPCHST(SLOPE(I+1),SLOPE(I-1)) .GT. ZERO)  GO TO 900
C                   ----------------------------
            ENDIF
C
C   ....... COMPUTE PROVISIONAL VALUE FOR D(1,I).
C
            DEXT = DPCHSD (SLOPE(I-1), SLOPE(I), H(I-1), H(I))
C
C   ....... DETERMINE WHICH INTERVAL CONTAINS THE EXTREMUM.
C
            IF ( DPCHST(DEXT, SLOPE(I-1)) )  200, 900, 250
C                -----------------------
C
  200       CONTINUE
C              DEXT AND SLOPE(I-1) HAVE OPPOSITE SIGNS --
C                        EXTREMUM IS IN (X(I-1),X(I)).
               K = I-1
C              SET UP TO COMPUTE NEW VALUES FOR D(1,I-1) AND D(1,I).
               WTAVE(2) = DEXT
               IF (K .GT. 1)
     *            WTAVE(1) = DPCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K))
               GO TO 400
C
  250       CONTINUE
C              DEXT AND SLOPE(I) HAVE OPPOSITE SIGNS --
C                        EXTREMUM IS IN (X(I),X(I+1)).
               K = I
C              SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1).
               WTAVE(1) = DEXT
               IF (K .LT. NLESS1)
     *            WTAVE(2) = DPCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1))
               GO TO 400
C
  300    CONTINUE
C
C....... AT LEAST ONE OF SLOPE(I-1) AND SLOPE(I) IS ZERO --
C                     CHECK FOR FLAT-TOPPED PEAK .......................
C
            IF (I .EQ. NLESS1)  GO TO 900
            IF ( DPCHST(SLOPE(I-1), SLOPE(I+1)) .GE. ZERO)  GO TO 900
C                -----------------------------
C
C           WE HAVE FLAT-TOPPED PEAK ON (X(I),X(I+1)).
            K = I
C           SET UP TO COMPUTE NEW VALUES FOR D(1,I) AND D(1,I+1).
            WTAVE(1) = DPCHSD (SLOPE(K-1), SLOPE(K), H(K-1), H(K))
            WTAVE(2) = DPCHSD (SLOPE(K), SLOPE(K+1), H(K), H(K+1))
C
  400    CONTINUE
C
C....... AT THIS POINT WE HAVE DETERMINED THAT THERE WILL BE AN EXTREMUM
C        ON (X(K),X(K+1)), WHERE K=I OR I-1, AND HAVE SET ARRAY WTAVE--
C           WTAVE(1) IS A WEIGHTED AVERAGE OF SLOPE(K-1) AND SLOPE(K),
C                    IF K.GT.1
C           WTAVE(2) IS A WEIGHTED AVERAGE OF SLOPE(K) AND SLOPE(K+1),
C                    IF K.LT.N-1
C
         SLMAX = ABS(SLOPE(K))
         IF (K .GT. 1)    SLMAX = MAX( SLMAX, ABS(SLOPE(K-1)) )
         IF (K.LT.NLESS1) SLMAX = MAX( SLMAX, ABS(SLOPE(K+1)) )
C
         IF (K .GT. 1)  DEL(1) = SLOPE(K-1) / SLMAX
         DEL(2) = SLOPE(K) / SLMAX
         IF (K.LT.NLESS1)  DEL(3) = SLOPE(K+1) / SLMAX
C
         IF ((K.GT.1) .AND. (K.LT.NLESS1))  THEN
C           NORMAL CASE -- EXTREMUM IS NOT IN A BOUNDARY INTERVAL.
            FACT = FUDGE* ABS(DEL(3)*(DEL(1)-DEL(2))*(WTAVE(2)/SLMAX))
            D(1,K) = D(1,K) + MIN(FACT,ONE)*(WTAVE(1) - D(1,K))
            FACT = FUDGE* ABS(DEL(1)*(DEL(3)-DEL(2))*(WTAVE(1)/SLMAX))
            D(1,K+1) = D(1,K+1) + MIN(FACT,ONE)*(WTAVE(2) - D(1,K+1))
         ELSE
C           SPECIAL CASE K=1 (WHICH CAN OCCUR ONLY IF I=2) OR
C                        K=NLESS1 (WHICH CAN OCCUR ONLY IF I=NLESS1).
            FACT = FUDGE* ABS(DEL(2))
            D(1,I) = MIN(FACT,ONE) * WTAVE(I-K+1)
C              NOTE THAT I-K+1 = 1 IF K=I  (=NLESS1),
C                        I-K+1 = 2 IF K=I-1(=1).
         ENDIF
C
C
C....... ADJUST IF NECESSARY TO LIMIT EXCURSIONS FROM DATA.
C
         IF (SWITCH .LE. ZERO)  GO TO 900
C
         DFLOC = H(K)*ABS(SLOPE(K))
         IF (K .GT. 1)    DFLOC = MAX( DFLOC, H(K-1)*ABS(SLOPE(K-1)) )
         IF (K.LT.NLESS1) DFLOC = MAX( DFLOC, H(K+1)*ABS(SLOPE(K+1)) )
         DFMX = SWITCH*DFLOC
         INDX = I-K+1
C        INDX = 1 IF K=I, 2 IF K=I-1.
C        ---------------------------------------------------------------
         CALL DPCHSW(DFMX, INDX, D(1,K), D(1,K+1), H(K), SLOPE(K), IERR)
C        ---------------------------------------------------------------
         IF (IERR .NE. 0)  RETURN
C
C....... END OF SEGMENT LOOP.
C
  900 CONTINUE
C
      RETURN
C------------- LAST LINE OF DPCHCS FOLLOWS -----------------------------
      END
*DECK DPCHDF
      DOUBLE PRECISION FUNCTION DPCHDF (K, X, S, IERR)
C***BEGIN PROLOGUE  DPCHDF
C***SUBSIDIARY
C***PURPOSE  Computes divided differences for DPCHCE and DPCHSP
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      DOUBLE PRECISION (PCHDF-S, DPCHDF-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C          DPCHDF:   DPCHIP Finite Difference Formula
C
C     Uses a divided difference formulation to compute a K-point approx-
C     imation to the derivative at X(K) based on the data in X and S.
C
C     Called by  DPCHCE  and  DPCHSP  to compute 3- and 4-point boundary
C     derivative approximations.
C
C ----------------------------------------------------------------------
C
C     On input:
C        K      is the order of the desired derivative approximation.
C               K must be at least 3 (error return if not).
C        X      contains the K values of the independent variable.
C               X need not be ordered, but the values **MUST** be
C               distinct.  (Not checked here.)
C        S      contains the associated slope values:
C                  S(I) = (F(I+1)-F(I))/(X(I+1)-X(I)), I=1(1)K-1.
C               (Note that S need only be of length K-1.)
C
C     On return:
C        S      will be destroyed.
C        IERR   will be set to -1 if K.LT.2 .
C        DPCHDF  will be set to the desired derivative approximation if
C               IERR=0 or to zero if IERR=-1.
C
C ----------------------------------------------------------------------
C
C***SEE ALSO  DPCHCE, DPCHSP
C***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
C                 Verlag, New York, 1978, pp. 10-16.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820503  DATE WRITTEN
C   820805  Converted to SLATEC library version.
C   870707  Corrected XERROR calls for d.p. name(s).
C   870813  Minor cosmetic changes.
C   890206  Corrected XERROR calls.
C   890411  Added SAVE statements (Vers. 3.2).
C   890411  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated AUTHOR and DATE WRITTEN sections in prologue.  (WRB)
C   920429  Revised format and order of references.  (WRB,FNF)
C   930503  Improved purpose.  (FNF)
C***END PROLOGUE  DPCHDF
C
C**End
C
C  DECLARE ARGUMENTS.
C
      INTEGER  K, IERR
      DOUBLE PRECISION  X(K), S(K)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, J
      DOUBLE PRECISION  VALUE, ZERO
      SAVE ZERO
      DATA  ZERO /0.D0/
C
C  CHECK FOR LEGAL VALUE OF K.
C
C***FIRST EXECUTABLE STATEMENT  DPCHDF
      IF (K .LT. 3)  GO TO 5001
C
C  COMPUTE COEFFICIENTS OF INTERPOLATING POLYNOMIAL.
C
      DO 10  J = 2, K-1
         DO 9  I = 1, K-J
            S(I) = (S(I+1)-S(I))/(X(I+J)-X(I))
    9    CONTINUE
   10 CONTINUE
C
C  EVALUATE DERIVATIVE AT X(K).
C
      VALUE = S(1)
      DO 20  I = 2, K-1
         VALUE = S(I) + VALUE*(X(K)-X(I))
   20 CONTINUE
C
C  NORMAL RETURN.
C
      IERR = 0
      DPCHDF = VALUE
      RETURN
C
C  ERROR RETURN.
C
 5001 CONTINUE
C     K.LT.3 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHDF', 'K LESS THAN THREE', IERR, 1)
      DPCHDF = ZERO
      RETURN
C------------- LAST LINE OF DPCHDF FOLLOWS -----------------------------
      END
*DECK DPCHFD
      SUBROUTINE DPCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR)
C***BEGIN PROLOGUE  DPCHFD
C***PURPOSE  Evaluate a piecewise cubic Hermite function and its first
C            derivative at an array of points.  May be used by itself
C            for Hermite interpolation, or as an evaluator for DPCHIM
C            or DPCHIC. If only function values are required, use
C            DPCHFE instead.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3, H1
C***TYPE      DOUBLE PRECISION (PCHFD-S, DPCHFD-D)
C***KEYWORDS  CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION,
C             HERMITE INTERPOLATION, PCHIP, PIECEWISE CUBIC EVALUATION
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          DPCHFD:  Piecewise Cubic Hermite Function and Derivative
C                  evaluator
C
C     Evaluates the cubic Hermite function defined by  N, X, F, D,  to-
C     gether with its first derivative, at the points  XE(J), J=1(1)NE.
C
C     If only function values are required, use DPCHFE, instead.
C
C     To provide compatibility with DPCHIM and DPCHIC, includes an
C     increment between successive values of the F- and D-arrays.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, NE, IERR
C        DOUBLE PRECISION  X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE),
C                          DE(NE)
C        LOGICAL  SKIP
C
C        CALL  DPCHFD (N, X, F, D, INCFD, SKIP, NE, XE, FE, DE, IERR)
C
C   Parameters:
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C
C     X -- (input) real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real*8 array of function values.  F(1+(I-1)*INCFD) is
C           the value corresponding to X(I).
C
C     D -- (input) real*8 array of derivative values.  D(1+(I-1)*INCFD)
C           is the value corresponding to X(I).
C
C     INCFD -- (input) increment between successive values in F and D.
C           (Error return if  INCFD.LT.1 .)
C
C     SKIP -- (input/output) logical variable which should be set to
C           .TRUE. if the user wishes to skip checks for validity of
C           preceding parameters, or to .FALSE. otherwise.
C           This will save time in case these checks have already
C           been performed (say, in DPCHIM or DPCHIC).
C           SKIP will be set to .TRUE. on normal return.
C
C     NE -- (input) number of evaluation points.  (Error return if
C           NE.LT.1 .)
C
C     XE -- (input) real*8 array of points at which the functions are to
C           be evaluated.
C
C
C          NOTES:
C           1. The evaluation will be most efficient if the elements
C              of XE are increasing relative to X;
C              that is,   XE(J) .GE. X(I)
C              implies    XE(K) .GE. X(I),  all K.GE.J .
C           2. If any of the XE are outside the interval [X(1),X(N)],
C              values are extrapolated from the nearest extreme cubic,
C              and a warning error is returned.
C
C     FE -- (output) real*8 array of values of the cubic Hermite
C           function defined by  N, X, F, D  at the points  XE.
C
C     DE -- (output) real*8 array of values of the first derivative of
C           the same function at the points  XE.
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           Warning error:
C              IERR.GT.0  means that extrapolation was performed at
C                 IERR points.
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C              IERR = -4  if NE.LT.1 .
C           (Output arrays have not been changed in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C              IERR = -5  if an error has occurred in the lower-level
C                         routine DCHFDV.  NB: this should never happen.
C                         Notify the author **IMMEDIATELY** if it does.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DCHFDV, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811020  DATE WRITTEN
C   820803  Minor cosmetic changes for release 1.
C   870707  Corrected XERROR calls for d.p. name(s).
C   890206  Corrected XERROR calls.
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DPCHFD
C  Programming notes:
C
C     1. To produce a single precision version, simply:
C        a. Change DPCHFD to PCHFD, and DCHFDV to CHFDV, wherever they
C           occur,
C        b. Change the double precision declaration to real,
C
C     2. Most of the coding between the call to DCHFDV and the end of
C        the IR-loop could be eliminated if it were permissible to
C        assume that XE is ordered relative to X.
C
C     3. DCHFDV does not assume that X1 is less than X2.  thus, it would
C        be possible to write a version of DPCHFD that assumes a strict-
C        ly decreasing X-array by simply running the IR-loop backwards
C        (and reversing the order of appropriate tests).
C
C     4. The present code has a minor bug, which I have decided is not
C        worth the effort that would be required to fix it.
C        If XE contains points in [X(N-1),X(N)], followed by points .LT.
C        X(N-1), followed by points .GT.X(N), the extrapolation points
C        will be counted (at least) twice in the total returned in IERR.
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD, NE, IERR
      DOUBLE PRECISION  X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*),
     * DE(*)
      LOGICAL  SKIP
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, IERC, IR, J, JFIRST, NEXT(2), NJ
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  DPCHFD
      IF (SKIP)  GO TO 5
C
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
C
C  FUNCTION DEFINITION IS OK, GO ON.
C
    5 CONTINUE
      IF ( NE.LT.1 )  GO TO 5004
      IERR = 0
      SKIP = .TRUE.
C
C  LOOP OVER INTERVALS.        (   INTERVAL INDEX IS  IL = IR-1  . )
C                              ( INTERVAL IS X(IL).LE.X.LT.X(IR) . )
      JFIRST = 1
      IR = 2
   10 CONTINUE
C
C     SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS.
C
         IF (JFIRST .GT. NE)  GO TO 5000
C
C     LOCATE ALL POINTS IN INTERVAL.
C
         DO 20  J = JFIRST, NE
            IF (XE(J) .GE. X(IR))  GO TO 30
   20    CONTINUE
         J = NE + 1
         GO TO 40
C
C     HAVE LOCATED FIRST POINT BEYOND INTERVAL.
C
   30    CONTINUE
         IF (IR .EQ. N)  J = NE + 1
C
   40    CONTINUE
         NJ = J - JFIRST
C
C     SKIP EVALUATION IF NO POINTS IN INTERVAL.
C
         IF (NJ .EQ. 0)  GO TO 50
C
C     EVALUATE CUBIC AT XE(I),  I = JFIRST (1) J-1 .
C
C       ----------------------------------------------------------------
        CALL DCHFDV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR)
     *              ,NJ, XE(JFIRST), FE(JFIRST), DE(JFIRST), NEXT, IERC)
C       ----------------------------------------------------------------
         IF (IERC .LT. 0)  GO TO 5005
C
         IF (NEXT(2) .EQ. 0)  GO TO 42
C        IF (NEXT(2) .GT. 0)  THEN
C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE
C           RIGHT OF X(IR).
C
            IF (IR .LT. N)  GO TO 41
C           IF (IR .EQ. N)  THEN
C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
               IERR = IERR + NEXT(2)
               GO TO 42
   41       CONTINUE
C           ELSE
C              WE SHOULD NEVER HAVE GOTTEN HERE.
               GO TO 5005
C           ENDIF
C        ENDIF
   42    CONTINUE
C
         IF (NEXT(1) .EQ. 0)  GO TO 49
C        IF (NEXT(1) .GT. 0)  THEN
C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE
C           LEFT OF X(IR-1).
C
            IF (IR .GT. 2)  GO TO 43
C           IF (IR .EQ. 2)  THEN
C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
               IERR = IERR + NEXT(1)
               GO TO 49
   43       CONTINUE
C           ELSE
C              XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST
C              EVALUATION INTERVAL.
C
C              FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1).
               DO 44  I = JFIRST, J-1
                  IF (XE(I) .LT. X(IR-1))  GO TO 45
   44          CONTINUE
C              NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR
C                     IN DCHFDV.
               GO TO 5005
C
   45          CONTINUE
C              RESET J.  (THIS WILL BE THE NEW JFIRST.)
               J = I
C
C              NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY.
               DO 46  I = 1, IR-1
                  IF (XE(J) .LT. X(I)) GO TO 47
   46          CONTINUE
C              NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1).
C
   47          CONTINUE
C              AT THIS POINT, EITHER  XE(J) .LT. X(1)
C                 OR      X(I-1) .LE. XE(J) .LT. X(I) .
C              RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE
C              CYCLING.
               IR = MAX(1, I-1)
C           ENDIF
C        ENDIF
   49    CONTINUE
C
         JFIRST = J
C
C     END OF IR-LOOP.
C
   50 CONTINUE
      IR = IR + 1
      IF (IR .LE. N)  GO TO 10
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHFD',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHFD', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      RETURN
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHFD',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      RETURN
C
 5004 CONTINUE
C     NE.LT.1 RETURN.
      IERR = -4
      CALL XERMSG ('SLATEC', 'DPCHFD',
     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
      RETURN
C
 5005 CONTINUE
C     ERROR RETURN FROM DCHFDV.
C   *** THIS CASE SHOULD NEVER OCCUR ***
      IERR = -5
      CALL XERMSG ('SLATEC', 'DPCHFD',
     +   'ERROR RETURN FROM DCHFDV -- FATAL', IERR, 2)
      RETURN
C------------- LAST LINE OF DPCHFD FOLLOWS -----------------------------
      END
*DECK DPCHFE
      SUBROUTINE DPCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
C***BEGIN PROLOGUE  DPCHFE
C***PURPOSE  Evaluate a piecewise cubic Hermite function at an array of
C            points.  May be used by itself for Hermite interpolation,
C            or as an evaluator for DPCHIM or DPCHIC.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3
C***TYPE      DOUBLE PRECISION (PCHFE-S, DPCHFE-D)
C***KEYWORDS  CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP,
C             PIECEWISE CUBIC EVALUATION
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          DPCHFE:  Piecewise Cubic Hermite Function Evaluator
C
C     Evaluates the cubic Hermite function defined by  N, X, F, D  at
C     the points  XE(J), J=1(1)NE.
C
C     To provide compatibility with DPCHIM and DPCHIC, includes an
C     increment between successive values of the F- and D-arrays.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, NE, IERR
C        DOUBLE PRECISION  X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE)
C        LOGICAL  SKIP
C
C        CALL  DPCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR)
C
C   Parameters:
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C
C     X -- (input) real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real*8 array of function values.  F(1+(I-1)*INCFD) is
C           the value corresponding to X(I).
C
C     D -- (input) real*8 array of derivative values.  D(1+(I-1)*INCFD)
C           is the value corresponding to X(I).
C
C     INCFD -- (input) increment between successive values in F and D.
C           (Error return if  INCFD.LT.1 .)
C
C     SKIP -- (input/output) logical variable which should be set to
C           .TRUE. if the user wishes to skip checks for validity of
C           preceding parameters, or to .FALSE. otherwise.
C           This will save time in case these checks have already
C           been performed (say, in DPCHIM or DPCHIC).
C           SKIP will be set to .TRUE. on normal return.
C
C     NE -- (input) number of evaluation points.  (Error return if
C           NE.LT.1 .)
C
C     XE -- (input) real*8 array of points at which the function is to
C           be evaluated.
C
C          NOTES:
C           1. The evaluation will be most efficient if the elements
C              of XE are increasing relative to X;
C              that is,   XE(J) .GE. X(I)
C              implies    XE(K) .GE. X(I),  all K.GE.J .
C           2. If any of the XE are outside the interval [X(1),X(N)],
C              values are extrapolated from the nearest extreme cubic,
C              and a warning error is returned.
C
C     FE -- (output) real*8 array of values of the cubic Hermite
C           function defined by  N, X, F, D  at the points  XE.
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           Warning error:
C              IERR.GT.0  means that extrapolation was performed at
C                 IERR points.
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C              IERR = -4  if NE.LT.1 .
C             (The FE-array has not been changed in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DCHFEV, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811020  DATE WRITTEN
C   820803  Minor cosmetic changes for release 1.
C   870707  Corrected XERROR calls for d.p. name(s).
C   890206  Corrected XERROR calls.
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DPCHFE
C  Programming notes:
C
C     1. To produce a single precision version, simply:
C        a. Change DPCHFE to PCHFE, and DCHFEV to CHFEV, wherever they
C           occur,
C        b. Change the double precision declaration to real,
C
C     2. Most of the coding between the call to DCHFEV and the end of
C        the IR-loop could be eliminated if it were permissible to
C        assume that XE is ordered relative to X.
C
C     3. DCHFEV does not assume that X1 is less than X2.  thus, it would
C        be possible to write a version of DPCHFE that assumes a
C        decreasing X-array by simply running the IR-loop backwards
C        (and reversing the order of appropriate tests).
C
C     4. The present code has a minor bug, which I have decided is not
C        worth the effort that would be required to fix it.
C        If XE contains points in [X(N-1),X(N)], followed by points .LT.
C        X(N-1), followed by points .GT.X(N), the extrapolation points
C        will be counted (at least) twice in the total returned in IERR.
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD, NE, IERR
      DOUBLE PRECISION  X(*), F(INCFD,*), D(INCFD,*), XE(*), FE(*)
      LOGICAL  SKIP
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, IERC, IR, J, JFIRST, NEXT(2), NJ
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  DPCHFE
      IF (SKIP)  GO TO 5
C
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
C
C  FUNCTION DEFINITION IS OK, GO ON.
C
    5 CONTINUE
      IF ( NE.LT.1 )  GO TO 5004
      IERR = 0
      SKIP = .TRUE.
C
C  LOOP OVER INTERVALS.        (   INTERVAL INDEX IS  IL = IR-1  . )
C                              ( INTERVAL IS X(IL).LE.X.LT.X(IR) . )
      JFIRST = 1
      IR = 2
   10 CONTINUE
C
C     SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS.
C
         IF (JFIRST .GT. NE)  GO TO 5000
C
C     LOCATE ALL POINTS IN INTERVAL.
C
         DO 20  J = JFIRST, NE
            IF (XE(J) .GE. X(IR))  GO TO 30
   20    CONTINUE
         J = NE + 1
         GO TO 40
C
C     HAVE LOCATED FIRST POINT BEYOND INTERVAL.
C
   30    CONTINUE
         IF (IR .EQ. N)  J = NE + 1
C
   40    CONTINUE
         NJ = J - JFIRST
C
C     SKIP EVALUATION IF NO POINTS IN INTERVAL.
C
         IF (NJ .EQ. 0)  GO TO 50
C
C     EVALUATE CUBIC AT XE(I),  I = JFIRST (1) J-1 .
C
C       ----------------------------------------------------------------
        CALL DCHFEV (X(IR-1),X(IR), F(1,IR-1),F(1,IR), D(1,IR-1),D(1,IR)
     *              ,NJ, XE(JFIRST), FE(JFIRST), NEXT, IERC)
C       ----------------------------------------------------------------
         IF (IERC .LT. 0)  GO TO 5005
C
         IF (NEXT(2) .EQ. 0)  GO TO 42
C        IF (NEXT(2) .GT. 0)  THEN
C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE
C           RIGHT OF X(IR).
C
            IF (IR .LT. N)  GO TO 41
C           IF (IR .EQ. N)  THEN
C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
               IERR = IERR + NEXT(2)
               GO TO 42
   41       CONTINUE
C           ELSE
C              WE SHOULD NEVER HAVE GOTTEN HERE.
               GO TO 5005
C           ENDIF
C        ENDIF
   42    CONTINUE
C
         IF (NEXT(1) .EQ. 0)  GO TO 49
C        IF (NEXT(1) .GT. 0)  THEN
C           IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE
C           LEFT OF X(IR-1).
C
            IF (IR .GT. 2)  GO TO 43
C           IF (IR .EQ. 2)  THEN
C              THESE ARE ACTUALLY EXTRAPOLATION POINTS.
               IERR = IERR + NEXT(1)
               GO TO 49
   43       CONTINUE
C           ELSE
C              XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST
C              EVALUATION INTERVAL.
C
C              FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1).
               DO 44  I = JFIRST, J-1
                  IF (XE(I) .LT. X(IR-1))  GO TO 45
   44          CONTINUE
C              NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR
C                     IN DCHFEV.
               GO TO 5005
C
   45          CONTINUE
C              RESET J.  (THIS WILL BE THE NEW JFIRST.)
               J = I
C
C              NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY.
               DO 46  I = 1, IR-1
                  IF (XE(J) .LT. X(I)) GO TO 47
   46          CONTINUE
C              NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1).
C
   47          CONTINUE
C              AT THIS POINT, EITHER  XE(J) .LT. X(1)
C                 OR      X(I-1) .LE. XE(J) .LT. X(I) .
C              RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE
C              CYCLING.
               IR = MAX(1, I-1)
C           ENDIF
C        ENDIF
   49    CONTINUE
C
         JFIRST = J
C
C     END OF IR-LOOP.
C
   50 CONTINUE
      IR = IR + 1
      IF (IR .LE. N)  GO TO 10
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHFE',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHFE', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      RETURN
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHFE',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      RETURN
C
 5004 CONTINUE
C     NE.LT.1 RETURN.
      IERR = -4
      CALL XERMSG ('SLATEC', 'DPCHFE',
     +   'NUMBER OF EVALUATION POINTS LESS THAN ONE', IERR, 1)
      RETURN
C
 5005 CONTINUE
C     ERROR RETURN FROM DCHFEV.
C   *** THIS CASE SHOULD NEVER OCCUR ***
      IERR = -5
      CALL XERMSG ('SLATEC', 'DPCHFE',
     +   'ERROR RETURN FROM DCHFEV -- FATAL', IERR, 2)
      RETURN
C------------- LAST LINE OF DPCHFE FOLLOWS -----------------------------
      END
*DECK DPCHIA
      DOUBLE PRECISION FUNCTION DPCHIA (N, X, F, D, INCFD, SKIP, A, B,
     +   IERR)
C***BEGIN PROLOGUE  DPCHIA
C***PURPOSE  Evaluate the definite integral of a piecewise cubic
C            Hermite function over an arbitrary interval.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3, H2A1B2
C***TYPE      DOUBLE PRECISION (PCHIA-S, DPCHIA-D)
C***KEYWORDS  CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP,
C             QUADRATURE
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          DPCHIA:  Piecewise Cubic Hermite Integrator, Arbitrary limits
C
C     Evaluates the definite integral of the cubic Hermite function
C     defined by  N, X, F, D  over the interval [A, B].
C
C     To provide compatibility with DPCHIM and DPCHIC, includes an
C     increment between successive values of the F- and D-arrays.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, IERR
C        DOUBLE PRECISION  X(N), F(INCFD,N), D(INCFD,N), A, B
C        DOUBLE PRECISION  VALUE, DPCHIA
C        LOGICAL  SKIP
C
C        VALUE = DPCHIA (N, X, F, D, INCFD, SKIP, A, B, IERR)
C
C   Parameters:
C
C     VALUE -- (output) value of the requested integral.
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C
C     X -- (input) real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real*8 array of function values.  F(1+(I-1)*INCFD) is
C           the value corresponding to X(I).
C
C     D -- (input) real*8 array of derivative values.  D(1+(I-1)*INCFD)
C           is the value corresponding to X(I).
C
C     INCFD -- (input) increment between successive values in F and D.
C           (Error return if  INCFD.LT.1 .)
C
C     SKIP -- (input/output) logical variable which should be set to
C           .TRUE. if the user wishes to skip checks for validity of
C           preceding parameters, or to .FALSE. otherwise.
C           This will save time in case these checks have already
C           been performed (say, in DPCHIM or DPCHIC).
C           SKIP will be set to .TRUE. on return with IERR.GE.0 .
C
C     A,B -- (input) the limits of integration.
C           NOTE:  There is no requirement that [A,B] be contained in
C                  [X(1),X(N)].  However, the resulting integral value
C                  will be highly suspect, if not.
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           Warning errors:
C              IERR = 1  if  A  is outside the interval [X(1),X(N)].
C              IERR = 2  if  B  is outside the interval [X(1),X(N)].
C              IERR = 3  if both of the above are true.  (Note that this
C                        means that either [A,B] contains data interval
C                        or the intervals do not intersect at all.)
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C                (VALUE will be zero in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C              IERR = -4  in case of an error return from DPCHID (which
C                         should never occur).
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  DCHFIE, DPCHID, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820730  DATE WRITTEN
C   820804  Converted to SLATEC library version.
C   870707  Corrected XERROR calls for d.p. name(s).
C   870707  Corrected conversion to double precision.
C   870813  Minor cosmetic changes.
C   890206  Corrected XERROR calls.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890703  Corrected category record.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   930503  Corrected to set VALUE=0 when IERR.lt.0.  (FNF)
C   930504  Changed DCHFIV to DCHFIE.  (FNF)
C***END PROLOGUE  DPCHIA
C
C  Programming notes:
C  1. The error flag from DPCHID is tested, because a logic flaw
C     could conceivably result in IERD=-4, which should be reported.
C**End
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD, IERR
      DOUBLE PRECISION  X(*), F(INCFD,*), D(INCFD,*), A, B
      LOGICAL  SKIP
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, IA, IB, IERD, IL, IR
      DOUBLE PRECISION  VALUE, XA, XB, ZERO
      SAVE ZERO
      DOUBLE PRECISION  DCHFIE, DPCHID
C
C  INITIALIZE.
C
      DATA  ZERO /0.D0/
C***FIRST EXECUTABLE STATEMENT  DPCHIA
      VALUE = ZERO
C
C  VALIDITY-CHECK ARGUMENTS.
C
      IF (SKIP)  GO TO 5
C
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
C
C  FUNCTION DEFINITION IS OK, GO ON.
C
    5 CONTINUE
      SKIP = .TRUE.
      IERR = 0
      IF ( (A.LT.X(1)) .OR. (A.GT.X(N)) )  IERR = IERR + 1
      IF ( (B.LT.X(1)) .OR. (B.GT.X(N)) )  IERR = IERR + 2
C
C  COMPUTE INTEGRAL VALUE.
C
      IF (A .NE. B)  THEN
         XA = MIN (A, B)
         XB = MAX (A, B)
         IF (XB .LE. X(2))  THEN
C           INTERVAL IS TO LEFT OF X(2), SO USE FIRST CUBIC.
C                   ---------------------------------------
            VALUE = DCHFIE (X(1),X(2), F(1,1),F(1,2),
     +                                 D(1,1),D(1,2), A, B)
C                   ---------------------------------------
         ELSE IF (XA .GE. X(N-1))  THEN
C           INTERVAL IS TO RIGHT OF X(N-1), SO USE LAST CUBIC.
C                   ------------------------------------------
            VALUE = DCHFIE(X(N-1),X(N), F(1,N-1),F(1,N),
     +                                  D(1,N-1),D(1,N), A, B)
C                   ------------------------------------------
         ELSE
C           'NORMAL' CASE -- XA.LT.XB, XA.LT.X(N-1), XB.GT.X(2).
C      ......LOCATE IA AND IB SUCH THAT
C               X(IA-1).LT.XA.LE.X(IA).LE.X(IB).LE.XB.LE.X(IB+1)
            IA = 1
            DO 10  I = 1, N-1
               IF (XA .GT. X(I))  IA = I + 1
   10       CONTINUE
C             IA = 1 IMPLIES XA.LT.X(1) .  OTHERWISE,
C             IA IS LARGEST INDEX SUCH THAT X(IA-1).LT.XA,.
C
            IB = N
            DO 20  I = N, IA, -1
               IF (XB .LT. X(I))  IB = I - 1
   20       CONTINUE
C             IB = N IMPLIES XB.GT.X(N) .  OTHERWISE,
C             IB IS SMALLEST INDEX SUCH THAT XB.LT.X(IB+1) .
C
C     ......COMPUTE THE INTEGRAL.
            IF (IB .LT. IA)  THEN
C              THIS MEANS IB = IA-1 AND
C                 (A,B) IS A SUBSET OF (X(IB),X(IA)).
C                      -------------------------------------------
               VALUE = DCHFIE (X(IB),X(IA), F(1,IB),F(1,IA),
     +                                      D(1,IB),D(1,IA), A, B)
C                      -------------------------------------------
            ELSE
C
C              FIRST COMPUTE INTEGRAL OVER (X(IA),X(IB)).
C                (Case (IB .EQ. IA) is taken care of by initialization
C                 of VALUE to ZERO.)
               IF (IB .GT. IA)  THEN
C                         ---------------------------------------------
                  VALUE = DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERD)
C                         ---------------------------------------------
                  IF (IERD .LT. 0)  GO TO 5004
               ENDIF
C
C              THEN ADD ON INTEGRAL OVER (XA,X(IA)).
               IF (XA .LT. X(IA))  THEN
                  IL = MAX(1, IA-1)
                  IR = IL + 1
C                                 -------------------------------------
                  VALUE = VALUE + DCHFIE (X(IL),X(IR), F(1,IL),F(1,IR),
     +                                      D(1,IL),D(1,IR), XA, X(IA))
C                                 -------------------------------------
               ENDIF
C
C              THEN ADD ON INTEGRAL OVER (X(IB),XB).
               IF (XB .GT. X(IB))  THEN
                  IR = MIN (IB+1, N)
                  IL = IR - 1
C                                 -------------------------------------
                  VALUE = VALUE + DCHFIE (X(IL),X(IR), F(1,IL),F(1,IR),
     +                                      D(1,IL),D(1,IR), X(IB), XB)
C                                 -------------------------------------
               ENDIF
C
C              FINALLY, ADJUST SIGN IF NECESSARY.
               IF (A .GT. B)  VALUE = -VALUE
            ENDIF
         ENDIF
      ENDIF
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      DPCHIA = VALUE
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHIA',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      GO TO 5000
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHIA', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      GO TO 5000
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHIA',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      GO TO 5000
C
 5004 CONTINUE
C     TROUBLE IN DPCHID.  (SHOULD NEVER OCCUR.)
      IERR = -4
      CALL XERMSG ('SLATEC', 'DPCHIA', 'TROUBLE IN DPCHID', IERR, 1)
      GO TO 5000
C------------- LAST LINE OF DPCHIA FOLLOWS -----------------------------
      END
*DECK DPCHIC
      SUBROUTINE DPCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK,
     +   IERR)
C***BEGIN PROLOGUE  DPCHIC
C***PURPOSE  Set derivatives needed to determine a piecewise monotone
C            piecewise cubic Hermite interpolant to given data.
C            User control is available over boundary conditions and/or
C            treatment of points where monotonicity switches direction.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E1A
C***TYPE      DOUBLE PRECISION (PCHIC-S, DPCHIC-D)
C***KEYWORDS  CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION,
C             PCHIP, PIECEWISE CUBIC INTERPOLATION,
C             SHAPE-PRESERVING INTERPOLATION
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C         DPCHIC:  Piecewise Cubic Hermite Interpolation Coefficients.
C
C     Sets derivatives needed to determine a piecewise monotone piece-
C     wise cubic interpolant to the data given in X and F satisfying the
C     boundary conditions specified by IC and VC.
C
C     The treatment of points where monotonicity switches direction is
C     controlled by argument SWITCH.
C
C     To facilitate two-dimensional applications, includes an increment
C     between successive values of the F- and D-arrays.
C
C     The resulting piecewise cubic Hermite function may be evaluated
C     by DPCHFE or DPCHFD.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  IC(2), N, NWK, IERR
C        DOUBLE PRECISION  VC(2), SWITCH, X(N), F(INCFD,N), D(INCFD,N),
C                          WK(NWK)
C
C        CALL DPCHIC (IC, VC, SWITCH, N, X, F, D, INCFD, WK, NWK, IERR)
C
C   Parameters:
C
C     IC -- (input) integer array of length 2 specifying desired
C           boundary conditions:
C           IC(1) = IBEG, desired condition at beginning of data.
C           IC(2) = IEND, desired condition at end of data.
C
C           IBEG = 0  for the default boundary condition (the same as
C                     used by DPCHIM).
C           If IBEG.NE.0, then its sign indicates whether the boundary
C                     derivative is to be adjusted, if necessary, to be
C                     compatible with monotonicity:
C              IBEG.GT.0  if no adjustment is to be performed.
C              IBEG.LT.0  if the derivative is to be adjusted for
C                     monotonicity.
C
C           Allowable values for the magnitude of IBEG are:
C           IBEG = 1  if first derivative at X(1) is given in VC(1).
C           IBEG = 2  if second derivative at X(1) is given in VC(1).
C           IBEG = 3  to use the 3-point difference formula for D(1).
C                     (Reverts to the default b.c. if N.LT.3 .)
C           IBEG = 4  to use the 4-point difference formula for D(1).
C                     (Reverts to the default b.c. if N.LT.4 .)
C           IBEG = 5  to set D(1) so that the second derivative is con-
C              tinuous at X(2). (Reverts to the default b.c. if N.LT.4.)
C              This option is somewhat analogous to the "not a knot"
C              boundary condition provided by DPCHSP.
C
C          NOTES (IBEG):
C           1. An error return is taken if ABS(IBEG).GT.5 .
C           2. Only in case  IBEG.LE.0  is it guaranteed that the
C              interpolant will be monotonic in the first interval.
C              If the returned value of D(1) lies between zero and
C              3*SLOPE(1), the interpolant will be monotonic.  This
C              is **NOT** checked if IBEG.GT.0 .
C           3. If IBEG.LT.0 and D(1) had to be changed to achieve mono-
C              tonicity, a warning error is returned.
C
C           IEND may take on the same values as IBEG, but applied to
C           derivative at X(N).  In case IEND = 1 or 2, the value is
C           given in VC(2).
C
C          NOTES (IEND):
C           1. An error return is taken if ABS(IEND).GT.5 .
C           2. Only in case  IEND.LE.0  is it guaranteed that the
C              interpolant will be monotonic in the last interval.
C              If the returned value of D(1+(N-1)*INCFD) lies between
C              zero and 3*SLOPE(N-1), the interpolant will be monotonic.
C              This is **NOT** checked if IEND.GT.0 .
C           3. If IEND.LT.0 and D(1+(N-1)*INCFD) had to be changed to
C              achieve monotonicity, a warning error is returned.
C
C     VC -- (input) real*8 array of length 2 specifying desired boundary
C           values, as indicated above.
C           VC(1) need be set only if IC(1) = 1 or 2 .
C           VC(2) need be set only if IC(2) = 1 or 2 .
C
C     SWITCH -- (input) indicates desired treatment of points where
C           direction of monotonicity switches:
C           Set SWITCH to zero if interpolant is required to be mono-
C           tonic in each interval, regardless of monotonicity of data.
C             NOTES:
C              1. This will cause D to be set to zero at all switch
C                 points, thus forcing extrema there.
C              2. The result of using this option with the default boun-
C                 dary conditions will be identical to using DPCHIM, but
C                 will generally cost more compute time.
C                 This option is provided only to facilitate comparison
C                 of different switch and/or boundary conditions.
C           Set SWITCH nonzero to use a formula based on the 3-point
C              difference formula in the vicinity of switch points.
C           If SWITCH is positive, the interpolant on each interval
C              containing an extremum is controlled to not deviate from
C              the data by more than SWITCH*DFLOC, where DFLOC is the
C              maximum of the change of F on this interval and its two
C              immediate neighbors.
C           If SWITCH is negative, no such control is to be imposed.
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C
C     X -- (input) real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real*8 array of dependent variable values to be
C           interpolated.  F(1+(I-1)*INCFD) is value corresponding to
C           X(I).
C
C     D -- (output) real*8 array of derivative values at the data
C           points.  These values will determine a monotone cubic
C           Hermite function on each subinterval on which the data
C           are monotonic, except possibly adjacent to switches in
C           monotonicity. The value corresponding to X(I) is stored in
C                D(1+(I-1)*INCFD),  I=1(1)N.
C           No other entries in D are changed.
C
C     INCFD -- (input) increment between successive values in F and D.
C           This argument is provided primarily for 2-D applications.
C           (Error return if  INCFD.LT.1 .)
C
C     WK -- (scratch) real*8 array of working storage.  The user may
C           wish to know that the returned values are:
C              WK(I)     = H(I)     = X(I+1) - X(I) ;
C              WK(N-1+I) = SLOPE(I) = (F(1,I+1) - F(1,I)) / H(I)
C           for  I = 1(1)N-1.
C
C     NWK -- (input) length of work array.
C           (Error return if  NWK.LT.2*(N-1) .)
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           Warning errors:
C              IERR = 1  if IBEG.LT.0 and D(1) had to be adjusted for
C                        monotonicity.
C              IERR = 2  if IEND.LT.0 and D(1+(N-1)*INCFD) had to be
C                        adjusted for monotonicity.
C              IERR = 3  if both of the above are true.
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C              IERR = -4  if ABS(IBEG).GT.5 .
C              IERR = -5  if ABS(IEND).GT.5 .
C              IERR = -6  if both of the above are true.
C              IERR = -7  if NWK.LT.2*(N-1) .
C             (The D-array has not been changed in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C
C***REFERENCES  1. F. N. Fritsch, Piecewise Cubic Hermite Interpolation
C                 Package, Report UCRL-87285, Lawrence Livermore Natio-
C                 nal Laboratory, July 1982.  [Poster presented at the
C                 SIAM 30th Anniversary Meeting, 19-23 July 1982.]
C               2. F. N. Fritsch and J. Butland, A method for construc-
C                 ting local monotone piecewise cubic interpolants, SIAM
C                 Journal on Scientific and Statistical Computing 5, 2
C                 (June 1984), pp. 300-304.
C               3. F. N. Fritsch and R. E. Carlson, Monotone piecewise
C                 cubic interpolation, SIAM Journal on Numerical Ana-
C                 lysis 17, 2 (April 1980), pp. 238-246.
C***ROUTINES CALLED  DPCHCE, DPCHCI, DPCHCS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820218  DATE WRITTEN
C   820804  Converted to SLATEC library version.
C   870707  Corrected XERROR calls for d.p. name(s).
C   870813  Updated Reference 2.
C   890206  Corrected XERROR calls.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890703  Corrected category record.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920429  Revised format and order of references.  (WRB,FNF)
C***END PROLOGUE  DPCHIC
C  Programming notes:
C
C     To produce a single precision version, simply:
C        a. Change DPCHIC to PCHIC wherever it occurs,
C        b. Change DPCHCE to PCHCE wherever it occurs,
C        c. Change DPCHCI to PCHCI wherever it occurs,
C        d. Change DPCHCS to PCHCS wherever it occurs,
C        e. Change the double precision declarations to real, and
C        f. Change the constant  ZERO  to single precision.
C
C  DECLARE ARGUMENTS.
C
      INTEGER  IC(2), N, INCFD, NWK, IERR
      DOUBLE PRECISION  VC(2), SWITCH, X(*), F(INCFD,*), D(INCFD,*),
     * WK(NWK)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, IBEG, IEND, NLESS1
      DOUBLE PRECISION  ZERO
      SAVE ZERO
      DATA  ZERO /0.D0/
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  DPCHIC
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
C
      IBEG = IC(1)
      IEND = IC(2)
      IERR = 0
      IF (ABS(IBEG) .GT. 5)  IERR = IERR - 1
      IF (ABS(IEND) .GT. 5)  IERR = IERR - 2
      IF (IERR .LT. 0)  GO TO 5004
C
C  FUNCTION DEFINITION IS OK -- GO ON.
C
      NLESS1 = N - 1
      IF ( NWK .LT. 2*NLESS1 )  GO TO 5007
C
C  SET UP H AND SLOPE ARRAYS.
C
      DO 20  I = 1, NLESS1
         WK(I) = X(I+1) - X(I)
         WK(NLESS1+I) = (F(1,I+1) - F(1,I)) / WK(I)
   20 CONTINUE
C
C  SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION.
C
      IF (NLESS1 .GT. 1)  GO TO 1000
      D(1,1) = WK(2)
      D(1,N) = WK(2)
      GO TO 3000
C
C  NORMAL CASE  (N .GE. 3) .
C
 1000 CONTINUE
C
C  SET INTERIOR DERIVATIVES AND DEFAULT END CONDITIONS.
C
C     --------------------------------------
      CALL DPCHCI (N, WK(1), WK(N), D, INCFD)
C     --------------------------------------
C
C  SET DERIVATIVES AT POINTS WHERE MONOTONICITY SWITCHES DIRECTION.
C
      IF (SWITCH .EQ. ZERO)  GO TO 3000
C     ----------------------------------------------------
      CALL DPCHCS (SWITCH, N, WK(1), WK(N), D, INCFD, IERR)
C     ----------------------------------------------------
      IF (IERR .NE. 0)  GO TO 5008
C
C  SET END CONDITIONS.
C
 3000 CONTINUE
      IF ( (IBEG.EQ.0) .AND. (IEND.EQ.0) )  GO TO 5000
C     -------------------------------------------------------
      CALL DPCHCE (IC, VC, N, X, WK(1), WK(N), D, INCFD, IERR)
C     -------------------------------------------------------
      IF (IERR .LT. 0)  GO TO 5009
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHIC',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHIC', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      RETURN
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHIC',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      RETURN
C
 5004 CONTINUE
C     IC OUT OF RANGE RETURN.
      IERR = IERR - 3
      CALL XERMSG ('SLATEC', 'DPCHIC', 'IC OUT OF RANGE', IERR, 1)
      RETURN
C
 5007 CONTINUE
C     NWK .LT. 2*(N-1)  RETURN.
      IERR = -7
      CALL XERMSG ('SLATEC', 'DPCHIC', 'WORK ARRAY TOO SMALL', IERR, 1)
      RETURN
C
 5008 CONTINUE
C     ERROR RETURN FROM DPCHCS.
      IERR = -8
      CALL XERMSG ('SLATEC', 'DPCHIC', 'ERROR RETURN FROM DPCHCS',
     +   IERR, 1)
      RETURN
C
 5009 CONTINUE
C     ERROR RETURN FROM DPCHCE.
C   *** THIS CASE SHOULD NEVER OCCUR ***
      IERR = -9
      CALL XERMSG ('SLATEC', 'DPCHIC', 'ERROR RETURN FROM DPCHCE',
     +   IERR, 1)
      RETURN
C------------- LAST LINE OF DPCHIC FOLLOWS -----------------------------
      END
*DECK DPCHID
      DOUBLE PRECISION FUNCTION DPCHID (N, X, F, D, INCFD, SKIP, IA, IB,
     +   IERR)
C***BEGIN PROLOGUE  DPCHID
C***PURPOSE  Evaluate the definite integral of a piecewise cubic
C            Hermite function over an interval whose endpoints are data
C            points.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3, H2A1B2
C***TYPE      DOUBLE PRECISION (PCHID-S, DPCHID-D)
C***KEYWORDS  CUBIC HERMITE INTERPOLATION, NUMERICAL INTEGRATION, PCHIP,
C             QUADRATURE
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          DPCHID:  Piecewise Cubic Hermite Integrator, Data limits
C
C     Evaluates the definite integral of the cubic Hermite function
C     defined by  N, X, F, D  over the interval [X(IA), X(IB)].
C
C     To provide compatibility with DPCHIM and DPCHIC, includes an
C     increment between successive values of the F- and D-arrays.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, IA, IB, IERR
C        DOUBLE PRECISION  X(N), F(INCFD,N), D(INCFD,N)
C        LOGICAL  SKIP
C
C        VALUE = DPCHID (N, X, F, D, INCFD, SKIP, IA, IB, IERR)
C
C   Parameters:
C
C     VALUE -- (output) value of the requested integral.
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C
C     X -- (input) real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real*8 array of function values.  F(1+(I-1)*INCFD) is
C           the value corresponding to X(I).
C
C     D -- (input) real*8 array of derivative values.  D(1+(I-1)*INCFD)
C           is the value corresponding to X(I).
C
C     INCFD -- (input) increment between successive values in F and D.
C           (Error return if  INCFD.LT.1 .)
C
C     SKIP -- (input/output) logical variable which should be set to
C           .TRUE. if the user wishes to skip checks for validity of
C           preceding parameters, or to .FALSE. otherwise.
C           This will save time in case these checks have already
C           been performed (say, in DPCHIM or DPCHIC).
C           SKIP will be set to .TRUE. on return with IERR = 0 or -4.
C
C     IA,IB -- (input) indices in X-array for the limits of integration.
C           both must be in the range [1,N].  (Error return if not.)
C           No restrictions on their relative values.
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C              IERR = -4  if IA or IB is out of range.
C                (VALUE will be zero in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820723  DATE WRITTEN
C   820804  Converted to SLATEC library version.
C   870707  Corrected XERROR calls for d.p. name(s).
C   870813  Minor cosmetic changes.
C   890206  Corrected XERROR calls.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890703  Corrected category record.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   930504  Corrected to set VALUE=0 when IERR.ne.0.  (FNF)
C***END PROLOGUE  DPCHID
C
C  Programming notes:
C  1. This routine uses a special formula that is valid only for
C     integrals whose limits coincide with data values.  This is
C     mathematically equivalent to, but much more efficient than,
C     calls to DCHFIE.
C**End
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD, IA, IB, IERR
      DOUBLE PRECISION  X(*), F(INCFD,*), D(INCFD,*)
      LOGICAL  SKIP
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, IUP, LOW
      DOUBLE PRECISION  H, HALF, SIX, SUM, VALUE, ZERO
      SAVE ZERO, HALF, SIX
C
C  INITIALIZE.
C
      DATA  ZERO /0.D0/,  HALF/.5D0/, SIX/6.D0/
C***FIRST EXECUTABLE STATEMENT  DPCHID
      VALUE = ZERO
C
C  VALIDITY-CHECK ARGUMENTS.
C
      IF (SKIP)  GO TO 5
C
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
C
C  FUNCTION DEFINITION IS OK, GO ON.
C
    5 CONTINUE
      SKIP = .TRUE.
      IF ((IA.LT.1) .OR. (IA.GT.N))  GO TO 5004
      IF ((IB.LT.1) .OR. (IB.GT.N))  GO TO 5004
      IERR = 0
C
C  COMPUTE INTEGRAL VALUE.
C
      IF (IA .NE. IB)  THEN
         LOW = MIN(IA, IB)
         IUP = MAX(IA, IB) - 1
         SUM = ZERO
         DO 10  I = LOW, IUP
            H = X(I+1) - X(I)
            SUM = SUM + H*( (F(1,I) + F(1,I+1)) +
     *                      (D(1,I) - D(1,I+1))*(H/SIX) )
   10    CONTINUE
         VALUE = HALF * SUM
         IF (IA .GT. IB)  VALUE = -VALUE
      ENDIF
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      DPCHID = VALUE
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHID',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      GO TO 5000
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHID', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      GO TO 5000
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHID',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      GO TO 5000
C
 5004 CONTINUE
C     IA OR IB OUT OF RANGE RETURN.
      IERR = -4
      CALL XERMSG ('SLATEC', 'DPCHID', 'IA OR IB OUT OF RANGE', IERR,
     +   1)
      GO TO 5000
C------------- LAST LINE OF DPCHID FOLLOWS -----------------------------
      END
*DECK DPCHIM
      SUBROUTINE DPCHIM (N, X, F, D, INCFD, IERR)
C***BEGIN PROLOGUE  DPCHIM
C***PURPOSE  Set derivatives needed to determine a monotone piecewise
C            cubic Hermite interpolant to given data.  Boundary values
C            are provided which are compatible with monotonicity.  The
C            interpolant will have an extremum at each point where mono-
C            tonicity switches direction.  (See DPCHIC if user control
C            is desired over boundary or switch conditions.)
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E1A
C***TYPE      DOUBLE PRECISION (PCHIM-S, DPCHIM-D)
C***KEYWORDS  CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION,
C             PCHIP, PIECEWISE CUBIC INTERPOLATION
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          DPCHIM:  Piecewise Cubic Hermite Interpolation to
C                  Monotone data.
C
C     Sets derivatives needed to determine a monotone piecewise cubic
C     Hermite interpolant to the data given in X and F.
C
C     Default boundary conditions are provided which are compatible
C     with monotonicity.  (See DPCHIC if user control of boundary con-
C     ditions is desired.)
C
C     If the data are only piecewise monotonic, the interpolant will
C     have an extremum at each point where monotonicity switches direc-
C     tion.  (See DPCHIC if user control is desired in such cases.)
C
C     To facilitate two-dimensional applications, includes an increment
C     between successive values of the F- and D-arrays.
C
C     The resulting piecewise cubic Hermite function may be evaluated
C     by DPCHFE or DPCHFD.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  N, IERR
C        DOUBLE PRECISION  X(N), F(INCFD,N), D(INCFD,N)
C
C        CALL  DPCHIM (N, X, F, D, INCFD, IERR)
C
C   Parameters:
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C           If N=2, simply does linear interpolation.
C
C     X -- (input) real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real*8 array of dependent variable values to be
C           interpolated.  F(1+(I-1)*INCFD) is value corresponding to
C           X(I).  DPCHIM is designed for monotonic data, but it will
C           work for any F-array.  It will force extrema at points where
C           monotonicity switches direction.  If some other treatment of
C           switch points is desired, DPCHIC should be used instead.
C                                     -----
C     D -- (output) real*8 array of derivative values at the data
C           points.  If the data are monotonic, these values will
C           determine a monotone cubic Hermite function.
C           The value corresponding to X(I) is stored in
C                D(1+(I-1)*INCFD),  I=1(1)N.
C           No other entries in D are changed.
C
C     INCFD -- (input) increment between successive values in F and D.
C           This argument is provided primarily for 2-D applications.
C           (Error return if  INCFD.LT.1 .)
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           Warning error:
C              IERR.GT.0  means that IERR switches in the direction
C                 of monotonicity were detected.
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C             (The D-array has not been changed in any of these cases.)
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C
C***REFERENCES  1. F. N. Fritsch and J. Butland, A method for construc-
C                 ting local monotone piecewise cubic interpolants, SIAM
C                 Journal on Scientific and Statistical Computing 5, 2
C                 (June 1984), pp. 300-304.
C               2. F. N. Fritsch and R. E. Carlson, Monotone piecewise
C                 cubic interpolation, SIAM Journal on Numerical Ana-
C                 lysis 17, 2 (April 1980), pp. 238-246.
C***ROUTINES CALLED  DPCHST, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811103  DATE WRITTEN
C   820201  1. Introduced  DPCHST  to reduce possible over/under-
C             flow problems.
C           2. Rearranged derivative formula for same reason.
C   820602  1. Modified end conditions to be continuous functions
C             of data when monotonicity switches in next interval.
C           2. Modified formulas so end conditions are less prone
C             of over/underflow problems.
C   820803  Minor cosmetic changes for release 1.
C   870707  Corrected XERROR calls for d.p. name(s).
C   870813  Updated Reference 1.
C   890206  Corrected XERROR calls.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890703  Corrected category record.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920429  Revised format and order of references.  (WRB,FNF)
C***END PROLOGUE  DPCHIM
C  Programming notes:
C
C     1. The function  DPCHST(ARG1,ARG2)  is assumed to return zero if
C        either argument is zero, +1 if they are of the same sign, and
C        -1 if they are of opposite sign.
C     2. To produce a single precision version, simply:
C        a. Change DPCHIM to PCHIM wherever it occurs,
C        b. Change DPCHST to PCHST wherever it occurs,
C        c. Change all references to the Fortran intrinsics to their
C           single precision equivalents,
C        d. Change the double precision declarations to real, and
C        e. Change the constants ZERO and THREE to single precision.
C
C  DECLARE ARGUMENTS.
C
      INTEGER  N, INCFD, IERR
      DOUBLE PRECISION  X(*), F(INCFD,*), D(INCFD,*)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  I, NLESS1
      DOUBLE PRECISION  DEL1, DEL2, DMAX, DMIN, DRAT1, DRAT2, DSAVE,
     *      H1, H2, HSUM, HSUMT3, THREE, W1, W2, ZERO
      SAVE ZERO, THREE
      DOUBLE PRECISION  DPCHST
      DATA  ZERO /0.D0/, THREE/3.D0/
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  DPCHIM
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  I = 2, N
         IF ( X(I).LE.X(I-1) )  GO TO 5003
    1 CONTINUE
C
C  FUNCTION DEFINITION IS OK, GO ON.
C
      IERR = 0
      NLESS1 = N - 1
      H1 = X(2) - X(1)
      DEL1 = (F(1,2) - F(1,1))/H1
      DSAVE = DEL1
C
C  SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION.
C
      IF (NLESS1 .GT. 1)  GO TO 10
      D(1,1) = DEL1
      D(1,N) = DEL1
      GO TO 5000
C
C  NORMAL CASE  (N .GE. 3).
C
   10 CONTINUE
      H2 = X(3) - X(2)
      DEL2 = (F(1,3) - F(1,2))/H2
C
C  SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE
C     SHAPE-PRESERVING.
C
      HSUM = H1 + H2
      W1 = (H1 + HSUM)/HSUM
      W2 = -H1/HSUM
      D(1,1) = W1*DEL1 + W2*DEL2
      IF ( DPCHST(D(1,1),DEL1) .LE. ZERO)  THEN
         D(1,1) = ZERO
      ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO)  THEN
C        NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES.
         DMAX = THREE*DEL1
         IF (ABS(D(1,1)) .GT. ABS(DMAX))  D(1,1) = DMAX
      ENDIF
C
C  LOOP THROUGH INTERIOR POINTS.
C
      DO 50  I = 2, NLESS1
         IF (I .EQ. 2)  GO TO 40
C
         H1 = H2
         H2 = X(I+1) - X(I)
         HSUM = H1 + H2
         DEL1 = DEL2
         DEL2 = (F(1,I+1) - F(1,I))/H2
   40    CONTINUE
C
C        SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC.
C
         D(1,I) = ZERO
         IF ( DPCHST(DEL1,DEL2) )  42, 41, 45
C
C        COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY.
C
   41    CONTINUE
         IF (DEL2 .EQ. ZERO)  GO TO 50
         IF ( DPCHST(DSAVE,DEL2) .LT. ZERO)  IERR = IERR + 1
         DSAVE = DEL2
         GO TO 50
C
   42    CONTINUE
         IERR = IERR + 1
         DSAVE = DEL2
         GO TO 50
C
C        USE BRODLIE MODIFICATION OF BUTLAND FORMULA.
C
   45    CONTINUE
         HSUMT3 = HSUM+HSUM+HSUM
         W1 = (HSUM + H1)/HSUMT3
         W2 = (HSUM + H2)/HSUMT3
         DMAX = MAX( ABS(DEL1), ABS(DEL2) )
         DMIN = MIN( ABS(DEL1), ABS(DEL2) )
         DRAT1 = DEL1/DMAX
         DRAT2 = DEL2/DMAX
         D(1,I) = DMIN/(W1*DRAT1 + W2*DRAT2)
C
   50 CONTINUE
C
C  SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE
C     SHAPE-PRESERVING.
C
      W1 = -H2/HSUM
      W2 = (H2 + HSUM)/HSUM
      D(1,N) = W1*DEL1 + W2*DEL2
      IF ( DPCHST(D(1,N),DEL2) .LE. ZERO)  THEN
         D(1,N) = ZERO
      ELSE IF ( DPCHST(DEL1,DEL2) .LT. ZERO)  THEN
C        NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES.
         DMAX = THREE*DEL2
         IF (ABS(D(1,N)) .GT. ABS(DMAX))  D(1,N) = DMAX
      ENDIF
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHIM',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHIM', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      RETURN
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHIM',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      RETURN
C------------- LAST LINE OF DPCHIM FOLLOWS -----------------------------
      END
*DECK DPCHKT
      SUBROUTINE DPCHKT (N, X, KNOTYP, T)
C***BEGIN PROLOGUE  DPCHKT
C***SUBSIDIARY
C***PURPOSE  Compute B-spline knot sequence for DPCHBS.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E3
C***TYPE      DOUBLE PRECISION (PCHKT-S, DPCHKT-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C     Set a knot sequence for the B-spline representation of a PCH
C     function with breakpoints X.  All knots will be at least double.
C     Endknots are set as:
C        (1) quadruple knots at endpoints if KNOTYP=0;
C        (2) extrapolate the length of end interval if KNOTYP=1;
C        (3) periodic if KNOTYP=2.
C
C  Input arguments:  N, X, KNOTYP.
C  Output arguments:  T.
C
C  Restrictions/assumptions:
C     1. N.GE.2 .  (not checked)
C     2. X(i).LT.X(i+1), i=1,...,N .  (not checked)
C     3. 0.LE.KNOTYP.LE.2 .  (Acts like KNOTYP=0 for any other value.)
C
C***SEE ALSO  DPCHBS
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   870701  DATE WRITTEN
C   900405  Converted Fortran to upper case.
C   900410  Converted prologue to SLATEC 4.0 format.
C   900410  Minor cosmetic changes.
C   900430  Produced double precision version.
C   930514  Changed NKNOTS from an output to an input variable.  (FNF)
C   930604  Removed unused variable NKNOTS from argument list.  (FNF)
C***END PROLOGUE  DPCHKT
C
C*Internal Notes:
C
C  Since this is subsidiary to DPCHBS, which validates its input before
C  calling, it is unnecessary for such validation to be done here.
C
C**End
C
C  Declare arguments.
C
      INTEGER  N, KNOTYP
      DOUBLE PRECISION  X(*), T(*)
C
C  Declare local variables.
C
      INTEGER  J, K, NDIM
      DOUBLE PRECISION  HBEG, HEND
C***FIRST EXECUTABLE STATEMENT  DPCHKT
C
C  Initialize.
C
      NDIM = 2*N
C
C  Set interior knots.
C
      J = 1
      DO 20  K = 1, N
         J = J + 2
         T(J) = X(K)
         T(J+1) = T(J)
   20 CONTINUE
C     Assertion:  At this point T(3),...,T(NDIM+2) have been set and
C                 J=NDIM+1.
C
C  Set end knots according to KNOTYP.
C
      HBEG = X(2) - X(1)
      HEND = X(N) - X(N-1)
      IF (KNOTYP.EQ.1 )  THEN
C          Extrapolate.
         T(2) = X(1) - HBEG
         T(NDIM+3) = X(N) + HEND
      ELSE IF ( KNOTYP.EQ.2 )  THEN
C          Periodic.
         T(2) = X(1) - HEND
         T(NDIM+3) = X(N) + HBEG
      ELSE
C          Quadruple end knots.
         T(2) = X(1)
         T(NDIM+3) = X(N)
      ENDIF
      T(1) = T(2)
      T(NDIM+4) = T(NDIM+3)
C
C  Terminate.
C
      RETURN
C------------- LAST LINE OF DPCHKT FOLLOWS -----------------------------
      END
*DECK DPCHNG
      SUBROUTINE DPCHNG (II, XVAL, IPLACE, SX, IX, IRCX)
C***BEGIN PROLOGUE  DPCHNG
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PCHNGS-S, DPCHNG-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C     SUBROUTINE DPCHNG CHANGES ELEMENT II IN VECTOR +/- IRCX TO THE
C     VALUE XVAL.
C     DPCHNG LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME.
C     SPARSE MATRIX ELEMENT ALTERATION SUBROUTINE.
C
C            II THE ABSOLUTE VALUE OF THIS INTEGER IS THE SUBSCRIPT FOR
C               THE ELEMENT TO BE CHANGED.
C          XVAL NEW VALUE OF THE MATRIX ELEMENT BEING CHANGED.
C     IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE.
C   SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE
C               MATRIX. THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY THE
C               PACKAGE FOR THE USER.
C          IRCX POINTS TO THE VECTOR OF THE MATRIX BEING UPDATED.
C               A NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS
C               BEING UPDATED.  A POSITIVE VALUE OF IRCX INDICATES THAT
C               COLUMN IRCX IS BEING UPDATED.  A ZERO VALUE OF IRCX IS
C               AN ERROR.
C
C     SINCE DATA ITEMS ARE KEPT SORTED IN THE SEQUENTIAL DATA STRUCTURE,
C     CHANGING A MATRIX ELEMENT CAN REQUIRE THE MOVEMENT OF ALL THE DATA
C     ITEMS IN THE MATRIX. FOR THIS REASON, IT IS SUGGESTED THAT DATA
C     ITEMS BE ADDED A COL. AT A TIME, IN ASCENDING COL. SEQUENCE.
C     FURTHERMORE, SINCE DELETING ITEMS FROM THE DATA STRUCTURE MAY ALSO
C     REQUIRE MOVING LARGE AMOUNTS OF DATA, ZERO ELEMENTS ARE EXPLICITLY
C     STORED IN THE MATRIX.
C
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LCHNGS,
C     SANDIA LABS. REPT. SAND78-0785.
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C     REVISED 811130-1000
C     REVISED YYMMDD-HHMM
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DPRWPG, IDLOC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890606  Changed references from IPLOC to IDLOC.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910403  Updated AUTHOR and DESCRIPTION sections.  (WRB)
C***END PROLOGUE  DPCHNG
      DIMENSION IX(*)
      INTEGER IDLOC
      DOUBLE PRECISION SX(*),XVAL,ZERO,ONE,SXLAST,SXVAL
      SAVE ZERO, ONE
      DATA ZERO,ONE /0.D0,1.D0/
C***FIRST EXECUTABLE STATEMENT  DPCHNG
      IOPT=1
C
C     DETERMINE NULL-CASES..
      IF(II.EQ.0) RETURN
C
C     CHECK VALIDITY OF ROW/COL. INDEX.
C
      IF (.NOT.(IRCX.EQ.0)) GO TO 20002
      NERR=55
      CALL XERMSG ('SLATEC', 'DPCHNG', 'IRCX=0', NERR, IOPT)
20002 LMX = IX(1)
C
C     LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA.
C
      IF (.NOT.(IRCX.LT.0)) GO TO 20005
C
C     CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE .LE. M AND
C     THE INDEX MUST BE .LE. N.
C
      IF (.NOT.(IX(2).LT.-IRCX .OR. IX(3).LT.ABS(II))) GO TO 20008
      NERR=55
      CALL XERMSG ('SLATEC', 'DPCHNG',
     +   'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' //
     +   'BOUNDS', NERR, IOPT)
20008 GO TO 20006
C
C     CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE .LE. N AND
C     THE INDEX MUST BE .LE. M.
C
20005 IF (.NOT.(IX(3).LT.IRCX .OR. IX(2).LT.ABS(II))) GO TO 20011
      NERR=55
      CALL XERMSG ('SLATEC', 'DPCHNG',
     +   'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' //
     +   'BOUNDS', NERR, IOPT)
20011 CONTINUE
C
C     SET I TO BE THE ELEMENT OF ROW/COLUMN J TO BE CHANGED.
C
20006 IF (.NOT.(IRCX.GT.0)) GO TO 20014
      I = ABS(II)
      J = ABS(IRCX)
      GO TO 20015
20014 I = ABS(IRCX)
      J = ABS(II)
C
C     THE INTEGER LL POINTS TO THE START OF THE MATRIX ELEMENT DATA.
C
20015 LL=IX(3)+4
      II = ABS(II)
      LPG = LMX - LL
C
C     SET IPLACE TO START OUR SCAN FOR THE ELEMENT AT THE BEGINNING
C     OF THE VECTOR.
C
      IF (.NOT.(J.EQ.1)) GO TO 20017
      IPLACE=LL+1
      GO TO 20018
20017 IPLACE=IX(J+3)+1
C
C     IEND POINTS TO THE LAST ELEMENT OF THE VECTOR TO BE SCANNED.
C
20018 IEND = IX(J+4)
C
C     SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ELEMENT.
C
      IPL = IDLOC(IPLACE,SX,IX)
      NP = ABS(IX(LMX-1))
      GO TO 20021
20020 IF (ILAST.EQ.IEND) GO TO 20022
C
C     THE VIRTUAL END OF DATA FOR THIS PAGE IS ILAST.
C
20021 ILAST = MIN(IEND,NP*LPG+LL-2)
C
C     THE RELATIVE END OF DATA FOR THIS PAGE IS IL.
C     SEARCH FOR A MATRIX VALUE WITH AN INDEX .GE. I ON THE PRESENT
C     PAGE.
C
      IL = IDLOC(ILAST,SX,IX)
      IL = MIN(IL,LMX-2)
20023 IF (.NOT.(.NOT.(IPL.GE.IL .OR. IX(IPL).GE.I))) GO TO 20024
      IPL=IPL+1
      GO TO 20023
C
C     SET IPLACE AND STORE DATA ITEM IF FOUND.
C
20024 IF (.NOT.(IX(IPL).EQ.I .AND. IPL.LE.IL)) GO TO 20025
      SX(IPL) = XVAL
      SX(LMX) = ONE
      RETURN
C
C     EXIT FROM LOOP IF ITEM WAS FOUND.
C
20025 IF(IX(IPL).GT.I .AND. IPL.LE.IL) ILAST = IEND
      IF (.NOT.(ILAST.NE.IEND)) GO TO 20028
      IPL = LL + 1
      NP = NP + 1
20028 GO TO 20020
C
C     INSERT NEW DATA ITEM INTO LOCATION AT IPLACE(IPL).
C
20022 IF (.NOT.(IPL.GT.IL.OR.(IPL.EQ.IL.AND.I.GT.IX(IPL)))) GO TO 20031
      IPL = IL + 1
      IF(IPL.EQ.LMX-1) IPL = IPL + 2
20031 IPLACE = (NP-1)*LPG + IPL
C
C     GO TO A NEW PAGE, IF NECESSARY, TO INSERT THE ITEM.
C
      IF (.NOT.(IPL.LE.LMX .OR. IX(LMX-1).GE.0)) GO TO 20034
      IPL=IDLOC(IPLACE,SX,IX)
20034 IEND = IX(LL)
      NP = ABS(IX(LMX-1))
      SXVAL = XVAL
C
C     LOOP THROUGH ALL SUBSEQUENT PAGES OF THE MATRIX MOVING DATA DOWN.
C     THIS IS NECESSARY TO MAKE ROOM FOR THE NEW MATRIX ELEMENT AND
C     KEEP THE ENTRIES SORTED.
C
      GO TO 20038
20037 IF (IX(LMX-1).LE.0) GO TO 20039
20038 ILAST = MIN(IEND,NP*LPG+LL-2)
      IL = IDLOC(ILAST,SX,IX)
      IL = MIN(IL,LMX-2)
      SXLAST = SX(IL)
      IXLAST = IX(IL)
      ISTART = IPL + 1
      IF (.NOT.(ISTART.LE.IL)) GO TO 20040
      K = ISTART + IL
      DO 50 JJ=ISTART,IL
      SX(K-JJ) = SX(K-JJ-1)
      IX(K-JJ) = IX(K-JJ-1)
50    CONTINUE
      SX(LMX) = ONE
20040 IF (.NOT.(IPL.LE.LMX)) GO TO 20043
      SX(IPL) = SXVAL
      IX(IPL) = I
      SXVAL = SXLAST
      I = IXLAST
      SX(LMX) = ONE
      IF (.NOT.(IX(LMX-1).GT.0)) GO TO 20046
      IPL = LL + 1
      NP = NP + 1
20046 CONTINUE
20043 GO TO 20037
20039 NP = ABS(IX(LMX-1))
C
C     DETERMINE IF A NEW PAGE IS TO BE CREATED FOR THE LAST ELEMENT
C     MOVED DOWN.
C
      IL = IL + 1
      IF (.NOT.(IL.EQ.LMX-1)) GO TO 20049
C
C     CREATE A NEW PAGE.
C
      IX(LMX-1) = NP
C
C     WRITE THE OLD PAGE.
C
      SX(LMX) = ZERO
      KEY = 2
      CALL DPRWPG(KEY,NP,LPG,SX,IX)
      SX(LMX) = ONE
C
C     STORE LAST ELEMENT MOVED DOWN IN A NEW PAGE.
C
      IPL = LL + 1
      NP = NP + 1
      IX(LMX-1) = -NP
      SX(IPL) = SXVAL
      IX(IPL) = I
      GO TO 20050
C
C     LAST ELEMENT MOVED REMAINED ON THE OLD PAGE.
C
20049 IF (.NOT.(IPL.NE.IL)) GO TO 20052
      SX(IL) = SXVAL
      IX(IL) = I
      SX(LMX) = ONE
20052 CONTINUE
C
C     INCREMENT POINTERS TO LAST ELEMENT IN VECTORS J,J+1,... .
C
20050 JSTART = J + 4
      JJ=JSTART
      N20055=LL
      GO TO 20056
20055 JJ=JJ+1
20056 IF ((N20055-JJ).LT.0) GO TO 20057
      IX(JJ) = IX(JJ) + 1
      IF(MOD(IX(JJ)-LL,LPG).EQ.LPG-1) IX(JJ) = IX(JJ) + 2
      GO TO 20055
C
C     IPLACE POINTS TO THE INSERTED DATA ITEM.
C
20057 IPL=IDLOC(IPLACE,SX,IX)
      RETURN
      END
*DECK DPCHSP
      SUBROUTINE DPCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
C***BEGIN PROLOGUE  DPCHSP
C***PURPOSE  Set derivatives needed to determine the Hermite represen-
C            tation of the cubic spline interpolant to given data, with
C            specified boundary conditions.
C***LIBRARY   SLATEC (PCHIP)
C***CATEGORY  E1A
C***TYPE      DOUBLE PRECISION (PCHSP-S, DPCHSP-D)
C***KEYWORDS  CUBIC HERMITE INTERPOLATION, PCHIP,
C             PIECEWISE CUBIC INTERPOLATION, SPLINE INTERPOLATION
C***AUTHOR  Fritsch, F. N., (LLNL)
C             Lawrence Livermore National Laboratory
C             P.O. Box 808  (L-316)
C             Livermore, CA  94550
C             FTS 532-4275, (510) 422-4275
C***DESCRIPTION
C
C          DPCHSP:   Piecewise Cubic Hermite Spline
C
C     Computes the Hermite representation of the cubic spline inter-
C     polant to the data given in X and F satisfying the boundary
C     conditions specified by IC and VC.
C
C     To facilitate two-dimensional applications, includes an increment
C     between successive values of the F- and D-arrays.
C
C     The resulting piecewise cubic Hermite function may be evaluated
C     by DPCHFE or DPCHFD.
C
C     NOTE:  This is a modified version of C. de Boor's cubic spline
C            routine CUBSPL.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        PARAMETER  (INCFD = ...)
C        INTEGER  IC(2), N, NWK, IERR
C        DOUBLE PRECISION  VC(2), X(N), F(INCFD,N), D(INCFD,N), WK(NWK)
C
C        CALL  DPCHSP (IC, VC, N, X, F, D, INCFD, WK, NWK, IERR)
C
C   Parameters:
C
C     IC -- (input) integer array of length 2 specifying desired
C           boundary conditions:
C           IC(1) = IBEG, desired condition at beginning of data.
C           IC(2) = IEND, desired condition at end of data.
C
C           IBEG = 0  to set D(1) so that the third derivative is con-
C              tinuous at X(2).  This is the "not a knot" condition
C              provided by de Boor's cubic spline routine CUBSPL.
C              < This is the default boundary condition. >
C           IBEG = 1  if first derivative at X(1) is given in VC(1).
C           IBEG = 2  if second derivative at X(1) is given in VC(1).
C           IBEG = 3  to use the 3-point difference formula for D(1).
C                     (Reverts to the default b.c. if N.LT.3 .)
C           IBEG = 4  to use the 4-point difference formula for D(1).
C                     (Reverts to the default b.c. if N.LT.4 .)
C          NOTES:
C           1. An error return is taken if IBEG is out of range.
C           2. For the "natural" boundary condition, use IBEG=2 and
C              VC(1)=0.
C
C           IEND may take on the same values as IBEG, but applied to
C           derivative at X(N).  In case IEND = 1 or 2, the value is
C           given in VC(2).
C
C          NOTES:
C           1. An error return is taken if IEND is out of range.
C           2. For the "natural" boundary condition, use IEND=2 and
C              VC(2)=0.
C
C     VC -- (input) real*8 array of length 2 specifying desired boundary
C           values, as indicated above.
C           VC(1) need be set only if IC(1) = 1 or 2 .
C           VC(2) need be set only if IC(2) = 1 or 2 .
C
C     N -- (input) number of data points.  (Error return if N.LT.2 .)
C
C     X -- (input) real*8 array of independent variable values.  The
C           elements of X must be strictly increasing:
C                X(I-1) .LT. X(I),  I = 2(1)N.
C           (Error return if not.)
C
C     F -- (input) real*8 array of dependent variable values to be
C           interpolated.  F(1+(I-1)*INCFD) is value corresponding to
C           X(I).
C
C     D -- (output) real*8 array of derivative values at the data
C           points.  These values will determine the cubic spline
C           interpolant with the requested boundary conditions.
C           The value corresponding to X(I) is stored in
C                D(1+(I-1)*INCFD),  I=1(1)N.
C           No other entries in D are changed.
C
C     INCFD -- (input) increment between successive values in F and D.
C           This argument is provided primarily for 2-D applications.
C           (Error return if  INCFD.LT.1 .)
C
C     WK -- (scratch) real*8 array of working storage.
C
C     NWK -- (input) length of work array.
C           (Error return if NWK.LT.2*N .)
C
C     IERR -- (output) error flag.
C           Normal return:
C              IERR = 0  (no errors).
C           "Recoverable" errors:
C              IERR = -1  if N.LT.2 .
C              IERR = -2  if INCFD.LT.1 .
C              IERR = -3  if the X-array is not strictly increasing.
C              IERR = -4  if IBEG.LT.0 or IBEG.GT.4 .
C              IERR = -5  if IEND.LT.0 of IEND.GT.4 .
C              IERR = -6  if both of the above are true.
C              IERR = -7  if NWK is too small.
C               NOTE:  The above errors are checked in the order listed,
C                   and following arguments have **NOT** been validated.
C             (The D-array has not been changed in any of these cases.)
C              IERR = -8  in case of trouble solving the linear system
C                         for the interior derivative values.
C             (The D-array may have been changed in this case.)
C             (             Do **NOT** use it!                )
C
C***REFERENCES  Carl de Boor, A Practical Guide to Splines, Springer-
C                 Verlag, New York, 1978, pp. 53-59.
C***ROUTINES CALLED  DPCHDF, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820503  DATE WRITTEN
C   820804  Converted to SLATEC library version.
C   870707  Corrected XERROR calls for d.p. name(s).
C   890206  Corrected XERROR calls.
C   890411  Added SAVE statements (Vers. 3.2).
C   890703  Corrected category record.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920429  Revised format and order of references.  (WRB,FNF)
C***END PROLOGUE  DPCHSP
C  Programming notes:
C
C     To produce a single precision version, simply:
C        a. Change DPCHSP to PCHSP wherever it occurs,
C        b. Change the double precision declarations to real, and
C        c. Change the constants ZERO, HALF, ... to single precision.
C
C  DECLARE ARGUMENTS.
C
      INTEGER  IC(2), N, INCFD, NWK, IERR
      DOUBLE PRECISION  VC(2), X(*), F(INCFD,*), D(INCFD,*), WK(2,*)
C
C  DECLARE LOCAL VARIABLES.
C
      INTEGER  IBEG, IEND, INDEX, J, NM1
      DOUBLE PRECISION  G, HALF, ONE, STEMP(3), THREE, TWO, XTEMP(4),
     *  ZERO
      SAVE ZERO, HALF, ONE, TWO, THREE
      DOUBLE PRECISION  DPCHDF
C
      DATA  ZERO /0.D0/, HALF/.5D0/, ONE/1.D0/, TWO/2.D0/, THREE/3.D0/
C
C  VALIDITY-CHECK ARGUMENTS.
C
C***FIRST EXECUTABLE STATEMENT  DPCHSP
      IF ( N.LT.2 )  GO TO 5001
      IF ( INCFD.LT.1 )  GO TO 5002
      DO 1  J = 2, N
         IF ( X(J).LE.X(J-1) )  GO TO 5003
    1 CONTINUE
C
      IBEG = IC(1)
      IEND = IC(2)
      IERR = 0
      IF ( (IBEG.LT.0).OR.(IBEG.GT.4) )  IERR = IERR - 1
      IF ( (IEND.LT.0).OR.(IEND.GT.4) )  IERR = IERR - 2
      IF ( IERR.LT.0 )  GO TO 5004
C
C  FUNCTION DEFINITION IS OK -- GO ON.
C
      IF ( NWK .LT. 2*N )  GO TO 5007
C
C  COMPUTE FIRST DIFFERENCES OF X SEQUENCE AND STORE IN WK(1,.). ALSO,
C  COMPUTE FIRST DIVIDED DIFFERENCE OF DATA AND STORE IN WK(2,.).
      DO 5  J=2,N
         WK(1,J) = X(J) - X(J-1)
         WK(2,J) = (F(1,J) - F(1,J-1))/WK(1,J)
    5 CONTINUE
C
C  SET TO DEFAULT BOUNDARY CONDITIONS IF N IS TOO SMALL.
C
      IF ( IBEG.GT.N )  IBEG = 0
      IF ( IEND.GT.N )  IEND = 0
C
C  SET UP FOR BOUNDARY CONDITIONS.
C
      IF ( (IBEG.EQ.1).OR.(IBEG.EQ.2) )  THEN
         D(1,1) = VC(1)
      ELSE IF (IBEG .GT. 2)  THEN
C        PICK UP FIRST IBEG POINTS, IN REVERSE ORDER.
         DO 10  J = 1, IBEG
            INDEX = IBEG-J+1
C           INDEX RUNS FROM IBEG DOWN TO 1.
            XTEMP(J) = X(INDEX)
            IF (J .LT. IBEG)  STEMP(J) = WK(2,INDEX)
   10    CONTINUE
C                 --------------------------------
         D(1,1) = DPCHDF (IBEG, XTEMP, STEMP, IERR)
C                 --------------------------------
         IF (IERR .NE. 0)  GO TO 5009
         IBEG = 1
      ENDIF
C
      IF ( (IEND.EQ.1).OR.(IEND.EQ.2) )  THEN
         D(1,N) = VC(2)
      ELSE IF (IEND .GT. 2)  THEN
C        PICK UP LAST IEND POINTS.
         DO 15  J = 1, IEND
            INDEX = N-IEND+J
C           INDEX RUNS FROM N+1-IEND UP TO N.
            XTEMP(J) = X(INDEX)
            IF (J .LT. IEND)  STEMP(J) = WK(2,INDEX+1)
   15    CONTINUE
C                 --------------------------------
         D(1,N) = DPCHDF (IEND, XTEMP, STEMP, IERR)
C                 --------------------------------
         IF (IERR .NE. 0)  GO TO 5009
         IEND = 1
      ENDIF
C
C --------------------( BEGIN CODING FROM CUBSPL )--------------------
C
C  **** A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(J) OF
C  F  AT X(J), J=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS ELIM-
C  INATION, WITH S(J) ENDING UP IN D(1,J), ALL J.
C     WK(1,.) AND WK(2,.) ARE USED FOR TEMPORARY STORAGE.
C
C  CONSTRUCT FIRST EQUATION FROM FIRST BOUNDARY CONDITION, OF THE FORM
C             WK(2,1)*S(1) + WK(1,1)*S(2) = D(1,1)
C
      IF (IBEG .EQ. 0)  THEN
         IF (N .EQ. 2)  THEN
C           NO CONDITION AT LEFT END AND N = 2.
            WK(2,1) = ONE
            WK(1,1) = ONE
            D(1,1) = TWO*WK(2,2)
         ELSE
C           NOT-A-KNOT CONDITION AT LEFT END AND N .GT. 2.
            WK(2,1) = WK(1,3)
            WK(1,1) = WK(1,2) + WK(1,3)
            D(1,1) =((WK(1,2) + TWO*WK(1,1))*WK(2,2)*WK(1,3)
     *                        + WK(1,2)**2*WK(2,3)) / WK(1,1)
         ENDIF
      ELSE IF (IBEG .EQ. 1)  THEN
C        SLOPE PRESCRIBED AT LEFT END.
         WK(2,1) = ONE
         WK(1,1) = ZERO
      ELSE
C        SECOND DERIVATIVE PRESCRIBED AT LEFT END.
         WK(2,1) = TWO
         WK(1,1) = ONE
         D(1,1) = THREE*WK(2,2) - HALF*WK(1,2)*D(1,1)
      ENDIF
C
C  IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND
C  CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE J-TH
C  EQUATION READS    WK(2,J)*S(J) + WK(1,J)*S(J+1) = D(1,J).
C
      NM1 = N-1
      IF (NM1 .GT. 1)  THEN
         DO 20 J=2,NM1
            IF (WK(2,J-1) .EQ. ZERO)  GO TO 5008
            G = -WK(1,J+1)/WK(2,J-1)
            D(1,J) = G*D(1,J-1)
     *                  + THREE*(WK(1,J)*WK(2,J+1) + WK(1,J+1)*WK(2,J))
            WK(2,J) = G*WK(1,J-1) + TWO*(WK(1,J) + WK(1,J+1))
   20    CONTINUE
      ENDIF
C
C  CONSTRUCT LAST EQUATION FROM SECOND BOUNDARY CONDITION, OF THE FORM
C           (-G*WK(2,N-1))*S(N-1) + WK(2,N)*S(N) = D(1,N)
C
C     IF SLOPE IS PRESCRIBED AT RIGHT END, ONE CAN GO DIRECTLY TO BACK-
C     SUBSTITUTION, SINCE ARRAYS HAPPEN TO BE SET UP JUST RIGHT FOR IT
C     AT THIS POINT.
      IF (IEND .EQ. 1)  GO TO 30
C
      IF (IEND .EQ. 0)  THEN
         IF (N.EQ.2 .AND. IBEG.EQ.0)  THEN
C           NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N = 2.
            D(1,2) = WK(2,2)
            GO TO 30
         ELSE IF ((N.EQ.2) .OR. (N.EQ.3 .AND. IBEG.EQ.0))  THEN
C           EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT) OR (N=2 AND *NOT*
C           NOT-A-KNOT AT LEFT END POINT).
            D(1,N) = TWO*WK(2,N)
            WK(2,N) = ONE
            IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
            G = -ONE/WK(2,N-1)
         ELSE
C           NOT-A-KNOT AND N .GE. 3, AND EITHER N.GT.3 OR  ALSO NOT-A-
C           KNOT AT LEFT END POINT.
            G = WK(1,N-1) + WK(1,N)
C           DO NOT NEED TO CHECK FOLLOWING DENOMINATORS (X-DIFFERENCES).
            D(1,N) = ((WK(1,N)+TWO*G)*WK(2,N)*WK(1,N-1)
     *                  + WK(1,N)**2*(F(1,N-1)-F(1,N-2))/WK(1,N-1))/G
            IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
            G = -G/WK(2,N-1)
            WK(2,N) = WK(1,N-1)
         ENDIF
      ELSE
C        SECOND DERIVATIVE PRESCRIBED AT RIGHT ENDPOINT.
         D(1,N) = THREE*WK(2,N) + HALF*WK(1,N)*D(1,N)
         WK(2,N) = TWO
         IF (WK(2,N-1) .EQ. ZERO)  GO TO 5008
         G = -ONE/WK(2,N-1)
      ENDIF
C
C  COMPLETE FORWARD PASS OF GAUSS ELIMINATION.
C
      WK(2,N) = G*WK(1,N-1) + WK(2,N)
      IF (WK(2,N) .EQ. ZERO)   GO TO 5008
      D(1,N) = (G*D(1,N-1) + D(1,N))/WK(2,N)
C
C  CARRY OUT BACK SUBSTITUTION
C
   30 CONTINUE
      DO 40 J=NM1,1,-1
         IF (WK(2,J) .EQ. ZERO)  GO TO 5008
         D(1,J) = (D(1,J) - WK(1,J)*D(1,J+1))/WK(2,J)
   40 CONTINUE
C --------------------(  END  CODING FROM CUBSPL )--------------------
C
C  NORMAL RETURN.
C
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     N.LT.2 RETURN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHSP',
     +   'NUMBER OF DATA POINTS LESS THAN TWO', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     INCFD.LT.1 RETURN.
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHSP', 'INCREMENT LESS THAN ONE', IERR,
     +   1)
      RETURN
C
 5003 CONTINUE
C     X-ARRAY NOT STRICTLY INCREASING.
      IERR = -3
      CALL XERMSG ('SLATEC', 'DPCHSP',
     +   'X-ARRAY NOT STRICTLY INCREASING', IERR, 1)
      RETURN
C
 5004 CONTINUE
C     IC OUT OF RANGE RETURN.
      IERR = IERR - 3
      CALL XERMSG ('SLATEC', 'DPCHSP', 'IC OUT OF RANGE', IERR, 1)
      RETURN
C
 5007 CONTINUE
C     NWK TOO SMALL RETURN.
      IERR = -7
      CALL XERMSG ('SLATEC', 'DPCHSP', 'WORK ARRAY TOO SMALL', IERR, 1)
      RETURN
C
 5008 CONTINUE
C     SINGULAR SYSTEM.
C   *** THEORETICALLY, THIS CAN ONLY OCCUR IF SUCCESSIVE X-VALUES   ***
C   *** ARE EQUAL, WHICH SHOULD ALREADY HAVE BEEN CAUGHT (IERR=-3). ***
      IERR = -8
      CALL XERMSG ('SLATEC', 'DPCHSP', 'SINGULAR LINEAR SYSTEM', IERR,
     +   1)
      RETURN
C
 5009 CONTINUE
C     ERROR RETURN FROM DPCHDF.
C   *** THIS CASE SHOULD NEVER OCCUR ***
      IERR = -9
      CALL XERMSG ('SLATEC', 'DPCHSP', 'ERROR RETURN FROM DPCHDF',
     +   IERR, 1)
      RETURN
C------------- LAST LINE OF DPCHSP FOLLOWS -----------------------------
      END
*DECK DPCHST
      DOUBLE PRECISION FUNCTION DPCHST (ARG1, ARG2)
C***BEGIN PROLOGUE  DPCHST
C***SUBSIDIARY
C***PURPOSE  DPCHIP Sign-Testing Routine
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      DOUBLE PRECISION (PCHST-S, DPCHST-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C         DPCHST:  DPCHIP Sign-Testing Routine.
C
C
C     Returns:
C        -1. if ARG1 and ARG2 are of opposite sign.
C         0. if either argument is zero.
C        +1. if ARG1 and ARG2 are of the same sign.
C
C     The object is to do this without multiplying ARG1*ARG2, to avoid
C     possible over/underflow problems.
C
C  Fortran intrinsics used:  SIGN.
C
C***SEE ALSO  DPCHCE, DPCHCI, DPCHCS, DPCHIM
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   811103  DATE WRITTEN
C   820805  Converted to SLATEC library version.
C   870813  Minor cosmetic changes.
C   890411  Added SAVE statements (Vers. 3.2).
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated AUTHOR and DATE WRITTEN sections in prologue.  (WRB)
C   930503  Improved purpose.  (FNF)
C***END PROLOGUE  DPCHST
C
C**End
C
C  DECLARE ARGUMENTS.
C
      DOUBLE PRECISION  ARG1, ARG2
C
C  DECLARE LOCAL VARIABLES.
C
      DOUBLE PRECISION  ONE, ZERO
      SAVE ZERO, ONE
      DATA  ZERO /0.D0/,  ONE/1.D0/
C
C  PERFORM THE TEST.
C
C***FIRST EXECUTABLE STATEMENT  DPCHST
      DPCHST = SIGN(ONE,ARG1) * SIGN(ONE,ARG2)
      IF ((ARG1.EQ.ZERO) .OR. (ARG2.EQ.ZERO))  DPCHST = ZERO
C
      RETURN
C------------- LAST LINE OF DPCHST FOLLOWS -----------------------------
      END
*DECK DPCHSW
      SUBROUTINE DPCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR)
C***BEGIN PROLOGUE  DPCHSW
C***SUBSIDIARY
C***PURPOSE  Limits excursion from data for DPCHCS
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      DOUBLE PRECISION (PCHSW-S, DPCHSW-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C         DPCHSW:  DPCHCS Switch Excursion Limiter.
C
C     Called by  DPCHCS  to adjust D1 and D2 if necessary to insure that
C     the extremum on this interval is not further than DFMAX from the
C     extreme data value.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        INTEGER  IEXTRM, IERR
C        DOUBLE PRECISION  DFMAX, D1, D2, H, SLOPE
C
C        CALL  DPCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR)
C
C   Parameters:
C
C     DFMAX -- (input) maximum allowed difference between F(IEXTRM) and
C           the cubic determined by derivative values D1,D2.  (assumes
C           DFMAX.GT.0.)
C
C     IEXTRM -- (input) index of the extreme data value.  (assumes
C           IEXTRM = 1 or 2 .  Any value .NE.1 is treated as 2.)
C
C     D1,D2 -- (input) derivative values at the ends of the interval.
C           (Assumes D1*D2 .LE. 0.)
C          (output) may be modified if necessary to meet the restriction
C           imposed by DFMAX.
C
C     H -- (input) interval length.  (Assumes  H.GT.0.)
C
C     SLOPE -- (input) data slope on the interval.
C
C     IERR -- (output) error flag.  should be zero.
C           If IERR=-1, assumption on D1 and D2 is not satisfied.
C           If IERR=-2, quadratic equation locating extremum has
C                       negative discriminant (should never occur).
C
C    -------
C    WARNING:  This routine does no validity-checking of arguments.
C    -------
C
C  Fortran intrinsics used:  ABS, SIGN, SQRT.
C
C***SEE ALSO  DPCHCS
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820218  DATE WRITTEN
C   820805  Converted to SLATEC library version.
C   870707  Corrected XERROR calls for d.p. name(s).
C   870707  Replaced DATA statement for SMALL with a use of D1MACH.
C   870813  Minor cosmetic changes.
C   890206  Corrected XERROR calls.
C   890411  1. Added SAVE statements (Vers. 3.2).
C           2. Added DOUBLE PRECISION declaration for D1MACH.
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated AUTHOR and DATE WRITTEN sections in prologue.  (WRB)
C   920526  Eliminated possible divide by zero problem.  (FNF)
C   930503  Improved purpose.  (FNF)
C***END PROLOGUE  DPCHSW
C
C**End
C
C  DECLARE ARGUMENTS.
C
      INTEGER  IEXTRM, IERR
      DOUBLE PRECISION  DFMAX, D1, D2, H, SLOPE
C
C  DECLARE LOCAL VARIABLES.
C
      DOUBLE PRECISION  CP, FACT, HPHI, LAMBDA, NU, ONE, PHI, RADCAL,
     *                  RHO, SIGMA, SMALL, THAT, THIRD, THREE, TWO, ZERO
      SAVE ZERO, ONE, TWO, THREE, FACT
      SAVE THIRD
      DOUBLE PRECISION  D1MACH
C
      DATA  ZERO /0.D0/,  ONE /1.D0/,  TWO /2.D0/, THREE /3.D0/,
     *      FACT /100.D0/
C        THIRD SHOULD BE SLIGHTLY LESS THAN 1/3.
      DATA  THIRD /0.33333D0/
C
C  NOTATION AND GENERAL REMARKS.
C
C     RHO IS THE RATIO OF THE DATA SLOPE TO THE DERIVATIVE BEING TESTED.
C     LAMBDA IS THE RATIO OF D2 TO D1.
C     THAT = T-HAT(RHO) IS THE NORMALIZED LOCATION OF THE EXTREMUM.
C     PHI IS THE NORMALIZED VALUE OF P(X)-F1 AT X = XHAT = X-HAT(RHO),
C           WHERE  THAT = (XHAT - X1)/H .
C        THAT IS, P(XHAT)-F1 = D*H*PHI,  WHERE D=D1 OR D2.
C     SIMILARLY,  P(XHAT)-F2 = D*H*(PHI-RHO) .
C
C      SMALL SHOULD BE A FEW ORDERS OF MAGNITUDE GREATER THAN MACHEPS.
C***FIRST EXECUTABLE STATEMENT  DPCHSW
      SMALL = FACT*D1MACH(4)
C
C  DO MAIN CALCULATION.
C
      IF (D1 .EQ. ZERO)  THEN
C
C        SPECIAL CASE -- D1.EQ.ZERO .
C
C          IF D2 IS ALSO ZERO, THIS ROUTINE SHOULD NOT HAVE BEEN CALLED.
         IF (D2 .EQ. ZERO)  GO TO 5001
C
         RHO = SLOPE/D2
C          EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 .
         IF (RHO .GE. THIRD)  GO TO 5000
         THAT = (TWO*(THREE*RHO-ONE)) / (THREE*(TWO*RHO-ONE))
         PHI = THAT**2 * ((THREE*RHO-ONE)/THREE)
C
C          CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 .
         IF (IEXTRM .NE. 1)  PHI = PHI - RHO
C
C          TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY.
         HPHI = H * ABS(PHI)
         IF (HPHI*ABS(D2) .GT. DFMAX)  THEN
C           AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK.
            D2 = SIGN (DFMAX/HPHI, D2)
         ENDIF
      ELSE
C
         RHO = SLOPE/D1
         LAMBDA = -D2/D1
         IF (D2 .EQ. ZERO)  THEN
C
C           SPECIAL CASE -- D2.EQ.ZERO .
C
C             EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 .
            IF (RHO .GE. THIRD)  GO TO 5000
            CP = TWO - THREE*RHO
            NU = ONE - TWO*RHO
            THAT = ONE / (THREE*NU)
         ELSE
            IF (LAMBDA .LE. ZERO)  GO TO 5001
C
C           NORMAL CASE -- D1 AND D2 BOTH NONZERO, OPPOSITE SIGNS.
C
            NU = ONE - LAMBDA - TWO*RHO
            SIGMA = ONE - RHO
            CP = NU + SIGMA
            IF (ABS(NU) .GT. SMALL)  THEN
               RADCAL = (NU - (TWO*RHO+ONE))*NU + SIGMA**2
               IF (RADCAL .LT. ZERO)  GO TO 5002
               THAT = (CP - SQRT(RADCAL)) / (THREE*NU)
            ELSE
               THAT = ONE/(TWO*SIGMA)
            ENDIF
         ENDIF
         PHI = THAT*((NU*THAT - CP)*THAT + ONE)
C
C          CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 .
         IF (IEXTRM .NE. 1)  PHI = PHI - RHO
C
C          TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY.
         HPHI = H * ABS(PHI)
         IF (HPHI*ABS(D1) .GT. DFMAX)  THEN
C           AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK.
            D1 = SIGN (DFMAX/HPHI, D1)
            D2 = -LAMBDA*D1
         ENDIF
      ENDIF
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      IERR = 0
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     D1 AND D2 BOTH ZERO, OR BOTH NONZERO AND SAME SIGN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHSW', 'D1 AND/OR D2 INVALID', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     NEGATIVE VALUE OF RADICAL (SHOULD NEVER OCCUR).
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHSW', 'NEGATIVE RADICAL', IERR, 1)
      RETURN
C------------- LAST LINE OF DPCHSW FOLLOWS -----------------------------
      END
*DECK DPCOEF
      SUBROUTINE DPCOEF (L, C, TC, A)
C***BEGIN PROLOGUE  DPCOEF
C***PURPOSE  Convert the DPOLFT coefficients to Taylor series form.
C***LIBRARY   SLATEC
C***CATEGORY  K1A1A2
C***TYPE      DOUBLE PRECISION (PCOEF-S, DPCOEF-D)
C***KEYWORDS  CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT
C***AUTHOR  Shampine, L. F., (SNLA)
C           Davenport, S. M., (SNLA)
C***DESCRIPTION
C
C     Abstract
C
C     DPOLFT  computes the least squares polynomial fit of degree  L  as
C     a sum of orthogonal polynomials.  DPCOEF  changes this fit to its
C     Taylor expansion about any point  C , i.e. writes the polynomial
C     as a sum of powers of (X-C).  Taking  C=0.  gives the polynomial
C     in powers of X, but a suitable non-zero  C  often leads to
C     polynomials which are better scaled and more accurately evaluated.
C
C     The parameters for  DPCOEF  are
C
C     INPUT -- All TYPE REAL variables are DOUBLE PRECISION
C         L -      Indicates the degree of polynomial to be changed to
C                  its Taylor expansion.  To obtain the Taylor
C                  coefficients in reverse order, input  L  as the
C                  negative of the degree desired.  The absolute value
C                  of L  must be less than or equal to NDEG, the highest
C                  degree polynomial fitted by  DPOLFT .
C         C -      The point about which the Taylor expansion is to be
C                  made.
C         A -      Work and output array containing values from last
C                  call to  DPOLFT .
C
C     OUTPUT -- All TYPE REAL variables are DOUBLE PRECISION
C         TC -     Vector containing the first LL+1 Taylor coefficients
C                  where LL=ABS(L).  If  L.GT.0 , the coefficients are
C                  in the usual Taylor series order, i.e.
C                    P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N
C                  If L .LT. 0, the coefficients are in reverse order,
C                  i.e.
C                    P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1)
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  DP1VLU
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPCOEF
C
      INTEGER I,L,LL,LLP1,LLP2,NEW,NR
      DOUBLE PRECISION A(*),C,FAC,SAVE,TC(*)
C***FIRST EXECUTABLE STATEMENT  DPCOEF
      LL = ABS(L)
      LLP1 = LL + 1
      CALL DP1VLU (LL,LL,C,TC(1),TC(2),A)
      IF (LL .LT. 2) GO TO 2
      FAC = 1.0D0
      DO 1 I = 3,LLP1
        FAC = FAC*(I-1)
 1      TC(I) = TC(I)/FAC
 2    IF (L .GE. 0) GO TO 4
      NR = LLP1/2
      LLP2 = LL + 2
      DO 3 I = 1,NR
        SAVE = TC(I)
        NEW = LLP2 - I
        TC(I) = TC(NEW)
 3      TC(NEW) = SAVE
 4    RETURN
      END
*DECK DPFQAD
      SUBROUTINE DPFQAD (F, LDC, C, XI, LXI, K, ID, X1, X2, TOL, QUAD,
     +   IERR)
C***BEGIN PROLOGUE  DPFQAD
C***PURPOSE  Compute the integral on (X1,X2) of a product of a
C            function F and the ID-th derivative of a B-spline,
C            (PP-representation).
C***LIBRARY   SLATEC
C***CATEGORY  H2A2A1, E3, K6
C***TYPE      DOUBLE PRECISION (PFQAD-S, DPFQAD-D)
C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract    **** a double precision routine ****
C         DPFQAD computes the integral on (X1,X2) of a product of a
C         function F and the ID-th derivative of a B-spline, using the
C         PP-representation (C,XI,LXI,K).  (X1,X2) is normally a sub-
C         interval of XI(1) .LE. X .LE. XI(LXI+1).  An integration
C         routine, DPPGQ8 (a modification of GAUS8), integrates the
C         product on subintervals of (X1,X2) formed by the included
C         break points.  Integration outside of (XI(1),XI(LXI+1)) is
C         permitted provided F is defined.
C
C         The maximum number of significant digits obtainable in
C         DBSQAD is the smaller of 18 and the number of digits
C         carried in double precision arithmetic.
C
C     Description of arguments
C         Input      F,C,XI,X1,X2,TOL are double precision
C           F      - external function of one argument for the
C                    integrand PF(X)=F(X)*DPPVAL(LDC,C,XI,LXI,K,ID,X,
C                    INPPV)
C           LDC    - leading dimension of matrix C, LDC .GE. K
C           C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI
C           XI(*)  - break point array of length LXI+1
C           LXI    - number of polynomial pieces
C           K      - order of B-spline, K .GE. 1
C           ID     - order of the spline derivative, 0 .LE. ID .LE. K-1
C                    ID=0 gives the spline function
C           X1,X2  - end points of quadrature interval, normally in
C                    XI(1) .LE. X .LE. XI(LXI+1)
C           TOL    - desired accuracy for the quadrature, suggest
C                    10.*DTOL .LT. TOL .LE. 0.1 where DTOL is the
C                    maximum of 1.0D-18 and double precision unit
C                    roundoff for the machine = D1MACH(4)
C
C         Output     QUAD is double precision
C           QUAD   - integral of PF(X) on (X1,X2)
C           IERR   - a status code
C                    IERR=1 normal return
C                         2 some quadrature does not meet the
C                           requested tolerance
C
C     Error Conditions
C         Improper input is a fatal error.
C         Some quadrature does not meet the requested tolerance.
C
C***REFERENCES  D. E. Amos, Quadrature subroutines for splines and
C                 B-splines, Report SAND79-1825, Sandia Laboratories,
C                 December 1979.
C***ROUTINES CALLED  D1MACH, DINTRV, DPPGQ8, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPFQAD
C
      INTEGER ID,IERR,IFLG,ILO,IL1,IL2,INPPV,K,LDC,LEFT,LXI,MF1,MF2
      DOUBLE PRECISION A,AA,ANS,B,BB,C,Q,QUAD,TA,TB,TOL,WTOL,XI,X1,X2
      DOUBLE PRECISION D1MACH, F
      DIMENSION XI(*), C(LDC,*)
      EXTERNAL F
C
C***FIRST EXECUTABLE STATEMENT  DPFQAD
      IERR = 1
      QUAD = 0.0D0
      IF(K.LT.1) GO TO 100
      IF(LDC.LT.K) GO TO 105
      IF(ID.LT.0 .OR. ID.GE.K) GO TO 110
      IF(LXI.LT.1) GO TO 115
      WTOL = D1MACH(4)
      WTOL = MAX(WTOL,1.0D-18)
      IF (TOL.LT.WTOL .OR. TOL.GT.0.1D0) GO TO 20
      AA = MIN(X1,X2)
      BB = MAX(X1,X2)
      IF (AA.EQ.BB) RETURN
      ILO = 1
      CALL DINTRV(XI, LXI, AA, ILO, IL1, MF1)
      CALL DINTRV(XI, LXI, BB, ILO, IL2, MF2)
      Q = 0.0D0
      INPPV = 1
      DO 10 LEFT=IL1,IL2
        TA = XI(LEFT)
        A = MAX(AA,TA)
        IF (LEFT.EQ.1) A = AA
        TB = BB
        IF (LEFT.LT.LXI) TB = XI(LEFT+1)
        B = MIN(BB,TB)
        CALL DPPGQ8(F,LDC,C,XI,LXI,K,ID,A,B,INPPV,TOL,ANS,IFLG)
        IF (IFLG.GT.1) IERR = 2
        Q = Q + ANS
   10 CONTINUE
      IF (X1.GT.X2) Q = -Q
      QUAD = Q
      RETURN
C
   20 CONTINUE
      CALL XERMSG ('SLATEC', 'DPFQAD',
     +   'TOL IS LESS DTOL OR GREATER THAN 0.1', 2, 1)
      RETURN
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'DPFQAD', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'DPFQAD', 'LDC DOES NOT SATISFY LDC.GE.K',
     +   2, 1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'DPFQAD',
     +   'ID DOES NOT SATISFY 0.LE.ID.LT.K', 2, 1)
      RETURN
  115 CONTINUE
      CALL XERMSG ('SLATEC', 'DPFQAD', 'LXI DOES NOT SATISFY LXI.GE.1',
     +   2, 1)
      RETURN
      END
*DECK DPIGMR
      SUBROUTINE DPIGMR (N, R0, SR, SZ, JSCAL, MAXL, MAXLP1, KMP, NRSTS,
     +   JPRE, MATVEC, MSOLVE, NMSL, Z, V, HES, Q, LGMR, RPAR, IPAR, WK,
     +   DL, RHOL, NRMAX, B, BNRM, X, XL, ITOL, TOL, NELT, IA, JA, A,
     +   ISYM, IUNIT, IFLAG, ERR)
C***BEGIN PROLOGUE  DPIGMR
C***SUBSIDIARY
C***PURPOSE  Internal routine for DGMRES.
C***LIBRARY   SLATEC (SLAP)
C***CATEGORY  D2A4, D2B4
C***TYPE      DOUBLE PRECISION (SPIGMR-S, DPIGMR-D)
C***KEYWORDS  GENERALIZED MINIMUM RESIDUAL, ITERATIVE PRECONDITION,
C             NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE
C***AUTHOR  Brown, Peter, (LLNL), pnbrown@llnl.gov
C           Hindmarsh, Alan, (LLNL), alanh@llnl.gov
C           Seager, Mark K., (LLNL), seager@llnl.gov
C             Lawrence Livermore National Laboratory
C             PO Box 808, L-60
C             Livermore, CA 94550 (510) 423-3141
C***DESCRIPTION
C         This routine solves the linear system A * Z = R0 using a
C         scaled preconditioned version of the generalized minimum
C         residual method.  An initial guess of Z = 0 is assumed.
C
C *Usage:
C      INTEGER N, JSCAL, MAXL, MAXLP1, KMP, NRSTS, JPRE, NMSL, LGMR
C      INTEGER IPAR(USER DEFINED), NRMAX, ITOL, NELT, IA(NELT), JA(NELT)
C      INTEGER ISYM, IUNIT, IFLAG
C      DOUBLE PRECISION R0(N), SR(N), SZ(N), Z(N), V(N,MAXLP1),
C     $                 HES(MAXLP1,MAXL), Q(2*MAXL), RPAR(USER DEFINED),
C     $                 WK(N), DL(N), RHOL, B(N), BNRM, X(N), XL(N),
C     $                 TOL, A(NELT), ERR
C      EXTERNAL MATVEC, MSOLVE
C
C      CALL DPIGMR(N, R0, SR, SZ, JSCAL, MAXL, MAXLP1, KMP,
C     $     NRSTS, JPRE, MATVEC, MSOLVE, NMSL, Z, V, HES, Q, LGMR,
C     $     RPAR, IPAR, WK, DL, RHOL, NRMAX, B, BNRM, X, XL,
C     $     ITOL, TOL, NELT, IA, JA, A, ISYM, IUNIT, IFLAG, ERR)
C
C *Arguments:
C N      :IN       Integer
C         The order of the matrix A, and the lengths
C         of the vectors SR, SZ, R0 and Z.
C R0     :IN       Double Precision R0(N)
C         R0 = the right hand side of the system A*Z = R0.
C         R0 is also used as workspace when computing
C         the final approximation.
C         (R0 is the same as V(*,MAXL+1) in the call to DPIGMR.)
C SR     :IN       Double Precision SR(N)
C         SR is a vector of length N containing the non-zero
C         elements of the diagonal scaling matrix for R0.
C SZ     :IN       Double Precision SZ(N)
C         SZ is a vector of length N containing the non-zero
C         elements of the diagonal scaling matrix for Z.
C JSCAL  :IN       Integer
C         A flag indicating whether arrays SR and SZ are used.
C         JSCAL=0 means SR and SZ are not used and the
C                 algorithm will perform as if all
C                 SR(i) = 1 and SZ(i) = 1.
C         JSCAL=1 means only SZ is used, and the algorithm
C                 performs as if all SR(i) = 1.
C         JSCAL=2 means only SR is used, and the algorithm
C                 performs as if all SZ(i) = 1.
C         JSCAL=3 means both SR and SZ are used.
C MAXL   :IN       Integer
C         The maximum allowable order of the matrix H.
C MAXLP1 :IN       Integer
C         MAXPL1 = MAXL + 1, used for dynamic dimensioning of HES.
C KMP    :IN       Integer
C         The number of previous vectors the new vector VNEW
C         must be made orthogonal to.  (KMP .le. MAXL)
C NRSTS  :IN       Integer
C         Counter for the number of restarts on the current
C         call to DGMRES.  If NRSTS .gt. 0, then the residual
C         R0 is already scaled, and so scaling of it is
C         not necessary.
C JPRE   :IN       Integer
C         Preconditioner type flag.
C MATVEC :EXT      External.
C         Name of a routine which performs the matrix vector multiply
C         Y = A*X given A and X.  The name of the MATVEC routine must
C         be declared external in the calling program.  The calling
C         sequence to MATVEC is:
C             CALL MATVEC(N, X, Y, NELT, IA, JA, A, ISYM)
C         where N is the number of unknowns, Y is the product A*X
C         upon return, X is an input vector, and NELT is the number of
C         non-zeros in the SLAP IA, JA, A storage for the matrix A.
C         ISYM is a flag which, if non-zero, denotes that A is
C         symmetric and only the lower or upper triangle is stored.
C MSOLVE :EXT      External.
C         Name of the routine which solves a linear system Mz = r for
C         z given r with the preconditioning matrix M (M is supplied via
C         RPAR and IPAR arrays.  The name of the MSOLVE routine must
C         be declared external in the calling program.  The calling
C         sequence to MSOLVE is:
C             CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR)
C         Where N is the number of unknowns, R is the right-hand side
C         vector and Z is the solution upon return.  NELT, IA, JA, A and
C         ISYM are defined as below.  RPAR is a double precision array
C         that can be used to pass necessary preconditioning information
C         and/or workspace to MSOLVE.  IPAR is an integer work array
C         for the same purpose as RPAR.
C NMSL   :OUT      Integer
C         The number of calls to MSOLVE.
C Z      :OUT      Double Precision Z(N)
C         The final computed approximation to the solution
C         of the system A*Z = R0.
C V      :OUT      Double Precision V(N,MAXLP1)
C         The N by (LGMR+1) array containing the LGMR
C         orthogonal vectors V(*,1) to V(*,LGMR).
C HES    :OUT      Double Precision HES(MAXLP1,MAXL)
C         The upper triangular factor of the QR decomposition
C         of the (LGMR+1) by LGMR upper Hessenberg matrix whose
C         entries are the scaled inner-products of A*V(*,I)
C         and V(*,K).
C Q      :OUT      Double Precision Q(2*MAXL)
C         A double precision array of length 2*MAXL containing the
C         components of the Givens rotations used in the QR
C         decomposition of HES.  It is loaded in DHEQR and used in
C         DHELS.
C LGMR   :OUT      Integer
C         The number of iterations performed and
C         the current order of the upper Hessenberg
C         matrix HES.
C RPAR   :IN       Double Precision RPAR(USER DEFINED)
C         Double Precision workspace passed directly to the MSOLVE
C         routine.
C IPAR   :IN       Integer IPAR(USER DEFINED)
C         Integer workspace passed directly to the MSOLVE routine.
C WK     :IN       Double Precision WK(N)
C         A double precision work array of length N used by routines
C         MATVEC and MSOLVE.
C DL     :INOUT    Double Precision DL(N)
C         On input, a double precision work array of length N used for
C         calculation of the residual norm RHO when the method is
C         incomplete (KMP.lt.MAXL), and/or when using restarting.
C         On output, the scaled residual vector RL.  It is only loaded
C         when performing restarts of the Krylov iteration.
C RHOL   :OUT      Double Precision
C         A double precision scalar containing the norm of the final
C         residual.
C NRMAX  :IN       Integer
C         The maximum number of restarts of the Krylov iteration.
C         NRMAX .gt. 0 means restarting is active, while
C         NRMAX = 0 means restarting is not being used.
C B      :IN       Double Precision B(N)
C         The right hand side of the linear system A*X = b.
C BNRM   :IN       Double Precision
C         The scaled norm of b.
C X      :IN       Double Precision X(N)
C         The current approximate solution as of the last
C         restart.
C XL     :IN       Double Precision XL(N)
C         An array of length N used to hold the approximate
C         solution X(L) when ITOL=11.
C ITOL   :IN       Integer
C         A flag to indicate the type of convergence criterion
C         used.  See the driver for its description.
C TOL    :IN       Double Precision
C         The tolerance on residuals R0-A*Z in scaled norm.
C NELT   :IN       Integer
C         The length of arrays IA, JA and A.
C IA     :IN       Integer IA(NELT)
C         An integer array of length NELT containing matrix data.
C         It is passed directly to the MATVEC and MSOLVE routines.
C JA     :IN       Integer JA(NELT)
C         An integer array of length NELT containing matrix data.
C         It is passed directly to the MATVEC and MSOLVE routines.
C A      :IN       Double Precision A(NELT)
C         A double precision array of length NELT containing matrix
C         data. It is passed directly to the MATVEC and MSOLVE routines.
C ISYM   :IN       Integer
C         A flag to indicate symmetric matrix storage.
C         If ISYM=0, all non-zero entries of the matrix are
C         stored.  If ISYM=1, the matrix is symmetric and
C         only the upper or lower triangular part is stored.
C IUNIT  :IN       Integer
C         The i/o unit number for writing intermediate residual
C         norm values.
C IFLAG  :OUT      Integer
C         An integer error flag..
C         0 means convergence in LGMR iterations, LGMR.le.MAXL.
C         1 means the convergence test did not pass in MAXL
C           iterations, but the residual norm is .lt. norm(R0),
C           and so Z is computed.
C         2 means the convergence test did not pass in MAXL
C           iterations, residual .ge. norm(R0), and Z = 0.
C ERR    :OUT      Double Precision.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C
C *Cautions:
C     This routine will attempt to write to the Fortran logical output
C     unit IUNIT, if IUNIT .ne. 0.  Thus, the user must make sure that
C     this logical unit is attached to a file or terminal before calling
C     this routine with a non-zero value for IUNIT.  This routine does
C     not check for the validity of a non-zero IUNIT unit number.
C
C***SEE ALSO  DGMRES
C***ROUTINES CALLED  DAXPY, DCOPY, DHELS, DHEQR, DNRM2, DORTH, DRLCAL,
C                    DSCAL, ISDGMR
C***REVISION HISTORY  (YYMMDD)
C   890404  DATE WRITTEN
C   890404  Previous REVISION DATE
C   890915  Made changes requested at July 1989 CML Meeting.  (MKS)
C   890922  Numerous changes to prologue to make closer to SLATEC
C           standard.  (FNF)
C   890929  Numerous changes to reduce SP/DP differences.  (FNF)
C   910411  Prologue converted to Version 4.0 format.  (BAB)
C   910502  Removed MATVEC and MSOLVE from ROUTINES CALLED list.  (FNF)
C   910506  Made subsidiary to DGMRES.  (FNF)
C   920511  Added complete declaration section.  (WRB)
C***END PROLOGUE  DPIGMR
C         The following is for optimized compilation on LLNL/LTSS Crays.
CLLL. OPTIMIZE
C     .. Scalar Arguments ..
      DOUBLE PRECISION BNRM, ERR, RHOL, TOL
      INTEGER IFLAG, ISYM, ITOL, IUNIT, JPRE, JSCAL, KMP, LGMR, MAXL,
     +        MAXLP1, N, NELT, NMSL, NRMAX, NRSTS
C     .. Array Arguments ..
      DOUBLE PRECISION A(NELT), B(*), DL(*), HES(MAXLP1,*), Q(*), R0(*),
     +                 RPAR(*), SR(*), SZ(*), V(N,*), WK(*), X(*),
     +                 XL(*), Z(*)
      INTEGER IA(NELT), IPAR(*), JA(NELT)
C     .. Subroutine Arguments ..
      EXTERNAL MATVEC, MSOLVE
C     .. Local Scalars ..
      DOUBLE PRECISION C, DLNRM, PROD, R0NRM, RHO, S, SNORMW, TEM
      INTEGER I, I2, INFO, IP1, ITER, ITMAX, J, K, LL, LLP1
C     .. External Functions ..
      DOUBLE PRECISION DNRM2
      INTEGER ISDGMR
      EXTERNAL DNRM2, ISDGMR
C     .. External Subroutines ..
      EXTERNAL DAXPY, DCOPY, DHELS, DHEQR, DORTH, DRLCAL, DSCAL
C     .. Intrinsic Functions ..
      INTRINSIC ABS
C***FIRST EXECUTABLE STATEMENT  DPIGMR
C
C         Zero out the Z array.
C
      DO 5 I = 1,N
         Z(I) = 0
 5    CONTINUE
C
      IFLAG = 0
      LGMR = 0
      NMSL = 0
C         Load ITMAX, the maximum number of iterations.
      ITMAX =(NRMAX+1)*MAXL
C   -------------------------------------------------------------------
C         The initial residual is the vector R0.
C         Apply left precon. if JPRE < 0 and this is not a restart.
C         Apply scaling to R0 if JSCAL = 2 or 3.
C   -------------------------------------------------------------------
      IF ((JPRE .LT. 0) .AND.(NRSTS .EQ. 0)) THEN
         CALL DCOPY(N, R0, 1, WK, 1)
         CALL MSOLVE(N, WK, R0, NELT, IA, JA, A, ISYM, RPAR, IPAR)
         NMSL = NMSL + 1
      ENDIF
      IF (((JSCAL.EQ.2) .OR.(JSCAL.EQ.3)) .AND.(NRSTS.EQ.0)) THEN
         DO 10 I = 1,N
            V(I,1) = R0(I)*SR(I)
 10      CONTINUE
      ELSE
         DO 20 I = 1,N
            V(I,1) = R0(I)
 20      CONTINUE
      ENDIF
      R0NRM = DNRM2(N, V, 1)
      ITER = NRSTS*MAXL
C
C         Call stopping routine ISDGMR.
C
      IF (ISDGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE,
     $    NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, V(1,1), Z, WK,
     $    RPAR, IPAR, R0NRM, BNRM, SR, SZ, JSCAL,
     $    KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM,
     $    HES, JPRE) .NE. 0) RETURN
      TEM = 1.0D0/R0NRM
      CALL DSCAL(N, TEM, V(1,1), 1)
C
C         Zero out the HES array.
C
      DO 50 J = 1,MAXL
         DO 40 I = 1,MAXLP1
            HES(I,J) = 0
 40      CONTINUE
 50   CONTINUE
C   -------------------------------------------------------------------
C         Main loop to compute the vectors V(*,2) to V(*,MAXL).
C         The running product PROD is needed for the convergence test.
C   -------------------------------------------------------------------
      PROD = 1
      DO 90 LL = 1,MAXL
         LGMR = LL
C   -------------------------------------------------------------------
C        Unscale  the  current V(LL)  and store  in WK.  Call routine
C        MSOLVE    to   compute(M-inverse)*WK,   where    M   is  the
C        preconditioner matrix.  Save the answer in Z.   Call routine
C        MATVEC to compute  VNEW  = A*Z,  where  A is  the the system
C        matrix.  save the answer in  V(LL+1).  Scale V(LL+1).   Call
C        routine DORTH  to  orthogonalize the    new vector VNEW   =
C        V(*,LL+1).  Call routine DHEQR to update the factors of HES.
C   -------------------------------------------------------------------
        IF ((JSCAL .EQ. 1) .OR.(JSCAL .EQ. 3)) THEN
           DO 60 I = 1,N
              WK(I) = V(I,LL)/SZ(I)
 60        CONTINUE
        ELSE
           CALL DCOPY(N, V(1,LL), 1, WK, 1)
        ENDIF
        IF (JPRE .GT. 0) THEN
           CALL MSOLVE(N, WK, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR)
           NMSL = NMSL + 1
           CALL MATVEC(N, Z, V(1,LL+1), NELT, IA, JA, A, ISYM)
        ELSE
           CALL MATVEC(N, WK, V(1,LL+1), NELT, IA, JA, A, ISYM)
        ENDIF
        IF (JPRE .LT. 0) THEN
           CALL DCOPY(N, V(1,LL+1), 1, WK, 1)
           CALL MSOLVE(N,WK,V(1,LL+1),NELT,IA,JA,A,ISYM,RPAR,IPAR)
           NMSL = NMSL + 1
        ENDIF
        IF ((JSCAL .EQ. 2) .OR.(JSCAL .EQ. 3)) THEN
           DO 65 I = 1,N
              V(I,LL+1) = V(I,LL+1)*SR(I)
 65        CONTINUE
        ENDIF
        CALL DORTH(V(1,LL+1), V, HES, N, LL, MAXLP1, KMP, SNORMW)
        HES(LL+1,LL) = SNORMW
        CALL DHEQR(HES, MAXLP1, LL, Q, INFO, LL)
        IF (INFO .EQ. LL) GO TO 120
C   -------------------------------------------------------------------
C         Update RHO, the estimate of the norm of the residual R0-A*ZL.
C         If KMP <  MAXL, then the vectors V(*,1),...,V(*,LL+1) are not
C         necessarily orthogonal for LL > KMP.  The vector DL must then
C         be computed, and its norm used in the calculation of RHO.
C   -------------------------------------------------------------------
        PROD = PROD*Q(2*LL)
        RHO = ABS(PROD*R0NRM)
        IF ((LL.GT.KMP) .AND.(KMP.LT.MAXL)) THEN
           IF (LL .EQ. KMP+1) THEN
              CALL DCOPY(N, V(1,1), 1, DL, 1)
              DO 75 I = 1,KMP
                 IP1 = I + 1
                 I2 = I*2
                 S = Q(I2)
                 C = Q(I2-1)
                 DO 70 K = 1,N
                    DL(K) = S*DL(K) + C*V(K,IP1)
 70              CONTINUE
 75           CONTINUE
           ENDIF
           S = Q(2*LL)
           C = Q(2*LL-1)/SNORMW
           LLP1 = LL + 1
           DO 80 K = 1,N
              DL(K) = S*DL(K) + C*V(K,LLP1)
 80        CONTINUE
           DLNRM = DNRM2(N, DL, 1)
           RHO = RHO*DLNRM
        ENDIF
        RHOL = RHO
C   -------------------------------------------------------------------
C         Test for convergence.  If passed, compute approximation ZL.
C         If failed and LL < MAXL, then continue iterating.
C   -------------------------------------------------------------------
        ITER = NRSTS*MAXL + LGMR
        IF (ISDGMR(N, B, X, XL, NELT, IA, JA, A, ISYM, MSOLVE,
     $      NMSL, ITOL, TOL, ITMAX, ITER, ERR, IUNIT, DL, Z, WK,
     $      RPAR, IPAR, RHOL, BNRM, SR, SZ, JSCAL,
     $      KMP, LGMR, MAXL, MAXLP1, V, Q, SNORMW, PROD, R0NRM,
     $      HES, JPRE) .NE. 0) GO TO 200
        IF (LL .EQ. MAXL) GO TO 100
C   -------------------------------------------------------------------
C         Rescale so that the norm of V(1,LL+1) is one.
C   -------------------------------------------------------------------
        TEM = 1.0D0/SNORMW
        CALL DSCAL(N, TEM, V(1,LL+1), 1)
 90   CONTINUE
 100  CONTINUE
      IF (RHO .LT. R0NRM) GO TO 150
 120  CONTINUE
      IFLAG = 2
C
C         Load approximate solution with zero.
C
      DO 130 I = 1,N
         Z(I) = 0
 130  CONTINUE
      RETURN
 150  IFLAG = 1
C
C         Tolerance not met, but residual norm reduced.
C
      IF (NRMAX .GT. 0) THEN
C
C        If performing restarting (NRMAX > 0)  calculate the residual
C        vector RL and  store it in the DL  array.  If the incomplete
C        version is being used (KMP < MAXL) then DL has  already been
C        calculated up to a scaling factor.   Use DRLCAL to calculate
C        the scaled residual vector.
C
         CALL DRLCAL(N, KMP, MAXL, MAXL, V, Q, DL, SNORMW, PROD,
     $        R0NRM)
      ENDIF
C   -------------------------------------------------------------------
C         Compute the approximation ZL to the solution.  Since the
C         vector Z was used as workspace, and the initial guess
C         of the linear iteration is zero, Z must be reset to zero.
C   -------------------------------------------------------------------
 200  CONTINUE
      LL = LGMR
      LLP1 = LL + 1
      DO 210 K = 1,LLP1
         R0(K) = 0
 210  CONTINUE
      R0(1) = R0NRM
      CALL DHELS(HES, MAXLP1, LL, Q, R0)
      DO 220 K = 1,N
         Z(K) = 0
 220  CONTINUE
      DO 230 I = 1,LL
         CALL DAXPY(N, R0(I), V(1,I), 1, Z, 1)
 230  CONTINUE
      IF ((JSCAL .EQ. 1) .OR.(JSCAL .EQ. 3)) THEN
         DO 240 I = 1,N
            Z(I) = Z(I)/SZ(I)
 240     CONTINUE
      ENDIF
      IF (JPRE .GT. 0) THEN
         CALL DCOPY(N, Z, 1, WK, 1)
         CALL MSOLVE(N, WK, Z, NELT, IA, JA, A, ISYM, RPAR, IPAR)
         NMSL = NMSL + 1
      ENDIF
      RETURN
C------------- LAST LINE OF DPIGMR FOLLOWS ----------------------------
      END
*DECK DPINCW
      SUBROUTINE DPINCW (MRELAS, NVARS, LMX, LBM, NPP, JSTRT, IBASIS,
     +   IMAT, IBRC, IPR, IWR, IND, IBB, COSTSC, GG, ERDNRM, DULNRM,
     +   AMAT, BASMAT, CSC, WR, WW, RZ, RG, COSTS, COLNRM, DUALS,
     +   STPEDG)
C***BEGIN PROLOGUE  DPINCW
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPINCW-S, DPINCW-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/,
C     REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/,/SDOT/DDOT/.
C
C     THIS SUBPROGRAM IS PART OF THE DSPLP( ) PACKAGE.
C     IT IMPLEMENTS THE PROCEDURE (INITIALIZE REDUCED COSTS AND
C     STEEPEST EDGE WEIGHTS).
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DCOPY, DDOT, DPRWPG, IDLOC, LA05BD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   890606  Changed references from IPLOC to IDLOC.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DPINCW
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),RZ(*),RG(*),
     * COSTS(*),COLNRM(*),DUALS(*),COSTSC,ERDNRM,DULNRM,GG,ONE,RZJ,
     * SCALR,ZERO,RCOST,CNORM
      DOUBLE PRECISION DDOT
      LOGICAL STPEDG,PAGEPL,TRANS
C***FIRST EXECUTABLE STATEMENT  DPINCW
      LPG=LMX-(NVARS+4)
      ZERO=0.D0
      ONE=1.D0
C
C     FORM REDUCED COSTS, RZ(*), AND STEEPEST EDGE WEIGHTS, RG(*).
      PAGEPL=.TRUE.
      RZ(1)=ZERO
      CALL DCOPY(NVARS+MRELAS,RZ,0,RZ,1)
      RG(1)=ONE
      CALL DCOPY(NVARS+MRELAS,RG,0,RG,1)
      NNEGRC=0
      J=JSTRT
20002 IF (.NOT.(IBB(J).LE.0)) GO TO 20004
      PAGEPL=.TRUE.
      GO TO 20005
C
C     THESE ARE NONBASIC INDEPENDENT VARIABLES. THE COLS. ARE IN SPARSE
C     MATRIX FORMAT.
20004 IF (.NOT.(J.LE.NVARS)) GO TO 20007
      RZJ=COSTSC*COSTS(J)
      WW(1)=ZERO
      CALL DCOPY(MRELAS,WW,0,WW,1)
      IF (.NOT.(J.EQ.1)) GO TO 20010
      ILOW=NVARS+5
      GO TO 20011
20010 ILOW=IMAT(J+3)+1
20011 CONTINUE
      IF (.NOT.(PAGEPL)) GO TO 20013
      IL1=IDLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20016
      ILOW=ILOW+2
      IL1=IDLOC(ILOW,AMAT,IMAT)
20016 CONTINUE
      IPAGE=ABS(IMAT(LMX-1))
      GO TO 20014
20013 IL1=IHI+1
20014 CONTINUE
      IHI=IMAT(J+4)-(ILOW-IL1)
20019 IU1=MIN(LMX-2,IHI)
      IF (.NOT.(IL1.GT.IU1)) GO TO 20021
      GO TO 20020
20021 CONTINUE
      DO 60 I=IL1,IU1
      RZJ=RZJ-AMAT(I)*DUALS(IMAT(I))
      WW(IMAT(I))=AMAT(I)*CSC(J)
60    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20024
      GO TO 20020
20024 CONTINUE
      IPAGE=IPAGE+1
      KEY=1
      CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20019
20020 PAGEPL=IHI.EQ.(LMX-2)
      RZ(J)=RZJ*CSC(J)
      IF (.NOT.(STPEDG)) GO TO 20027
      TRANS=.FALSE.
      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      RG(J)=DDOT(MRELAS,WW,1,WW,1)+ONE
20027 CONTINUE
C
C     THESE ARE NONBASIC DEPENDENT VARIABLES. THE COLS. ARE IMPLICITLY
C     DEFINED.
      GO TO 20008
20007 PAGEPL=.TRUE.
      WW(1)=ZERO
      CALL DCOPY(MRELAS,WW,0,WW,1)
      SCALR=-ONE
      IF (IND(J).EQ.2) SCALR=ONE
      I=J-NVARS
      RZ(J)=-SCALR*DUALS(I)
      WW(I)=SCALR
      IF (.NOT.(STPEDG)) GO TO 20030
      TRANS=.FALSE.
      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      RG(J)=DDOT(MRELAS,WW,1,WW,1)+ONE
20030 CONTINUE
      CONTINUE
20008 CONTINUE
C
20005 RCOST=RZ(J)
      IF (MOD(IBB(J),2).EQ.0) RCOST=-RCOST
      IF (IND(J).EQ.4) RCOST=-ABS(RCOST)
      CNORM=ONE
      IF (J.LE.NVARS) CNORM=COLNRM(J)
      IF (RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO) NNEGRC=NNEGRC+1
      J=MOD(J,MRELAS+NVARS)+1
      IF (.NOT.(NNEGRC.GE.NPP .OR. J.EQ.JSTRT)) GO TO 20033
      GO TO 20003
20033 GO TO 20002
20003 JSTRT=J
      RETURN
      END
*DECK DPINIT
      SUBROUTINE DPINIT (MRELAS, NVARS, COSTS, BL, BU, IND, PRIMAL,
     +   INFO, AMAT, CSC, COSTSC, COLNRM, XLAMDA, ANORM, RHS, RHSNRM,
     +   IBASIS, IBB, IMAT, LOPT)
C***BEGIN PROLOGUE  DPINIT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPINIT-S, DPINIT-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/SCOPY/DCOPY/
C     REVISED 810519-0900
C     REVISED YYMMDD-HHMM
C
C     INITIALIZATION SUBROUTINE FOR DSPLP(*) PACKAGE.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DASUM, DCOPY, DPNNZR
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   891009  Removed unreferenced variable.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DPINIT
      DOUBLE PRECISION AIJ,AMAT(*),ANORM,BL(*),BU(*),CMAX,
     * COLNRM(*),COSTS(*),COSTSC,CSC(*),CSUM,ONE,PRIMAL(*),
     * RHS(*),RHSNRM,SCALR,TESTSC,XLAMDA,ZERO
      DOUBLE PRECISION DASUM
      INTEGER IBASIS(*),IBB(*),IMAT(*),IND(*)
      LOGICAL CONTIN,USRBAS,COLSCP,CSTSCP,MINPRB,LOPT(8)
C
C***FIRST EXECUTABLE STATEMENT  DPINIT
      ZERO=0.D0
      ONE=1.D0
      CONTIN=LOPT(1)
      USRBAS=LOPT(2)
      COLSCP=LOPT(5)
      CSTSCP=LOPT(6)
      MINPRB=LOPT(7)
C
C     SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS.
      GO TO 30001
C
C     INITIALIZE ACTIVE BASIS MATRIX.
20002 CONTINUE
      GO TO 30002
20003 RETURN
C
C     PROCEDURE (SCALE DATA. NORMALIZE BOUNDS. FORM COLUMN CHECK SUMS)
C
C     DO COLUMN SCALING IF NOT PROVIDED BY THE USER.
30001 IF (.NOT.(.NOT. COLSCP)) GO TO 20004
      J=1
      N20007=NVARS
      GO TO 20008
20007 J=J+1
20008 IF ((N20007-J).LT.0) GO TO 20009
      CMAX=ZERO
      I=0
20011 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.EQ.0)) GO TO 20013
      GO TO 20012
20013 CONTINUE
      CMAX=MAX(CMAX,ABS(AIJ))
      GO TO 20011
20012 IF (.NOT.(CMAX.EQ.ZERO)) GO TO 20016
      CSC(J)=ONE
      GO TO 20017
20016 CSC(J)=ONE/CMAX
20017 CONTINUE
      GO TO 20007
20009 CONTINUE
C
C     FORM CHECK SUMS OF COLUMNS. COMPUTE MATRIX NORM OF SCALED MATRIX.
20004 ANORM = ZERO
      J=1
      N20019=NVARS
      GO TO 20020
20019 J=J+1
20020 IF ((N20019-J).LT.0) GO TO 20021
      PRIMAL(J)=ZERO
      CSUM = ZERO
      I=0
20023 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20025
      GO TO 20024
20025 CONTINUE
      PRIMAL(J)=PRIMAL(J)+AIJ
      CSUM = CSUM+ABS(AIJ)
      GO TO 20023
20024 IF (IND(J).EQ.2) CSC(J)=-CSC(J)
      PRIMAL(J)=PRIMAL(J)*CSC(J)
      COLNRM(J)=ABS(CSC(J)*CSUM)
      ANORM = MAX(ANORM,COLNRM(J))
      GO TO 20019
C
C     IF THE USER HAS NOT PROVIDED COST VECTOR SCALING THEN SCALE IT
C     USING THE MAX. NORM OF THE TRANSFORMED COST VECTOR, IF NONZERO.
20021 TESTSC=ZERO
      J=1
      N20028=NVARS
      GO TO 20029
20028 J=J+1
20029 IF ((N20028-J).LT.0) GO TO 20030
      TESTSC=MAX(TESTSC,ABS(CSC(J)*COSTS(J)))
      GO TO 20028
20030 IF (.NOT.(.NOT.CSTSCP)) GO TO 20032
      IF (.NOT.(TESTSC.GT.ZERO)) GO TO 20035
      COSTSC=ONE/TESTSC
      GO TO 20036
20035 COSTSC=ONE
20036 CONTINUE
      CONTINUE
20032 XLAMDA=(COSTSC+COSTSC)*TESTSC
      IF (XLAMDA.EQ.ZERO) XLAMDA=ONE
C
C     IF MAXIMIZATION PROBLEM, THEN CHANGE SIGN OF COSTSC AND LAMDA
C     =WEIGHT FOR PENALTY-FEASIBILITY METHOD.
      IF (.NOT.(.NOT.MINPRB)) GO TO 20038
      COSTSC=-COSTSC
20038 GO TO 20002
C:CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (INITIALIZE RHS(*),IBASIS(*), AND IBB(*))
C
C     INITIALLY SET RIGHT-HAND SIDE VECTOR TO ZERO.
30002 CALL DCOPY(MRELAS,ZERO,0,RHS,1)
C
C     TRANSLATE RHS ACCORDING TO CLASSIFICATION OF INDEPENDENT VARIABLES
      J=1
      N20041=NVARS
      GO TO 20042
20041 J=J+1
20042 IF ((N20041-J).LT.0) GO TO 20043
      IF (.NOT.(IND(J).EQ.1)) GO TO 20045
      SCALR=-BL(J)
      GO TO 20046
20045 IF (.NOT.(IND(J).EQ.2)) GO TO 10001
      SCALR=-BU(J)
      GO TO 20046
10001 IF (.NOT.(IND(J).EQ.3)) GO TO 10002
      SCALR=-BL(J)
      GO TO 20046
10002 IF (.NOT.(IND(J).EQ.4)) GO TO 10003
      SCALR=ZERO
10003 CONTINUE
20046 CONTINUE
      IF (.NOT.(SCALR.NE.ZERO)) GO TO 20048
      I=0
20051 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20053
      GO TO 20052
20053 CONTINUE
      RHS(I)=SCALR*AIJ+RHS(I)
      GO TO 20051
20052 CONTINUE
20048 CONTINUE
      GO TO 20041
C
C     TRANSLATE RHS ACCORDING TO CLASSIFICATION OF DEPENDENT VARIABLES.
20043 I=NVARS+1
      N20056=NVARS+MRELAS
      GO TO 20057
20056 I=I+1
20057 IF ((N20056-I).LT.0) GO TO 20058
      IF (.NOT.(IND(I).EQ.1)) GO TO 20060
      SCALR=BL(I)
      GO TO 20061
20060 IF (.NOT.(IND(I).EQ.2)) GO TO 10004
      SCALR=BU(I)
      GO TO 20061
10004 IF (.NOT.(IND(I).EQ.3)) GO TO 10005
      SCALR=BL(I)
      GO TO 20061
10005 IF (.NOT.(IND(I).EQ.4)) GO TO 10006
      SCALR=ZERO
10006 CONTINUE
20061 CONTINUE
      RHS(I-NVARS)=RHS(I-NVARS)+SCALR
      GO TO 20056
20058 RHSNRM=DASUM(MRELAS,RHS,1)
C
C     IF THIS IS NOT A CONTINUATION OR THE USER HAS NOT PROVIDED THE
C     INITIAL BASIS, THEN THE INITIAL BASIS IS COMPRISED OF THE
C     DEPENDENT VARIABLES.
      IF (.NOT.(.NOT.(CONTIN .OR. USRBAS))) GO TO 20063
      J=1
      N20066=MRELAS
      GO TO 20067
20066 J=J+1
20067 IF ((N20066-J).LT.0) GO TO 20068
      IBASIS(J)=NVARS+J
      GO TO 20066
20068 CONTINUE
C
C     DEFINE THE ARRAY IBB(*)
20063 J=1
      N20070=NVARS+MRELAS
      GO TO 20071
20070 J=J+1
20071 IF ((N20070-J).LT.0) GO TO 20072
      IBB(J)=1
      GO TO 20070
20072 J=1
      N20074=MRELAS
      GO TO 20075
20074 J=J+1
20075 IF ((N20074-J).LT.0) GO TO 20076
      IBB(IBASIS(J))=-1
      GO TO 20074
C
C     DEFINE THE REST OF IBASIS(*)
20076 IP=MRELAS
      J=1
      N20078=NVARS+MRELAS
      GO TO 20079
20078 J=J+1
20079 IF ((N20078-J).LT.0) GO TO 20080
      IF (.NOT.(IBB(J).GT.0)) GO TO 20082
      IP=IP+1
      IBASIS(IP)=J
20082 GO TO 20078
20080 GO TO 20003
      END
*DECK DPINTM
      SUBROUTINE DPINTM (M, N, SX, IX, LMX, IPAGEF)
C***BEGIN PROLOGUE  DPINTM
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PINITM-S, DPINTM-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C     DPINTM LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME.
C     THE MATRIX IS STORED BY COLUMNS.
C     SPARSE MATRIX INITIALIZATION SUBROUTINE.
C
C            M=NUMBER OF ROWS OF THE MATRIX.
C            N=NUMBER OF COLUMNS OF THE MATRIX.
C  SX(*),IX(*)=THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE
C              MATRIX.  THESE ARRAYS ARE AUTOMATICALLY MAINTAINED BY
C              THE PACKAGE FOR THE USER.
C          LMX=LENGTH OF THE WORK ARRAY SX(*).
C              LMX MUST BE AT LEAST N+7 WHERE
C              FOR GREATEST EFFICIENCY LMX SHOULD BE AT LEAST N+NZ+6
C              WHERE NZ IS THE MAXIMUM NUMBER OF NONZEROES TO BE
C              STORED IN THE MATRIX.  VALUES OF LMX BETWEEN N+7 AND
C              N+NZ+6 WILL CAUSE DEMAND PAGING TO OCCUR.
C              THIS IS IMPLEMENTED BY THE PACKAGE.
C              IX(*) MUST BE DIMENSIONED AT LEAST LMX
C      IPAGEF=UNIT NUMBER WHERE DEMAND PAGES WILL BE STORED.
C
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LINITM,
C     SANDIA LABS. REPT. SAND78-0785.
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C     REVISED 811130-1000
C     REVISED YYMMDD-HHMM
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910403  Updated AUTHOR and DESCRIPTION sections.  (WRB)
C***END PROLOGUE  DPINTM
      DOUBLE PRECISION SX(*),ZERO,ONE
      DIMENSION IX(*)
      SAVE ZERO, ONE
      DATA ZERO,ONE /0.D0,1.D0/
C***FIRST EXECUTABLE STATEMENT  DPINTM
      IOPT=1
C
C     CHECK FOR INPUT ERRORS.
C
      IF (.NOT.(M.LE.0 .OR. N.LE.0)) GO TO 20002
      NERR=55
      CALL XERMSG ('SLATEC', 'DPINTM',
     +   'MATRIX DIMENSION M OR N .LE. 0', NERR, IOPT)
C
C     VERIFY IF VALUE OF LMX IS LARGE ENOUGH.
C
20002 IF (.NOT.(LMX.LT.N+7)) GO TO 20005
      NERR=55
      CALL XERMSG ('SLATEC', 'DPINTM',
     +   'THE VALUE OF LMX IS TOO SMALL', NERR, IOPT)
C
C     INITIALIZE DATA STRUCTURE INDEPENDENT VALUES.
C
20005 SX(1)=ZERO
      SX(2)=ZERO
      SX(3)=IPAGEF
      IX(1)=LMX
      IX(2)=M
      IX(3)=N
      IX(4)=0
      SX(LMX-1)=ZERO
      SX(LMX)=-ONE
      IX(LMX-1)=-1
      LP4=N+4
C
C     INITIALIZE DATA STRUCTURE DEPENDENT VALUES.
C
      I=4
      N20008=LP4
      GO TO 20009
20008 I=I+1
20009 IF ((N20008-I).LT.0) GO TO 20010
      SX(I)=ZERO
      GO TO 20008
20010 I=5
      N20012=LP4
      GO TO 20013
20012 I=I+1
20013 IF ((N20012-I).LT.0) GO TO 20014
      IX(I)=LP4
      GO TO 20012
20014 SX(N+5)=ZERO
      IX(N+5)=0
      IX(LMX)=0
C
C     INITIALIZATION COMPLETE.
C
      RETURN
      END
*DECK DPJAC
      SUBROUTINE DPJAC (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, DF,
     +   DJAC, RPAR, IPAR)
C***BEGIN PROLOGUE  DPJAC
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DDEBDF
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PJAC-S, DPJAC-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C   DPJAC sets up the iteration matrix (involving the Jacobian) for the
C   integration package DDEBDF.
C
C***SEE ALSO  DDEBDF
C***ROUTINES CALLED  DGBFA, DGEFA, DVNRMS
C***COMMON BLOCKS    DDEBD1
C***REVISION HISTORY  (YYMMDD)
C   820301  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C   920422  Changed DIMENSION statement.  (WRB)
C***END PROLOGUE  DPJAC
C
      INTEGER I, I1, I2, IER, II, IOWND, IOWNS, IPAR, IWM, J, J1,
     1      JJ, JSTART, KFLAG, L, LENP, MAXORD, MBA, MBAND,
     2      MEB1, MEBAND, METH, MITER, ML, ML3, MU, N, NEQ,
     3      NFE, NJE, NQ, NQU, NST, NYH
      DOUBLE PRECISION CON, DI, DVNRMS, EL0, EWT,
     1      FAC, FTEM, H, HL0, HMIN, HMXI, HU, R, R0, ROWND, ROWNS,
     2      RPAR, SAVF, SRUR, TN, UROUND, WM, Y, YH, YI, YJ, YJJ
      EXTERNAL DF, DJAC
      DIMENSION Y(*),YH(NYH,*),EWT(*),FTEM(*),SAVF(*),WM(*),IWM(*),
     1          RPAR(*),IPAR(*)
      COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND,
     1                IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER,
     2                MAXORD,N,NQ,NST,NFE,NJE,NQU
C     ------------------------------------------------------------------
C      DPJAC IS CALLED BY DSTOD  TO COMPUTE AND PROCESS THE MATRIX
C      P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN.
C      HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE DJAC IF
C      MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5.
C      IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED.
C      J IS STORED IN WM AND REPLACED BY P.  IF MITER .NE. 3, P IS THEN
C      SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION
C      OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE
C      BY DGEFA IF MITER = 1 OR 2, AND BY DGBFA IF MITER = 4 OR 5.
C
C      IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION
C      WITH DPJAC USES THE FOLLOWING..
C      Y    = ARRAY CONTAINING PREDICTED VALUES ON ENTRY.
C      FTEM = WORK ARRAY OF LENGTH N (ACOR IN DSTOD ).
C      SAVF = ARRAY CONTAINING DF EVALUATED AT PREDICTED Y.
C      WM   = DOUBLE PRECISION WORK SPACE FOR MATRICES.  ON OUTPUT IT
C      CONTAINS THE
C             INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU
C             DECOMPOSITION OF P IF MITER IS 1, 2 , 4, OR 5.
C             STORAGE OF MATRIX ELEMENTS STARTS AT WM(3).
C             WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA..
C             WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN
C             INCREMENTS.  WM(2) = H*EL0, SAVED FOR LATER USE IF MITER =
C             3.
C      IWM  = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING
C             AT IWM(21), IF MITER IS 1, 2, 4, OR 5.  IWM ALSO CONTAINS
C             THE BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER
C             IS 4 OR 5.
C      EL0  = EL(1) (INPUT).
C      IER  = OUTPUT ERROR FLAG,  = 0 IF NO TROUBLE, .NE. 0 IF
C             P MATRIX FOUND TO BE SINGULAR.
C      THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND,
C      MITER, N, NFE, AND NJE.
C-----------------------------------------------------------------------
C     BEGIN BLOCK PERMITTING ...EXITS TO 240
C        BEGIN BLOCK PERMITTING ...EXITS TO 220
C           BEGIN BLOCK PERMITTING ...EXITS TO 130
C              BEGIN BLOCK PERMITTING ...EXITS TO 70
C***FIRST EXECUTABLE STATEMENT  DPJAC
                  NJE = NJE + 1
                  HL0 = H*EL0
                  GO TO (10,40,90,140,170), MITER
C                 IF MITER = 1, CALL DJAC AND MULTIPLY BY SCALAR.
C                 -----------------------
   10             CONTINUE
                  LENP = N*N
                  DO 20 I = 1, LENP
                     WM(I+2) = 0.0D0
   20             CONTINUE
                  CALL DJAC(TN,Y,WM(3),N,RPAR,IPAR)
                  CON = -HL0
                  DO 30 I = 1, LENP
                     WM(I+2) = WM(I+2)*CON
   30             CONTINUE
C              ...EXIT
                  GO TO 70
C                 IF MITER = 2, MAKE N CALLS TO DF TO APPROXIMATE J.
C                 --------------------
   40             CONTINUE
                  FAC = DVNRMS(N,SAVF,EWT)
                  R0 = 1000.0D0*ABS(H)*UROUND*N*FAC
                  IF (R0 .EQ. 0.0D0) R0 = 1.0D0
                  SRUR = WM(1)
                  J1 = 2
                  DO 60 J = 1, N
                     YJ = Y(J)
                     R = MAX(SRUR*ABS(YJ),R0*EWT(J))
                     Y(J) = Y(J) + R
                     FAC = -HL0/R
                     CALL DF(TN,Y,FTEM,RPAR,IPAR)
                     DO 50 I = 1, N
                        WM(I+J1) = (FTEM(I) - SAVF(I))*FAC
   50                CONTINUE
                     Y(J) = YJ
                     J1 = J1 + N
   60             CONTINUE
                  NFE = NFE + N
   70          CONTINUE
C              ADD IDENTITY MATRIX.
C              -------------------------------------------------
               J = 3
               DO 80 I = 1, N
                  WM(J) = WM(J) + 1.0D0
                  J = J + (N + 1)
   80          CONTINUE
C              DO LU DECOMPOSITION ON P.
C              --------------------------------------------
               CALL DGEFA(WM(3),N,N,IWM(21),IER)
C     .........EXIT
               GO TO 240
C              IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND
C              P. ---------
   90          CONTINUE
               WM(2) = HL0
               IER = 0
               R = EL0*0.1D0
               DO 100 I = 1, N
                  Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2))
  100          CONTINUE
               CALL DF(TN,Y,WM(3),RPAR,IPAR)
               NFE = NFE + 1
               DO 120 I = 1, N
                  R0 = H*SAVF(I) - YH(I,2)
                  DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I))
                  WM(I+2) = 1.0D0
                  IF (ABS(R0) .LT. UROUND*EWT(I)) GO TO 110
C           .........EXIT
                     IF (ABS(DI) .EQ. 0.0D0) GO TO 130
                     WM(I+2) = 0.1D0*R0/DI
  110             CONTINUE
  120          CONTINUE
C     .........EXIT
               GO TO 240
  130       CONTINUE
            IER = -1
C     ......EXIT
            GO TO 240
C           IF MITER = 4, CALL DJAC AND MULTIPLY BY SCALAR.
C           -----------------------
  140       CONTINUE
            ML = IWM(1)
            MU = IWM(2)
            ML3 = 3
            MBAND = ML + MU + 1
            MEBAND = MBAND + ML
            LENP = MEBAND*N
            DO 150 I = 1, LENP
               WM(I+2) = 0.0D0
  150       CONTINUE
            CALL DJAC(TN,Y,WM(ML3),MEBAND,RPAR,IPAR)
            CON = -HL0
            DO 160 I = 1, LENP
               WM(I+2) = WM(I+2)*CON
  160       CONTINUE
C        ...EXIT
            GO TO 220
C           IF MITER = 5, MAKE MBAND CALLS TO DF TO APPROXIMATE J.
C           ----------------
  170       CONTINUE
            ML = IWM(1)
            MU = IWM(2)
            MBAND = ML + MU + 1
            MBA = MIN(MBAND,N)
            MEBAND = MBAND + ML
            MEB1 = MEBAND - 1
            SRUR = WM(1)
            FAC = DVNRMS(N,SAVF,EWT)
            R0 = 1000.0D0*ABS(H)*UROUND*N*FAC
            IF (R0 .EQ. 0.0D0) R0 = 1.0D0
            DO 210 J = 1, MBA
               DO 180 I = J, N, MBAND
                  YI = Y(I)
                  R = MAX(SRUR*ABS(YI),R0*EWT(I))
                  Y(I) = Y(I) + R
  180          CONTINUE
               CALL DF(TN,Y,FTEM,RPAR,IPAR)
               DO 200 JJ = J, N, MBAND
                  Y(JJ) = YH(JJ,1)
                  YJJ = Y(JJ)
                  R = MAX(SRUR*ABS(YJJ),R0*EWT(JJ))
                  FAC = -HL0/R
                  I1 = MAX(JJ-MU,1)
                  I2 = MIN(JJ+ML,N)
                  II = JJ*MEB1 - ML + 2
                  DO 190 I = I1, I2
                     WM(II+I) = (FTEM(I) - SAVF(I))*FAC
  190             CONTINUE
  200          CONTINUE
  210       CONTINUE
            NFE = NFE + MBA
  220    CONTINUE
C        ADD IDENTITY MATRIX.
C        -------------------------------------------------
         II = MBAND + 2
         DO 230 I = 1, N
            WM(II) = WM(II) + 1.0D0
            II = II + MEBAND
  230    CONTINUE
C        DO LU DECOMPOSITION OF P.
C        --------------------------------------------
         CALL DGBFA(WM(3),MEBAND,N,ML,MU,IWM(21),IER)
  240 CONTINUE
      RETURN
C     ----------------------- END OF SUBROUTINE DPJAC
C     -----------------------
      END
*DECK DPLINT
      SUBROUTINE DPLINT (N, X, Y, C)
C***BEGIN PROLOGUE  DPLINT
C***PURPOSE  Produce the polynomial which interpolates a set of discrete
C            data points.
C***LIBRARY   SLATEC
C***CATEGORY  E1B
C***TYPE      DOUBLE PRECISION (POLINT-S, DPLINT-D)
C***KEYWORDS  POLYNOMIAL INTERPOLATION
C***AUTHOR  Huddleston, R. E., (SNLL)
C***DESCRIPTION
C
C     Abstract
C        Subroutine DPLINT is designed to produce the polynomial which
C     interpolates the data  (X(I),Y(I)), I=1,...,N.  DPLINT sets up
C     information in the array C which can be used by subroutine DPOLVL
C     to evaluate the polynomial and its derivatives and by subroutine
C     DPOLCF to produce the coefficients.
C
C     Formal Parameters
C     *** All TYPE REAL variables are DOUBLE PRECISION ***
C     N  - the number of data points  (N .GE. 1)
C     X  - the array of abscissas (all of which must be distinct)
C     Y  - the array of ordinates
C     C  - an array of information used by subroutines
C     *******  Dimensioning Information  *******
C     Arrays X,Y, and C must be dimensioned at least N in the calling
C     program.
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPLINT
      INTEGER I,K,KM1,N
      DOUBLE PRECISION DIF,C(*),X(*),Y(*)
C***FIRST EXECUTABLE STATEMENT  DPLINT
      IF (N .LE. 0) GO TO 91
      C(1)=Y(1)
      IF(N .EQ. 1) RETURN
      DO 10010 K=2,N
      C(K)=Y(K)
      KM1=K-1
      DO 10010 I=1,KM1
C     CHECK FOR DISTINCT X VALUES
      DIF = X(I)-X(K)
      IF (DIF .EQ. 0.0) GO TO 92
      C(K) = (C(I)-C(K))/DIF
10010 CONTINUE
      RETURN
   91 CALL XERMSG ('SLATEC', 'DPLINT', 'N IS ZERO OR NEGATIVE.', 2, 1)
      RETURN
   92 CALL XERMSG ('SLATEC', 'DPLINT',
     +   'THE ABSCISSAS ARE NOT DISTINCT.', 2, 1)
      RETURN
      END
*DECK DPLPCE
      SUBROUTINE DPLPCE (MRELAS, NVARS, LMX, LBM, ITLP, ITBRC, IBASIS,
     +   IMAT, IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, TUNE, GG, AMAT,
     +   BASMAT, CSC, WR, WW, PRIMAL, ERD, ERP, SINGLR, REDBAS)
C***BEGIN PROLOGUE  DPLPCE
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPLPCE-S, DPLPCE-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,
C     /SASUM/DASUM/,/DCOPY/,DCOPY/.
C
C     REVISED 811219-1630
C     REVISED YYMMDD-HHMM
C
C     THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE.  IT CALCULATES
C     THE APPROXIMATE ERROR IN THE PRIMAL AND DUAL SYSTEMS.  IT IS
C     THE MAIN PART OF THE PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL
C     SYSTEMS).
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DASUM, DCOPY, DPRWPG, IDLOC, LA05BD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   890606  Changed references from IPLOC to IDLOC.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DPLPCE
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),PRIMAL(*),
     * ERD(*),ERP(*),EPS,ERDNRM,FACTOR,GG,ONE,ZERO,TEN,TUNE
      DOUBLE PRECISION DASUM
      LOGICAL SINGLR,REDBAS,TRANS,PAGEPL
C***FIRST EXECUTABLE STATEMENT  DPLPCE
      ZERO=0.D0
      ONE=1.D0
      TEN=10.D0
      LPG=LMX-(NVARS+4)
      SINGLR=.FALSE.
      FACTOR=0.01
C
C     COPY COLSUMS IN WW(*), AND SOLVE TRANSPOSED SYSTEM.
      I=1
      N20002=MRELAS
      GO TO 20003
20002 I=I+1
20003 IF ((N20002-I).LT.0) GO TO 20004
      J=IBASIS(I)
      IF (.NOT.(J.LE.NVARS)) GO TO 20006
      WW(I) = PRIMAL(J)
      GO TO 20007
20006 IF (.NOT.(IND(J).EQ.2)) GO TO 20009
      WW(I)=ONE
      GO TO 20010
20009 WW(I)=-ONE
20010 CONTINUE
20007 CONTINUE
      GO TO 20002
C
C     PERTURB RIGHT-SIDE IN UNITS OF LAST BITS TO BETTER REFLECT
C     ERRORS IN THE CHECK SUM SOLNS.
20004 I=1
      N20012=MRELAS
      GO TO 20013
20012 I=I+1
20013 IF ((N20012-I).LT.0) GO TO 20014
      WW(I)=WW(I)+TEN*EPS*WW(I)
      GO TO 20012
20014 TRANS = .TRUE.
      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      I=1
      N20016=MRELAS
      GO TO 20017
20016 I=I+1
20017 IF ((N20016-I).LT.0) GO TO 20018
      ERD(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE
C
C     SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS .GT. FACTOR.
C     THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED.
      SINGLR=SINGLR.OR.(ERD(I).GE.FACTOR)
      GO TO 20016
20018 ERDNRM=DASUM(MRELAS,ERD,1)
C
C     RECALCULATE ROW CHECK SUMS EVERY ITBRC ITERATIONS OR WHEN
C     A REDECOMPOSITION HAS OCCURRED.
      IF (.NOT.(MOD(ITLP,ITBRC).EQ.0 .OR. REDBAS)) GO TO 20020
C
C     COMPUTE ROW SUMS, STORE IN WW(*), SOLVE PRIMAL SYSTEM.
      WW(1)=ZERO
      CALL DCOPY(MRELAS,WW,0,WW,1)
      PAGEPL=.TRUE.
      J=1
      N20023=NVARS
      GO TO 20024
20023 J=J+1
20024 IF ((N20023-J).LT.0) GO TO 20025
      IF (.NOT.(IBB(J).GE.ZERO)) GO TO 20027
C
C     THE VARIABLE IS NON-BASIC.
      PAGEPL=.TRUE.
      GO TO 20023
20027 IF (.NOT.(J.EQ.1)) GO TO 20030
      ILOW=NVARS+5
      GO TO 20031
20030 ILOW=IMAT(J+3)+1
20031 IF (.NOT.(PAGEPL)) GO TO 20033
      IL1=IDLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20036
      ILOW=ILOW+2
      IL1=IDLOC(ILOW,AMAT,IMAT)
20036 CONTINUE
      IPAGE=ABS(IMAT(LMX-1))
      GO TO 20034
20033 IL1=IHI+1
20034 IHI=IMAT(J+4)-(ILOW-IL1)
20039 IU1=MIN(LMX-2,IHI)
      IF (.NOT.(IL1.GT.IU1)) GO TO 20041
      GO TO 20040
20041 CONTINUE
      DO 20 I=IL1,IU1
      WW(IMAT(I))=WW(IMAT(I))+AMAT(I)*CSC(J)
20    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20044
      GO TO 20040
20044 CONTINUE
      IPAGE=IPAGE+1
      KEY=1
      CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20039
20040 PAGEPL=IHI.EQ.(LMX-2)
      GO TO 20023
20025 L=1
      N20047=MRELAS
      GO TO 20048
20047 L=L+1
20048 IF ((N20047-L).LT.0) GO TO 20049
      J=IBASIS(L)
      IF (.NOT.(J.GT.NVARS)) GO TO 20051
      I=J-NVARS
      IF (.NOT.(IND(J).EQ.2)) GO TO 20054
      WW(I)=WW(I)+ONE
      GO TO 20055
20054 WW(I)=WW(I)-ONE
20055 CONTINUE
      CONTINUE
20051 CONTINUE
      GO TO 20047
C
C     PERTURB RIGHT-SIDE IN UNITS OF LAST BIT POSITIONS.
20049 I=1
      N20057=MRELAS
      GO TO 20058
20057 I=I+1
20058 IF ((N20057-I).LT.0) GO TO 20059
      WW(I)=WW(I)+TEN*EPS*WW(I)
      GO TO 20057
20059 TRANS = .FALSE.
      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      I=1
      N20061=MRELAS
      GO TO 20062
20061 I=I+1
20062 IF ((N20061-I).LT.0) GO TO 20063
      ERP(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE
C
C     SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS .GT. FACTOR.
C     THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED.
      SINGLR=SINGLR.OR.(ERP(I).GE.FACTOR)
      GO TO 20061
20063 CONTINUE
C
20020 RETURN
      END
*DECK DPLPDM
      SUBROUTINE DPLPDM (MRELAS, NVARS, LMX, LBM, NREDC, INFO, IOPT,
     +   IBASIS, IMAT, IBRC, IPR, IWR, IND, IBB, ANORM, EPS, UU, GG,
     +   AMAT, BASMAT, CSC, WR, SINGLR, REDBAS)
C***BEGIN PROLOGUE  DPLPDM
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPLPDM-S, DPLPDM-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE.  IT PERFORMS THE
C     TASK OF DEFINING THE ENTRIES OF THE BASIS MATRIX AND
C     DECOMPOSING IT USING THE LA05 PACKAGE.
C     IT IS THE MAIN PART OF THE PROCEDURE (DECOMPOSE BASIS MATRIX).
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DASUM, DPNNZR, LA05AD, XERMSG
C***COMMON BLOCKS    LA05DD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890605  Added DASUM to list of DOUBLE PRECISION variables.
C   890605  Removed unreferenced labels.  (WRB)
C   891009  Removed unreferenced variable.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls, convert do-it-yourself
C           DO loops to DO loops.  (RWC)
C***END PROLOGUE  DPLPDM
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      DOUBLE PRECISION AIJ,AMAT(*),BASMAT(*),CSC(*),WR(*),ANORM,DASUM,
     * EPS,GG,ONE,SMALL,UU,ZERO
      LOGICAL SINGLR,REDBAS
      CHARACTER*16 XERN3
C
C     COMMON BLOCK USED BY LA05 () PACKAGE..
      COMMON /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL
C
C***FIRST EXECUTABLE STATEMENT  DPLPDM
      ZERO = 0.D0
      ONE = 1.D0
C
C     DEFINE BASIS MATRIX BY COLUMNS FOR SPARSE MATRIX EQUATION SOLVER.
C     THE LA05AD() SUBPROGRAM REQUIRES THE NONZERO ENTRIES OF THE MATRIX
C     TOGETHER WITH THE ROW AND COLUMN INDICES.
C
      NZBM = 0
C
C     DEFINE DEPENDENT VARIABLE COLUMNS. THESE ARE
C     COLS. OF THE IDENTITY MATRIX AND IMPLICITLY GENERATED.
C
      DO 20 K = 1,MRELAS
         J = IBASIS(K)
         IF (J.GT.NVARS) THEN
            NZBM = NZBM+1
            IF (IND(J).EQ.2) THEN
               BASMAT(NZBM) = ONE
            ELSE
               BASMAT(NZBM) = -ONE
            ENDIF
            IBRC(NZBM,1) = J-NVARS
            IBRC(NZBM,2) = K
         ELSE
C
C           DEFINE THE INDEP. VARIABLE COLS.  THIS REQUIRES RETRIEVING
C           THE COLS. FROM THE SPARSE MATRIX DATA STRUCTURE.
C
            I = 0
   10       CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
            IF (I.GT.0) THEN
               NZBM = NZBM+1
               BASMAT(NZBM) = AIJ*CSC(J)
               IBRC(NZBM,1) = I
               IBRC(NZBM,2) = K
               GO TO 10
            ENDIF
         ENDIF
   20 CONTINUE
C
      SINGLR = .FALSE.
C
C     RECOMPUTE MATRIX NORM USING CRUDE NORM  =  SUM OF MAGNITUDES.
C
      ANORM = DASUM(NZBM,BASMAT,1)
      SMALL = EPS*ANORM
C
C     GET AN L-U FACTORIZATION OF THE BASIS MATRIX.
C
      NREDC = NREDC+1
      REDBAS = .TRUE.
      CALL LA05AD(BASMAT,IBRC,NZBM,LBM,MRELAS,IPR,IWR,WR,GG,UU)
C
C     CHECK RETURN VALUE OF ERROR FLAG, GG.
C
      IF (GG.GE.ZERO) RETURN
      IF (GG.EQ.(-7.)) THEN
         CALL XERMSG ('SLATEC', 'DPLPDM',
     *      'IN DSPLP, SHORT ON STORAGE FOR LA05AD.  ' //
     *      'USE PRGOPT(*) TO GIVE MORE.', 28, IOPT)
         INFO = -28
      ELSEIF (GG.EQ.(-5.)) THEN
         SINGLR = .TRUE.
      ELSE
         WRITE (XERN3, '(1PE15.6)') GG
         CALL XERMSG ('SLATEC', 'DPLPDM',
     *      'IN DSPLP, LA05AD RETURNED ERROR FLAG = ' // XERN3,
     *      27, IOPT)
         INFO = -27
      ENDIF
      RETURN
      END
*DECK DPLPFE
      SUBROUTINE DPLPFE (MRELAS, NVARS, LMX, LBM, IENTER, IBASIS, IMAT,
     +   IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, GG, DULNRM, DIRNRM,
     +   AMAT, BASMAT, CSC, WR, WW, BL, BU, RZ, RG, COLNRM, DUALS,
     +   FOUND)
C***BEGIN PROLOGUE  DPLPFE
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPLPFE-S, DPLPFE-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/SASUM/DASUM/,
C     /SCOPY/DCOPY/.
C
C     THIS SUBPROGRAM IS PART OF THE DSPLP( ) PACKAGE.
C     IT IMPLEMENTS THE PROCEDURE (FIND VARIABLE TO ENTER BASIS
C     AND GET SEARCH DIRECTION).
C     REVISED 811130-1100
C     REVISED YYMMDD-HHMM
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DASUM, DCOPY, DPRWPG, IDLOC, LA05BD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   890606  Changed references from IPLOC to IDLOC.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DPLPFE
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),BL(*),BU(*),
     * RZ(*),RG(*),COLNRM(*),DUALS(*),CNORM,DIRNRM,DULNRM,EPS,ERDNRM,GG,
     * ONE,RATIO,RCOST,RMAX,ZERO
      DOUBLE PRECISION DASUM
      LOGICAL FOUND,TRANS
C***FIRST EXECUTABLE STATEMENT  DPLPFE
      LPG=LMX-(NVARS+4)
      ZERO=0.D0
      ONE=1.D0
      RMAX=ZERO
      FOUND=.FALSE.
      I=MRELAS+1
      N20002=MRELAS+NVARS
      GO TO 20003
20002 I=I+1
20003 IF ((N20002-I).LT.0) GO TO 20004
      J=IBASIS(I)
C
C     IF J=IBASIS(I) .LT. 0 THEN THE VARIABLE LEFT AT A ZERO LEVEL
C     AND IS NOT CONSIDERED AS A CANDIDATE TO ENTER.
      IF (.NOT.(J.GT.0)) GO TO 20006
C
C     DO NOT CONSIDER VARIABLES CORRESPONDING TO UNBOUNDED STEP LENGTHS.
      IF (.NOT.(IBB(J).EQ.0)) GO TO 20009
      GO TO 20002
20009 CONTINUE
C
C     IF A VARIABLE CORRESPONDS TO AN EQUATION(IND=3 AND BL=BU),
C     THEN DO NOT CONSIDER IT AS A CANDIDATE TO ENTER.
      IF (.NOT.(IND(J).EQ.3)) GO TO 20012
      IF (.NOT.((BU(J)-BL(J)).LE.EPS*(ABS(BL(J))+ABS(BU(J)))))
     *GO TO 20015
      GO TO 20002
20015 CONTINUE
      CONTINUE
20012 CONTINUE
      RCOST=RZ(J)
C
C     IF VARIABLE IS AT UPPER BOUND IT CAN ONLY DECREASE.  THIS
C     ACCOUNTS FOR THE POSSIBLE CHANGE OF SIGN.
      IF(MOD(IBB(J),2).EQ.0) RCOST=-RCOST
C
C     IF THE VARIABLE IS FREE, USE THE NEGATIVE MAGNITUDE OF THE
C     REDUCED COST FOR THAT VARIABLE.
      IF(IND(J).EQ.4) RCOST=-ABS(RCOST)
      CNORM=ONE
      IF(J.LE.NVARS)CNORM=COLNRM(J)
C
C     TEST FOR NEGATIVITY OF REDUCED COSTS.
      IF (.NOT.(RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO)) GO TO 20018
      FOUND=.TRUE.
      RATIO=RCOST**2/RG(J)
      IF (.NOT.(RATIO.GT.RMAX)) GO TO 20021
      RMAX=RATIO
      IENTER=I
20021 CONTINUE
      CONTINUE
20018 CONTINUE
      CONTINUE
20006 GO TO 20002
C
C     USE COL. CHOSEN TO COMPUTE SEARCH DIRECTION.
20004 IF (.NOT.(FOUND)) GO TO 20024
      J=IBASIS(IENTER)
      WW(1)=ZERO
      CALL DCOPY(MRELAS,WW,0,WW,1)
      IF (.NOT.(J.LE.NVARS)) GO TO 20027
      IF (.NOT.(J.EQ.1)) GO TO 20030
      ILOW=NVARS+5
      GO TO 20031
20030 ILOW=IMAT(J+3)+1
20031 CONTINUE
      IL1=IDLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20033
      ILOW=ILOW+2
      IL1=IDLOC(ILOW,AMAT,IMAT)
20033 CONTINUE
      IPAGE=ABS(IMAT(LMX-1))
      IHI=IMAT(J+4)-(ILOW-IL1)
20036 IU1=MIN(LMX-2,IHI)
      IF (.NOT.(IL1.GT.IU1)) GO TO 20038
      GO TO 20037
20038 CONTINUE
      DO 30 I=IL1,IU1
      WW(IMAT(I))=AMAT(I)*CSC(J)
30    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20041
      GO TO 20037
20041 CONTINUE
      IPAGE=IPAGE+1
      KEY=1
      CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20036
20037 GO TO 20028
20027 IF (.NOT.(IND(J).EQ.2)) GO TO 20044
      WW(J-NVARS)=ONE
      GO TO 20045
20044 WW(J-NVARS)=-ONE
20045 CONTINUE
      CONTINUE
C
C     COMPUTE SEARCH DIRECTION.
20028 TRANS=.FALSE.
      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
C
C     THE SEARCH DIRECTION REQUIRES THE FOLLOWING SIGN CHANGE IF EITHER
C     VARIABLE ENTERING IS AT ITS UPPER BOUND OR IS FREE AND HAS
C     POSITIVE REDUCED COST.
      IF (.NOT.(MOD(IBB(J),2).EQ.0.OR.(IND(J).EQ.4 .AND. RZ(J).GT.ZERO))
     *) GO TO 20047
      I=1
      N20050=MRELAS
      GO TO 20051
20050 I=I+1
20051 IF ((N20050-I).LT.0) GO TO 20052
      WW(I)=-WW(I)
      GO TO 20050
20052 CONTINUE
20047 DIRNRM=DASUM(MRELAS,WW,1)
C
C     COPY CONTENTS OF WR(*) TO DUALS(*) FOR USE IN
C     ADD-DROP (EXCHANGE) STEP, LA05CD( ).
      CALL DCOPY(MRELAS,WR,1,DUALS,1)
20024 RETURN
      END
*DECK DPLPFL
      SUBROUTINE DPLPFL (MRELAS, NVARS, IENTER, ILEAVE, IBASIS, IND,
     +   IBB, THETA, DIRNRM, RPRNRM, CSC, WW, BL, BU, ERP, RPRIM,
     +   PRIMAL, FINITE, ZEROLV)
C***BEGIN PROLOGUE  DPLPFL
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPLPFL-S, DPLPFL-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/.
C
C     THIS SUBPROGRAM IS PART OF THE DSPLP( ) PACKAGE.
C     IT IMPLEMENTS THE PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS).
C     REVISED 811130-1045
C     REVISED YYMMDD-HHMM
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  DPLPFL
      INTEGER IBASIS(*),IND(*),IBB(*)
      DOUBLE PRECISION CSC(*),WW(*),BL(*),BU(*),ERP(*),RPRIM(*),
     * PRIMAL(*),BOUND,DIRNRM,RATIO,RPRNRM,THETA,ZERO
      LOGICAL FINITE,ZEROLV
C***FIRST EXECUTABLE STATEMENT  DPLPFL
      ZERO=0.D0
C
C     SEE IF THE ENTERING VARIABLE IS RESTRICTING THE STEP LENGTH
C     BECAUSE OF AN UPPER BOUND.
      FINITE=.FALSE.
      J=IBASIS(IENTER)
      IF (.NOT.(IND(J).EQ.3)) GO TO 20002
      THETA=BU(J)-BL(J)
      IF(J.LE.NVARS)THETA=THETA/CSC(J)
      FINITE=.TRUE.
      ILEAVE=IENTER
C
C     NOW USE THE BASIC VARIABLES TO POSSIBLY RESTRICT THE STEP
C     LENGTH EVEN FURTHER.
20002 I=1
      N20005=MRELAS
      GO TO 20006
20005 I=I+1
20006 IF ((N20005-I).LT.0) GO TO 20007
      J=IBASIS(I)
C
C     IF THIS IS A FREE VARIABLE, DO NOT USE IT TO
C     RESTRICT THE STEP LENGTH.
      IF (.NOT.(IND(J).EQ.4)) GO TO 20009
      GO TO 20005
C
C     IF DIRECTION COMPONENT IS ABOUT ZERO, IGNORE IT FOR COMPUTING
C     THE STEP LENGTH.
20009 IF (.NOT.(ABS(WW(I)).LE.DIRNRM*ERP(I))) GO TO 20012
      GO TO 20005
20012 IF (.NOT.(WW(I).GT.ZERO)) GO TO 20015
C
C     IF RPRIM(I) IS ESSENTIALLY ZERO, SET RATIO TO ZERO AND EXIT LOOP.
      IF (.NOT.(ABS(RPRIM(I)).LE.RPRNRM*ERP(I))) GO TO 20018
      THETA=ZERO
      ILEAVE=I
      FINITE=.TRUE.
      GO TO 20008
C
C     THE VALUE OF RPRIM(I) WILL DECREASE ONLY TO ITS LOWER BOUND OR
C     ONLY TO ITS UPPER BOUND.  IF IT DECREASES TO ITS
C     UPPER BOUND, THEN RPRIM(I) HAS ALREADY BEEN TRANSLATED
C     TO ITS UPPER BOUND AND NOTHING NEEDS TO BE DONE TO IBB(J).
20018 IF (.NOT.(RPRIM(I).GT.ZERO)) GO TO 10001
      RATIO=RPRIM(I)/WW(I)
      IF (.NOT.(.NOT.FINITE)) GO TO 20021
      ILEAVE=I
      THETA=RATIO
      FINITE=.TRUE.
      GO TO 20022
20021 IF (.NOT.(RATIO.LT.THETA)) GO TO 10002
      ILEAVE=I
      THETA=RATIO
10002 CONTINUE
20022 CONTINUE
      GO TO 20019
C
C     THE VALUE RPRIM(I).LT.ZERO WILL NOT RESTRICT THE STEP.
10001 CONTINUE
C
C     THE DIRECTION COMPONENT IS NEGATIVE, THEREFORE THE VARIABLE WILL
C     INCREASE.
20019 GO TO 20016
C
C     IF THE VARIABLE IS LESS THAN ITS LOWER BOUND, IT CAN
C     INCREASE ONLY TO ITS LOWER BOUND.
20015 IF (.NOT.(PRIMAL(I+NVARS).LT.ZERO)) GO TO 20024
      RATIO=RPRIM(I)/WW(I)
      IF (RATIO.LT.ZERO) RATIO=ZERO
      IF (.NOT.(.NOT.FINITE)) GO TO 20027
      ILEAVE=I
      THETA=RATIO
      FINITE=.TRUE.
      GO TO 20028
20027 IF (.NOT.(RATIO.LT.THETA)) GO TO 10003
      ILEAVE=I
      THETA=RATIO
10003 CONTINUE
20028 CONTINUE
C
C     IF THE BASIC VARIABLE IS FEASIBLE AND IS NOT AT ITS UPPER BOUND,
C     THEN IT CAN INCREASE TO ITS UPPER BOUND.
      GO TO 20025
20024 IF (.NOT.(IND(J).EQ.3 .AND. PRIMAL(I+NVARS).EQ.ZERO)) GO TO 10004
      BOUND=BU(J)-BL(J)
      IF(J.LE.NVARS) BOUND=BOUND/CSC(J)
      RATIO=(BOUND-RPRIM(I))/(-WW(I))
      IF (.NOT.(.NOT.FINITE)) GO TO 20030
      ILEAVE=-I
      THETA=RATIO
      FINITE=.TRUE.
      GO TO 20031
20030 IF (.NOT.(RATIO.LT.THETA)) GO TO 10005
      ILEAVE=-I
      THETA=RATIO
10005 CONTINUE
20031 CONTINUE
      CONTINUE
10004 CONTINUE
20025 CONTINUE
20016 GO TO 20005
20007 CONTINUE
C
C     IF STEP LENGTH IS FINITE, SEE IF STEP LENGTH IS ABOUT ZERO.
20008 IF (.NOT.(FINITE)) GO TO 20033
      ZEROLV=.TRUE.
      I=1
      N20036=MRELAS
      GO TO 20037
20036 I=I+1
20037 IF ((N20036-I).LT.0) GO TO 20038
      ZEROLV=ZEROLV.AND. ABS(THETA*WW(I)).LE.ERP(I)*RPRNRM
      IF (.NOT.(.NOT. ZEROLV)) GO TO 20040
      GO TO 20039
20040 GO TO 20036
20038 CONTINUE
20039 CONTINUE
20033 CONTINUE
      RETURN
      END
*DECK DPLPMN
      SUBROUTINE DPLPMN (DUSRMT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV,
     +   BL, BU, IND, INFO, PRIMAL, DUALS, AMAT, CSC, COLNRM, ERD, ERP,
     +   BASMAT, WR, RZ, RG, RPRIM, RHS, WW, LMX, LBM, IBASIS, IBB,
     +   IMAT, IBRC, IPR, IWR)
C***BEGIN PROLOGUE  DPLPMN
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPLPMN-S, DPLPMN-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT.
C     THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR.
C
C     MAIN SUBROUTINE FOR DSPLP PACKAGE.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DASUM, DCOPY, DDOT, DPINCW, DPINIT, DPINTM, DPLPCE,
C                    DPLPDM, DPLPFE, DPLPFL, DPLPMU, DPLPUP, DPNNZR,
C                    DPOPT, DPRWPG, DVOUT, IVOUT, LA05BD, SCLOSM, XERMSG
C***COMMON BLOCKS    LA05DD
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   891009  Removed unreferenced variable.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C***END PROLOGUE  DPLPMN
      DOUBLE PRECISION ABIG,AIJ,AMAT(*),ANORM,ASMALL,BASMAT(*),
     * BL(*),BU(*),COLNRM(*),COSTS(*),COSTSC,CSC(*),DATTRV(*),
     * DIRNRM,DUALS(*),DULNRM,EPS,TUNE,ERD(*),ERDNRM,ERP(*),FACTOR,GG,
     * ONE,PRGOPT(*),PRIMAL(*),RESNRM,RG(*),RHS(*),RHSNRM,ROPT(07),
     * RPRIM(*),RPRNRM,RZ(*),RZJ,SCALR,SCOSTS,SIZE,SMALL,THETA,
     * TOLLS,UPBND,UU,WR(*),WW(*),XLAMDA,XVAL,ZERO,RDUM(01),TOLABS
      DOUBLE PRECISION DDOT,DASUM
C
      INTEGER IBASIS(*),IBB(*),IBRC(LBM,2),IMAT(*),IND(*),
     * IPR(*),IWR(*),INTOPT(08),IDUM(01)
C
C     ARRAY LOCAL VARIABLES
C     NAME(LENGTH)          DESCRIPTION
C
C     COSTS(NVARS)          COST COEFFICIENTS
C     PRGOPT( )             OPTION VECTOR
C     DATTRV( )             DATA TRANSFER VECTOR
C     PRIMAL(NVARS+MRELAS)  AS OUTPUT IT IS PRIMAL SOLUTION OF LP.
C                           INTERNALLY, THE FIRST NVARS POSITIONS HOLD
C                           THE COLUMN CHECK SUMS.  THE NEXT MRELAS
C                           POSITIONS HOLD THE CLASSIFICATION FOR THE
C                           BASIC VARIABLES  -1 VIOLATES LOWER
C                           BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND
C     DUALS(MRELAS+NVARS)   DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE
C                           AS FIRST MRELAS ENTRIES.
C     AMAT(LMX)             SPARSE FORM OF DATA MATRIX
C     IMAT(LMX)             SPARSE FORM OF DATA MATRIX
C     BL(NVARS+MRELAS)      LOWER BOUNDS FOR VARIABLES
C     BU(NVARS+MRELAS)      UPPER BOUNDS FOR VARIABLES
C     IND(NVARS+MRELAS)     INDICATOR FOR VARIABLES
C     CSC(NVARS)            COLUMN SCALING
C     IBASIS(NVARS+MRELAS)  COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC
C     IBB(NVARS+MRELAS)     INDICATOR FOR NON-BASIC VARS., POLARITY OF
C                           VARS., AND POTENTIALLY INFINITE VARS.
C                           IF IBB(J).LT.0, VARIABLE J IS BASIC
C                           IF IBB(J).GT.0, VARIABLE J IS NON-BASIC
C                           IF IBB(J).EQ.0, VARIABLE J HAS TO BE IGNORED
C                           BECAUSE IT WOULD CAUSE UNBOUNDED SOLN.
C                           WHEN MOD(IBB(J),2).EQ.0, VARIABLE IS AT ITS
C                           UPPER BOUND, OTHERWISE IT IS AT ITS LOWER
C                           BOUND
C     COLNRM(NVARS)         NORM OF COLUMNS
C     ERD(MRELAS)           ERRORS IN DUAL VARIABLES
C     ERP(MRELAS)           ERRORS IN PRIMAL VARIABLES
C     BASMAT(LBM)           BASIS MATRIX FOR HARWELL SPARSE CODE
C     IBRC(LBM,2)           ROW AND COLUMN POINTERS FOR BASMAT(*)
C     IPR(2*MRELAS)         WORK ARRAY FOR HARWELL SPARSE CODE
C     IWR(8*MRELAS)         WORK ARRAY FOR HARWELL SPARSE CODE
C     WR(MRELAS)            WORK ARRAY FOR HARWELL SPARSE CODE
C     RZ(NVARS+MRELAS)      REDUCED COSTS
C     RPRIM(MRELAS)         INTERNAL PRIMAL SOLUTION
C     RG(NVARS+MRELAS)      COLUMN WEIGHTS
C     WW(MRELAS)            WORK ARRAY
C     RHS(MRELAS)           HOLDS TRANSLATED RIGHT HAND SIDE
C
C     SCALAR LOCAL VARIABLES
C     NAME       TYPE         DESCRIPTION
C
C     LMX        INTEGER      LENGTH OF AMAT(*)
C     LPG        INTEGER      LENGTH OF PAGE FOR AMAT(*)
C     EPS        DOUBLE       MACHINE PRECISION
C     TUNE       DOUBLE       PARAMETER TO SCALE ERROR ESTIMATES
C     TOLLS      DOUBLE       RELATIVE TOLERANCE FOR SMALL RESIDUALS
C     TOLABS     DOUBLE       ABSOLUTE TOLERANCE FOR SMALL RESIDUALS.
C                             USED IF RELATIVE ERROR TEST FAILS.
C                             IN CONSTRAINT EQUATIONS
C     FACTOR     DOUBLE      .01--DETERMINES IF BASIS IS SINGULAR
C                             OR COMPONENT IS FEASIBLE.  MAY NEED TO
C                             BE INCREASED TO 1.D0 ON SHORT WORD
C                             LENGTH MACHINES.
C     ASMALL     DOUBLE       LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
C     ABIG       DOUBLE       UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
C     MXITLP     INTEGER      MAXIMUM NUMBER OF ITERATIONS FOR LP
C     ITLP       INTEGER      ITERATION COUNTER FOR TOTAL LP ITERS
C     COSTSC     DOUBLE       COSTS(*) SCALING
C     SCOSTS     DOUBLE       TEMP LOC. FOR COSTSC.
C     XLAMDA     DOUBLE       WEIGHT PARAMETER FOR PEN. METHOD.
C     ANORM      DOUBLE       NORM OF DATA MATRIX AMAT(*)
C     RPRNRM     DOUBLE       NORM OF THE SOLUTION
C     DULNRM     DOUBLE       NORM OF THE DUALS
C     ERDNRM     DOUBLE       NORM OF ERROR IN DUAL VARIABLES
C     DIRNRM     DOUBLE       NORM OF THE DIRECTION VECTOR
C     RHSNRM     DOUBLE       NORM OF TRANSLATED RIGHT HAND SIDE VECTOR
C     RESNRM     DOUBLE       NORM OF RESIDUAL VECTOR FOR CHECKING
C                             FEASIBILITY
C     NZBM       INTEGER      NUMBER OF NON-ZEROS IN BASMAT(*)
C     LBM        INTEGER      LENGTH OF BASMAT(*)
C     SMALL      DOUBLE       EPS*ANORM  USED IN HARWELL SPARSE CODE
C     LP         INTEGER      USED IN HARWELL LA05*() PACK AS OUTPUT
C                             FILE NUMBER. SET=I1MACH(4) NOW.
C     UU         DOUBLE       0.1--USED IN HARWELL SPARSE CODE
C                             FOR RELATIVE PIVOTING TOLERANCE.
C     GG         DOUBLE       OUTPUT INFO FLAG IN HARWELL SPARSE CODE
C     IPLACE     INTEGER      INTEGER USED BY SPARSE MATRIX CODES
C     IENTER     INTEGER      NEXT COLUMN TO ENTER BASIS
C     NREDC      INTEGER      NO. OF FULL REDECOMPOSITIONS
C     KPRINT     INTEGER      LEVEL OF OUTPUT, =0-3
C     IDG        INTEGER      FORMAT AND PRECISION OF OUTPUT
C     ITBRC      INTEGER      NO. OF ITERS. BETWEEN RECALCULATING
C                             THE ERROR IN THE PRIMAL SOLUTION.
C     NPP        INTEGER      NO. OF NEGATIVE REDUCED COSTS REQUIRED
C                             IN PARTIAL PRICING
C     JSTRT      INTEGER      STARTING PLACE FOR PARTIAL PRICING.
C
      LOGICAL COLSCP,SAVEDT,CONTIN,CSTSCP,UNBND,
     *        FEAS,FINITE,FOUND,MINPRB,REDBAS,
     *        SINGLR,SIZEUP,STPEDG,TRANS,USRBAS,ZEROLV,LOPT(08)
      CHARACTER*8 XERN1, XERN2
      EQUIVALENCE (CONTIN,LOPT(1)),(USRBAS,LOPT(2)),
     *  (SIZEUP,LOPT(3)),(SAVEDT,LOPT(4)),(COLSCP,LOPT(5)),
     *  (CSTSCP,LOPT(6)),(MINPRB,LOPT(7)),(STPEDG,LOPT(8)),
     *  (IDG,INTOPT(1)),(IPAGEF,INTOPT(2)),(ISAVE,INTOPT(3)),
     *  (MXITLP,INTOPT(4)),(KPRINT,INTOPT(5)),(ITBRC,INTOPT(6)),
     *  (NPP,INTOPT(7)),(LPRG,INTOPT(8)),(EPS,ROPT(1)),(ASMALL,ROPT(2)),
     *  (ABIG,ROPT(3)),(COSTSC,ROPT(4)),(TOLLS,ROPT(5)),(TUNE,ROPT(6)),
     *   (TOLABS,ROPT(7))
C
C     COMMON BLOCK USED BY LA05 () PACKAGE..
      COMMON /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL
      EXTERNAL DUSRMT
C
C     SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE.
C***FIRST EXECUTABLE STATEMENT  DPLPMN
      LP=0
C
C     THE VALUES ZERO AND ONE.
      ZERO=0.D0
      ONE=1.D0
      FACTOR=0.01D0
      LPG=LMX-(NVARS+4)
      IOPT=1
      INFO=0
      UNBND=.FALSE.
      JSTRT=1
C
C     PROCESS USER OPTIONS IN PRGOPT(*).
C     CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED.
      CALL DPOPT(PRGOPT,MRELAS,NVARS,INFO,CSC,IBASIS,ROPT,INTOPT,LOPT)
      IF (.NOT.(INFO.LT.0)) GO TO 20002
      GO TO 30001
20002 IF (.NOT.(CONTIN)) GO TO 20003
      GO TO 30002
20006 GO TO 20004
C
C     INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*).
20003 CALL DPINTM(MRELAS,NVARS,AMAT,IMAT,LMX,IPAGEF)
C
C     UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY.
20004 CALL DPLPUP(DUSRMT,MRELAS,NVARS,PRGOPT,DATTRV,
     *     BL,BU,IND,INFO,AMAT,IMAT,SIZEUP,ASMALL,ABIG)
      IF (.NOT.(INFO.LT.0)) GO TO 20007
      GO TO 30001
C
C++  CODE FOR OUTPUT=YES IS ACTIVE
20007 IF (.NOT.(KPRINT.GE.1)) GO TO 20008
      GO TO 30003
20011 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
C
C     INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN
C     CHECK SUMS, AND FORM INITIAL BASIS MATRIX.
20008 CALL DPINIT(MRELAS,NVARS,COSTS,BL,BU,IND,PRIMAL,INFO,
     * AMAT,CSC,COSTSC,COLNRM,XLAMDA,ANORM,RHS,RHSNRM,
     * IBASIS,IBB,IMAT,LOPT)
      IF (.NOT.(INFO.LT.0)) GO TO 20012
      GO TO 30001
C
20012 NREDC=0
      ASSIGN 20013 TO NPR004
      GO TO 30004
20013 IF (.NOT.(SINGLR)) GO TO 20014
      NERR=23
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP,  A SINGULAR INITIAL BASIS WAS ENCOUNTERED.', NERR,
     +   IOPT)
      INFO=-NERR
      GO TO 30001
20014 ASSIGN 20018 TO NPR005
      GO TO 30005
20018 ASSIGN 20019 TO NPR006
      GO TO 30006
20019 ASSIGN 20020 TO NPR007
      GO TO 30007
20020 IF (.NOT.(USRBAS)) GO TO 20021
      ASSIGN 20024 TO NPR008
      GO TO 30008
20024 IF (.NOT.(.NOT.FEAS)) GO TO 20025
      NERR=24
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP, AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.',
     +   NERR, IOPT)
      INFO=-NERR
      GO TO 30001
20025 CONTINUE
20021 ITLP=0
C
C     LAMDA HAS BEEN SET TO A CONSTANT, PERFORM PENALTY METHOD.
      ASSIGN 20029 TO NPR009
      GO TO 30009
20029 ASSIGN 20030 TO NPR010
      GO TO 30010
20030 ASSIGN 20031 TO NPR006
      GO TO 30006
20031 ASSIGN 20032 TO NPR008
      GO TO 30008
20032 IF (.NOT.(.NOT.FEAS)) GO TO 20033
C
C     SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF
C     COSTSC) AND PERFORM STANDARD PHASE-1.
      IF(KPRINT.GE.2)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-1'')',
     *IDG)
      SCOSTS=COSTSC
      COSTSC=ZERO
      ASSIGN 20036 TO NPR007
      GO TO 30007
20036 ASSIGN 20037 TO NPR009
      GO TO 30009
20037 ASSIGN 20038 TO NPR010
      GO TO 30010
20038 ASSIGN 20039 TO NPR006
      GO TO 30006
20039 ASSIGN 20040 TO NPR008
      GO TO 30008
20040 IF (.NOT.(FEAS)) GO TO 20041
C
C     SET LAMDA TO ZERO, COSTSC=SCOSTS, PERFORM STANDARD PHASE-2.
      IF(KPRINT.GT.1)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-2'')',
     *IDG)
      XLAMDA=ZERO
      COSTSC=SCOSTS
      ASSIGN 20044 TO NPR009
      GO TO 30009
20044 CONTINUE
20041 GO TO 20034
C     CHECK IF ANY BASIC VARIABLES ARE STILL CLASSIFIED AS
C     INFEASIBLE.  IF ANY ARE, THEN THIS MAY NOT YET BE AN
C     OPTIMAL POINT.  THEREFORE SET LAMDA TO ZERO AND TRY
C     TO PERFORM MORE SIMPLEX STEPS.
20033 I=1
      N20046=MRELAS
      GO TO 20047
20046 I=I+1
20047 IF ((N20046-I).LT.0) GO TO 20048
      IF (PRIMAL(I+NVARS).NE.ZERO) GO TO 20045
      GO TO 20046
20048 GO TO 20035
20045 XLAMDA=ZERO
      ASSIGN 20050 TO NPR009
      GO TO 30009
20050 CONTINUE
20034 CONTINUE
C
20035 ASSIGN 20051 TO NPR011
      GO TO 30011
20051 IF (.NOT.(FEAS.AND.(.NOT.UNBND))) GO TO 20052
      INFO=1
      GO TO 20053
20052 IF (.NOT.((.NOT.FEAS).AND.(.NOT.UNBND))) GO TO 10001
      NERR=1
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE', NERR, IOPT)
      INFO=-NERR
      GO TO 20053
10001 IF (.NOT.(FEAS .AND. UNBND)) GO TO 10002
      NERR=2
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP, THE PROBLEM APPEARS TO HAVE NO FINITE SOLUTION.',
     +   NERR, IOPT)
      INFO=-NERR
      GO TO 20053
10002 IF (.NOT.((.NOT.FEAS).AND.UNBND)) GO TO 10003
      NERR=3
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO ' //
     +   'HAVE NO FINITE SOLN.', NERR, IOPT)
      INFO=-NERR
10003 CONTINUE
20053 CONTINUE
C
      IF (.NOT.(INFO.EQ.(-1) .OR. INFO.EQ.(-3))) GO TO 20055
      SIZE=DASUM(NVARS,PRIMAL,1)*ANORM
      SIZE=SIZE/DASUM(NVARS,CSC,1)
      SIZE=SIZE+DASUM(MRELAS,PRIMAL(NVARS+1),1)
      I=1
      N20058=NVARS+MRELAS
      GO TO 20059
20058 I=I+1
20059 IF ((N20058-I).LT.0) GO TO 20060
      NX0066=IND(I)
      IF (NX0066.LT.1.OR.NX0066.GT.4) GO TO 20066
      GO TO (20062,20063,20064,20065), NX0066
20062 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20068
      GO TO 20058
20068 IF (.NOT.(PRIMAL(I).GT.BL(I))) GO TO 10004
      GO TO 20058
10004 IND(I)=-4
      GO TO 20067
20063 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 20071
      GO TO 20058
20071 IF (.NOT.(PRIMAL(I).LT.BU(I))) GO TO 10005
      GO TO 20058
10005 IND(I)=-4
      GO TO 20067
20064 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20074
      GO TO 20058
20074 IF (.NOT.(PRIMAL(I).LT.BL(I))) GO TO 10006
      IND(I)=-4
      GO TO 20075
10006 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 10007
      GO TO 20058
10007 IF (.NOT.(PRIMAL(I).GT.BU(I))) GO TO 10008
      IND(I)=-4
      GO TO 20075
10008 GO TO 20058
20075 GO TO 20067
20065 GO TO 20058
20066 CONTINUE
20067 GO TO 20058
20060 CONTINUE
20055 CONTINUE
C
      IF (.NOT.(INFO.EQ.(-2) .OR. INFO.EQ.(-3))) GO TO 20077
      J=1
      N20080=NVARS
      GO TO 20081
20080 J=J+1
20081 IF ((N20080-J).LT.0) GO TO 20082
      IF (.NOT.(IBB(J).EQ.0)) GO TO 20084
      NX0091=IND(J)
      IF (NX0091.LT.1.OR.NX0091.GT.4) GO TO 20091
      GO TO (20087,20088,20089,20090), NX0091
20087 BU(J)=BL(J)
      IND(J)=-3
      GO TO 20092
20088 BL(J)=BU(J)
      IND(J)=-3
      GO TO 20092
20089 GO TO 20080
20090 BL(J)=ZERO
      BU(J)=ZERO
      IND(J)=-3
20091 CONTINUE
20092 CONTINUE
20084 GO TO 20080
20082 CONTINUE
20077 CONTINUE
C++  CODE FOR OUTPUT=YES IS ACTIVE
      IF (.NOT.(KPRINT.GE.1)) GO TO 20093
      ASSIGN 20096 TO NPR012
      GO TO 30012
20096 CONTINUE
20093 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
      GO TO 30001
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE RIGHT HAND SIDE)
30010 RHS(1)=ZERO
      CALL DCOPY(MRELAS,RHS,0,RHS,1)
      J=1
      N20098=NVARS+MRELAS
      GO TO 20099
20098 J=J+1
20099 IF ((N20098-J).LT.0) GO TO 20100
      NX0106=IND(J)
      IF (NX0106.LT.1.OR.NX0106.GT.4) GO TO 20106
      GO TO (20102,20103,20104,20105), NX0106
20102 SCALR=-BL(J)
      GO TO 20107
20103 SCALR=-BU(J)
      GO TO 20107
20104 SCALR=-BL(J)
      GO TO 20107
20105 SCALR=ZERO
20106 CONTINUE
20107 IF (.NOT.(SCALR.NE.ZERO)) GO TO 20108
      IF (.NOT.(J.LE.NVARS)) GO TO 20111
      I=0
20114 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20116
      GO TO 20115
20116 RHS(I)=RHS(I)+AIJ*SCALR
      GO TO 20114
20115 GO TO 20112
20111 RHS(J-NVARS)=RHS(J-NVARS)-SCALR
20112 CONTINUE
20108 GO TO 20098
20100 J=1
      N20119=NVARS+MRELAS
      GO TO 20120
20119 J=J+1
20120 IF ((N20119-J).LT.0) GO TO 20121
      SCALR=ZERO
      IF(IND(J).EQ.3.AND.MOD(IBB(J),2).EQ.0) SCALR=BU(J)-BL(J)
      IF (.NOT.(SCALR.NE.ZERO)) GO TO 20123
      IF (.NOT.(J.LE.NVARS)) GO TO 20126
      I=0
20129 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20131
      GO TO 20130
20131 RHS(I)=RHS(I)-AIJ*SCALR
      GO TO 20129
20130 GO TO 20127
20126 RHS(J-NVARS)=RHS(J-NVARS)+SCALR
20127 CONTINUE
20123 GO TO 20119
20121 CONTINUE
      GO TO NPR010, (20030,20038)
C     PROCEDURE (PERFORM SIMPLEX STEPS)
30009 ASSIGN 20134 TO NPR013
      GO TO 30013
20134 ASSIGN 20135 TO NPR014
      GO TO 30014
20135 IF (.NOT.(KPRINT.GT.2)) GO TO 20136
      CALL DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
      CALL DVOUT(NVARS+MRELAS,RZ,'('' REDUCED COSTS'')',IDG)
20136 CONTINUE
20139 ASSIGN 20141 TO NPR015
      GO TO 30015
20141 IF (.NOT.(.NOT. FOUND)) GO TO 20142
      GO TO 30016
20145 CONTINUE
20142 IF (.NOT.(FOUND)) GO TO 20146
      IF (KPRINT.GE.3) CALL DVOUT(MRELAS,WW,'('' SEARCH DIRECTION'')',
     *IDG)
      GO TO 30017
20149 IF (.NOT.(FINITE)) GO TO 20150
      GO TO 30018
20153 ASSIGN 20154 TO NPR005
      GO TO 30005
20154 GO TO 20151
20150 UNBND=.TRUE.
      IBB(IBASIS(IENTER))=0
20151 GO TO 20147
20146 GO TO 20140
20147 ITLP=ITLP+1
      GO TO 30019
20155 GO TO 20139
20140 CONTINUE
      GO TO NPR009, (20029,20037,20044,20050)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE)
30002 LPR=NVARS+4
      REWIND ISAVE
      READ(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR)
      KEY=2
      IPAGE=1
      GO TO 20157
20156 IF (NP.LT.0) GO TO 20158
20157 LPR1=LPR+1
      READ(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX)
      CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
      NP=IMAT(LMX-1)
      IPAGE=IPAGE+1
      GO TO 20156
20158 NPARM=NVARS+MRELAS
      READ(ISAVE) (IBASIS(I),I=1,NPARM)
      REWIND ISAVE
      GO TO 20006
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (SAVE DATA ON FILE ISAVE)
C
C     SOME PAGES MAY NOT BE WRITTEN YET.
30020 IF (.NOT.(AMAT(LMX).EQ.ONE)) GO TO 20159
      AMAT(LMX)=ZERO
      KEY=2
      IPAGE=ABS(IMAT(LMX-1))
      CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
C
C     FORCE PAGE FILE TO BE OPENED ON RESTARTS.
20159 KEY=AMAT(4)
      AMAT(4)=ZERO
      LPR=NVARS+4
      WRITE(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR)
      AMAT(4)=KEY
      IPAGE=1
      KEY=1
      GO TO 20163
20162 IF (NP.LT.0) GO TO 20164
20163 CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT)
      LPR1=LPR+1
      WRITE(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX)
      NP=IMAT(LMX-1)
      IPAGE=IPAGE+1
      GO TO 20162
20164 NPARM=NVARS+MRELAS
      WRITE(ISAVE) (IBASIS(I),I=1,NPARM)
      ENDFILE ISAVE
C
C     CLOSE FILE, IPAGEF, WHERE PAGES ARE STORED. THIS IS NEEDED SO THAT
C     THE PAGES MAY BE RESTORED AT A CONTINUATION OF DSPLP().
      GO TO 20317
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (DECOMPOSE BASIS MATRIX)
C++  CODE FOR OUTPUT=YES IS ACTIVE
30004 IF (.NOT.(KPRINT.GE.2)) GO TO 20165
      CALL IVOUT(MRELAS,IBASIS,
     *'('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')',
     *IDG)
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
C
C     SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE.
20165 UU=0.1
      CALL DPLPDM(
     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ANORM,EPS,UU,GG,
     *AMAT,BASMAT,CSC,WR,
     *SINGLR,REDBAS)
      IF (.NOT.(INFO.LT.0)) GO TO 20168
      GO TO 30001
20168 CONTINUE
      GO TO NPR004, (20013,20204,20242)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CLASSIFY VARIABLES)
C
C     DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES
C     -1 VIOLATES LOWER BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND.
C     (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS))
C     TRANSLATE VARIABLE TO ITS UPPER BOUND, IF .GT. UPPER BOUND
30007 PRIMAL(NVARS+1)=ZERO
      CALL DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1)
      I=1
      N20172=MRELAS
      GO TO 20173
20172 I=I+1
20173 IF ((N20172-I).LT.0) GO TO 20174
      J=IBASIS(I)
      IF (.NOT.(IND(J).NE.4)) GO TO 20176
      IF (.NOT.(RPRIM(I).LT.ZERO)) GO TO 20179
      PRIMAL(I+NVARS)=-ONE
      GO TO 20180
20179 IF (.NOT.(IND(J).EQ.3)) GO TO 10009
      UPBND=BU(J)-BL(J)
      IF (J.LE.NVARS) UPBND=UPBND/CSC(J)
      IF (.NOT.(RPRIM(I).GT.UPBND)) GO TO 20182
      RPRIM(I)=RPRIM(I)-UPBND
      IF (.NOT.(J.LE.NVARS)) GO TO 20185
      K=0
20188 CALL DPNNZR(K,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(K.LE.0)) GO TO 20190
      GO TO 20189
20190 RHS(K)=RHS(K)-UPBND*AIJ*CSC(J)
      GO TO 20188
20189 GO TO 20186
20185 RHS(J-NVARS)=RHS(J-NVARS)+UPBND
20186 PRIMAL(I+NVARS)=ONE
20182 CONTINUE
      CONTINUE
10009 CONTINUE
20180 CONTINUE
20176 GO TO 20172
20174 CONTINUE
      GO TO NPR007, (20020,20036)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS)
30005 NTRIES=1
      GO TO 20195
20194 NTRIES=NTRIES+1
20195 IF ((2-NTRIES).LT.0) GO TO 20196
      CALL DPLPCE(
     *MRELAS,NVARS,LMX,LBM,ITLP,ITBRC,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ERDNRM,EPS,TUNE,GG,
     *AMAT,BASMAT,CSC,WR,WW,PRIMAL,ERD,ERP,
     *SINGLR,REDBAS)
      IF (.NOT.(.NOT. SINGLR)) GO TO 20198
C++  CODE FOR OUTPUT=YES IS ACTIVE
      IF (.NOT.(KPRINT.GE.3)) GO TO 20201
      CALL DVOUT(MRELAS,ERP,'('' EST. ERROR IN PRIMAL COMPS.'')',IDG)
      CALL DVOUT(MRELAS,ERD,'('' EST. ERROR IN DUAL COMPS.'')',IDG)
20201 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
      GO TO 20193
20198 IF (NTRIES.EQ.2) GO TO 20197
      ASSIGN 20204 TO NPR004
      GO TO 30004
20204 CONTINUE
      GO TO 20194
20196 CONTINUE
20197 NERR=26
      CALL XERMSG ('SLATEC', 'DPLPMN',
     +   'IN DSPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.',
     +   NERR, IOPT)
      INFO=-NERR
      GO TO 30001
20193 CONTINUE
      GO TO NPR005, (20018,20154,20243)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CHECK FEASIBILITY)
C
C     SEE IF NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT
C     EQUATIONS.
C
C     COPY RHS INTO WW(*), THEN UPDATE WW(*).
30008 CALL DCOPY(MRELAS,RHS,1,WW,1)
      J=1
      N20206=MRELAS
      GO TO 20207
20206 J=J+1
20207 IF ((N20206-J).LT.0) GO TO 20208
      IBAS=IBASIS(J)
      XVAL=RPRIM(J)
C
C     ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND.
      IF (IND(IBAS).LE.3) XVAL=MAX(ZERO,XVAL)
C
C     IF THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND.
      IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20210
      UPBND=BU(IBAS)-BL(IBAS)
      IF (IBAS.LE.NVARS) UPBND=UPBND/CSC(IBAS)
      XVAL=MIN(UPBND,XVAL)
20210 CONTINUE
C
C     SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*)
      IF (.NOT.(XVAL.NE.ZERO)) GO TO 20213
      IF (.NOT.(IBAS.LE.NVARS)) GO TO 20216
      I=0
20219 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,IBAS)
      IF (.NOT.(I.LE.0)) GO TO 20221
      GO TO 20220
20221 WW(I)=WW(I)-XVAL*AIJ*CSC(IBAS)
      GO TO 20219
20220 GO TO 20217
20216 IF (.NOT.(IND(IBAS).EQ.2)) GO TO 20224
      WW(IBAS-NVARS)=WW(IBAS-NVARS)-XVAL
      GO TO 20225
20224 WW(IBAS-NVARS)=WW(IBAS-NVARS)+XVAL
20225 CONTINUE
      CONTINUE
20217 CONTINUE
20213 CONTINUE
      GO TO 20206
C
C   COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY.
20208 RESNRM=DASUM(MRELAS,WW,1)
      FEAS=RESNRM.LE.TOLLS*(RPRNRM*ANORM+RHSNRM)
C
C     TRY AN ABSOLUTE ERROR TEST IF THE RELATIVE TEST FAILS.
      IF(.NOT. FEAS)FEAS=RESNRM.LE.TOLABS
      IF (.NOT.(FEAS)) GO TO 20227
      PRIMAL(NVARS+1)=ZERO
      CALL DCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1)
20227 CONTINUE
      GO TO NPR008, (20024,20032,20040)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS)
30014 CALL DPINCW(
     *MRELAS,NVARS,LMX,LBM,NPP,JSTRT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *COSTSC,GG,ERDNRM,DULNRM,
     *AMAT,BASMAT,CSC,WR,WW,RZ,RG,COSTS,COLNRM,DUALS,
     *STPEDG)
C
      GO TO NPR014, (20135,20246)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS)
30019 IF (.NOT.(ITLP.GT.MXITLP)) GO TO 20230
      NERR=25
      ASSIGN 20233 TO NPR011
      GO TO 30011
C++  CODE FOR OUTPUT=YES IS ACTIVE
20233 IF (.NOT.(KPRINT.GE.1)) GO TO 20234
      ASSIGN 20237 TO NPR012
      GO TO 30012
20237 CONTINUE
20234 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
      IDUM(1)=0
      IF(SAVEDT) IDUM(1)=ISAVE
      WRITE (XERN1, '(I8)') MXITLP
      WRITE (XERN2, '(I8)') IDUM(1)
      CALL XERMSG ('SLATEC', 'DPLPMN',
     *   'IN DSPLP, MAX ITERATIONS = ' // XERN1 //
     *   ' TAKEN.  UP-TO-DATE RESULTS SAVED ON FILE NO. ' // XERN2 //
     *   '.   IF FILE NO. = 0, NO SAVE.', NERR, IOPT)
      INFO=-NERR
      GO TO 30001
20230 CONTINUE
      GO TO 20155
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN)
30016 IF (.NOT.(.NOT.REDBAS)) GO TO 20239
      ASSIGN 20242 TO NPR004
      GO TO 30004
20242 ASSIGN 20243 TO NPR005
      GO TO 30005
20243 ASSIGN 20244 TO NPR006
      GO TO 30006
20244 ASSIGN 20245 TO NPR013
      GO TO 30013
20245 ASSIGN 20246 TO NPR014
      GO TO 30014
20246 CONTINUE
C
C     ERASE NON-CYCLING MARKERS NEAR COMPLETION.
20239 I=MRELAS+1
      N20247=MRELAS+NVARS
      GO TO 20248
20247 I=I+1
20248 IF ((N20247-I).LT.0) GO TO 20249
      IBASIS(I)=ABS(IBASIS(I))
      GO TO 20247
20249 ASSIGN 20251 TO NPR015
      GO TO 30015
20251 CONTINUE
      GO TO 20145
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE NEW PRIMAL)
C
C     COPY RHS INTO WW(*), SOLVE SYSTEM.
30006 CALL DCOPY(MRELAS,RHS,1,WW,1)
      TRANS = .FALSE.
      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
      CALL DCOPY(MRELAS,WW,1,RPRIM,1)
      RPRNRM=DASUM(MRELAS,RPRIM,1)
      GO TO NPR006, (20019,20031,20039,20244,20275)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (COMPUTE NEW DUALS)
C
C     SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*).
30013 I=1
      N20252=MRELAS
      GO TO 20253
20252 I=I+1
20253 IF ((N20252-I).LT.0) GO TO 20254
      J=IBASIS(I)
      IF (.NOT.(J.LE.NVARS)) GO TO 20256
      DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS)
      GO TO 20257
20256 DUALS(I)=XLAMDA*PRIMAL(I+NVARS)
20257 CONTINUE
      GO TO 20252
C
20254 TRANS=.TRUE.
      CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS)
      DULNRM=DASUM(MRELAS,DUALS,1)
      GO TO NPR013, (20134,20245,20267)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION)
30015 CALL DPLPFE(
     *MRELAS,NVARS,LMX,LBM,IENTER,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ERDNRM,EPS,GG,DULNRM,DIRNRM,
     *AMAT,BASMAT,CSC,WR,WW,BL,BU,RZ,RG,COLNRM,DUALS,
     *FOUND)
      GO TO NPR015, (20141,20251)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS)
30017 CALL DPLPFL(
     *MRELAS,NVARS,IENTER,ILEAVE,
     *IBASIS,IND,IBB,
     *THETA,DIRNRM,RPRNRM,
     *CSC,WW,BL,BU,ERP,RPRIM,PRIMAL,
     *FINITE,ZEROLV)
      GO TO 20149
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (MAKE MOVE AND UPDATE)
30018 CALL DPLPMU(
     *MRELAS,NVARS,LMX,LBM,NREDC,INFO,IENTER,ILEAVE,IOPT,NPP,JSTRT,
     *IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
     *ANORM,EPS,UU,GG,RPRNRM,ERDNRM,DULNRM,THETA,COSTSC,XLAMDA,RHSNRM,
     *AMAT,BASMAT,CSC,WR,RPRIM,WW,BU,BL,RHS,ERD,ERP,RZ,RG,COLNRM,COSTS,
     *PRIMAL,DUALS,SINGLR,REDBAS,ZEROLV,STPEDG)
      IF (.NOT.(INFO.EQ.(-26))) GO TO 20259
      GO TO 30001
C++  CODE FOR OUTPUT=YES IS ACTIVE
20259 IF (.NOT.(KPRINT.GE.2)) GO TO 20263
      GO TO 30021
20266 CONTINUE
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
20263 CONTINUE
      GO TO 20153
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE(RESCALE AND REARRANGE VARIABLES)
C
C     RESCALE THE DUAL VARIABLES.
30011 ASSIGN 20267 TO NPR013
      GO TO 30013
20267 IF (.NOT.(COSTSC.NE.ZERO)) GO TO 20268
      I=1
      N20271=MRELAS
      GO TO 20272
20271 I=I+1
20272 IF ((N20271-I).LT.0) GO TO 20273
      DUALS(I)=DUALS(I)/COSTSC
      GO TO 20271
20273 CONTINUE
20268 ASSIGN 20275 TO NPR006
      GO TO 30006
C
C     REAPPLY COLUMN SCALING TO PRIMAL.
20275 I=1
      N20276=MRELAS
      GO TO 20277
20276 I=I+1
20277 IF ((N20276-I).LT.0) GO TO 20278
      J=IBASIS(I)
      IF (.NOT.(J.LE.NVARS)) GO TO 20280
      SCALR=CSC(J)
      IF(IND(J).EQ.2)SCALR=-SCALR
      RPRIM(I)=RPRIM(I)*SCALR
20280 GO TO 20276
C
C     REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*)
20278 PRIMAL(1)=ZERO
      CALL DCOPY(NVARS+MRELAS,PRIMAL,0,PRIMAL,1)
      J=1
      N20283=NVARS+MRELAS
      GO TO 20284
20283 J=J+1
20284 IF ((N20283-J).LT.0) GO TO 20285
      IBAS=ABS(IBASIS(J))
      XVAL=ZERO
      IF (J.LE.MRELAS) XVAL=RPRIM(J)
      IF (IND(IBAS).EQ.1) XVAL=XVAL+BL(IBAS)
      IF (IND(IBAS).EQ.2) XVAL=BU(IBAS)-XVAL
      IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20287
      IF (MOD(IBB(IBAS),2).EQ.0) XVAL=BU(IBAS)-BL(IBAS)-XVAL
      XVAL = XVAL+BL(IBAS)
20287 PRIMAL(IBAS)=XVAL
      GO TO 20283
C
C     COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS.
C     OTHER ENTRIES ARE ZERO.
20285 J=1
      N20290=NVARS
      GO TO 20291
20290 J=J+1
20291 IF ((N20290-J).LT.0) GO TO 20292
      RZJ=ZERO
      IF (.NOT.(IBB(J).GT.ZERO .AND. IND(J).NE.4)) GO TO 20294
      RZJ=COSTS(J)
      I=0
20297 CALL DPNNZR(I,AIJ,IPLACE,AMAT,IMAT,J)
      IF (.NOT.(I.LE.0)) GO TO 20299
      GO TO 20298
20299 CONTINUE
      RZJ=RZJ-AIJ*DUALS(I)
      GO TO 20297
20298 CONTINUE
20294 DUALS(MRELAS+J)=RZJ
      GO TO 20290
20292 CONTINUE
      GO TO NPR011, (20051,20233)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C++  CODE FOR OUTPUT=YES IS ACTIVE
C     PROCEDURE (PRINT PROLOGUE)
30003 IDUM(1)=MRELAS
      CALL IVOUT(1,IDUM,'(''1NUM. OF DEPENDENT VARS., MRELAS'')',IDG)
      IDUM(1)=NVARS
      CALL IVOUT(1,IDUM,'('' NUM. OF INDEPENDENT VARS., NVARS'')',IDG)
      CALL IVOUT(1,IDUM,'('' DIMENSION OF COSTS(*)='')',IDG)
      IDUM(1)=NVARS+MRELAS
      CALL IVOUT(1,IDUM, '('' DIMENSIONS OF BL(*),BU(*),IND(*)''
     */'' PRIMAL(*),DUALS(*) ='')',IDG)
      CALL IVOUT(1,IDUM,'('' DIMENSION OF IBASIS(*)='')',IDG)
      IDUM(1)=LPRG+1
      CALL IVOUT(1,IDUM,'('' DIMENSION OF PRGOPT(*)='')',IDG)
      CALL IVOUT(0,IDUM,
     * '('' 1-NVARS=INDEPENDENT VARIABLE INDICES.''/
     * '' (NVARS+1)-(NVARS+MRELAS)=DEPENDENT VARIABLE INDICES.''/
     * '' CONSTRAINT INDICATORS ARE 1-4 AND MEAN'')',IDG)
      CALL IVOUT(0,IDUM,
     * '('' 1=VARIABLE HAS ONLY LOWER BOUND.''/
     * '' 2=VARIABLE HAS ONLY UPPER BOUND.''/
     * '' 3=VARIABLE HAS BOTH BOUNDS.''/
     * '' 4=VARIABLE HAS NO BOUNDS, IT IS FREE.'')',IDG)
      CALL DVOUT(NVARS,COSTS,'('' ARRAY OF COSTS'')',IDG)
      CALL IVOUT(NVARS+MRELAS,IND,
     * '('' CONSTRAINT INDICATORS'')',IDG)
      CALL DVOUT(NVARS+MRELAS,BL,
     *'('' LOWER BOUNDS FOR VARIABLES  (IGNORE UNUSED ENTRIES.)'')',IDG)
      CALL DVOUT(NVARS+MRELAS,BU,
     *'('' UPPER BOUNDS FOR VARIABLES  (IGNORE UNUSED ENTRIES.)'')',IDG)
      IF (.NOT.(KPRINT.GE.2)) GO TO 20302
      CALL IVOUT(0,IDUM,
     * '(''0NON-BASIC INDICES THAT ARE NEGATIVE SHOW VARIABLES''
     * '' EXCHANGED AT A ZERO''/'' STEP LENGTH'')',IDG)
      CALL IVOUT(0,IDUM,
     * '('' WHEN COL. NO. LEAVING=COL. NO. ENTERING, THE ENTERING ''
     * ''VARIABLE MOVED''/'' TO ITS BOUND.  IT REMAINS NON-BASIC.''/
     * '' WHEN COL. NO. OF BASIS EXCHANGED IS NEGATIVE, THE LEAVING''/
     * '' VARIABLE IS AT ITS UPPER BOUND.'')',IDG)
20302 CONTINUE
      GO TO 20011
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (PRINT SUMMARY)
30012 IDUM(1)=INFO
      CALL IVOUT(1,IDUM,'('' THE OUTPUT VALUE OF INFO IS'')',IDG)
      IF (.NOT.(MINPRB)) GO TO 20305
      CALL IVOUT(0,IDUM,'('' THIS IS A MINIMIZATION PROBLEM.'')',IDG)
      GO TO 20306
20305 CALL IVOUT(0,IDUM,'('' THIS IS A MAXIMIZATION PROBLEM.'')',IDG)
20306 IF (.NOT.(STPEDG)) GO TO 20308
      CALL IVOUT(0,IDUM,'('' STEEPEST EDGE PRICING WAS USED.'')',IDG)
      GO TO 20309
20308 CALL IVOUT(0,IDUM,'('' MINIMUM REDUCED COST PRICING WAS USED.'')',
     * IDG)
20309 RDUM(1)=DDOT(NVARS,COSTS,1,PRIMAL,1)
      CALL DVOUT(1,RDUM,
     * '('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',IDG)
      CALL DVOUT(NVARS+MRELAS,PRIMAL,
     * '('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',IDG)
      CALL DVOUT(MRELAS+NVARS,DUALS,
     * '('' THE OUTPUT DUAL VARIABLES'')',IDG)
      CALL IVOUT(NVARS+MRELAS,IBASIS,
     * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG)
      IDUM(1)=ITLP
      CALL IVOUT(1,IDUM,'('' NO. OF ITERATIONS'')',IDG)
      IDUM(1)=NREDC
      CALL IVOUT(1,IDUM,'('' NO. OF FULL REDECOMPS'')',IDG)
      GO TO NPR012, (20096,20237)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (PRINT ITERATION SUMMARY)
30021 IDUM(1)=ITLP+1
      CALL IVOUT(1,IDUM,'(''0ITERATION NUMBER'')',IDG)
      IDUM(1)=IBASIS(ABS(ILEAVE))
      CALL IVOUT(1,IDUM,
     * '('' INDEX OF VARIABLE ENTERING THE BASIS'')',IDG)
      IDUM(1)=ILEAVE
      CALL IVOUT(1,IDUM,'('' COLUMN OF THE BASIS EXCHANGED'')',IDG)
      IDUM(1)=IBASIS(IENTER)
      CALL IVOUT(1,IDUM,
     * '('' INDEX OF VARIABLE LEAVING THE BASIS'')',IDG)
      RDUM(1)=THETA
      CALL DVOUT(1,RDUM,'('' LENGTH OF THE EXCHANGE STEP'')',IDG)
      IF (.NOT.(KPRINT.GE.3)) GO TO 20311
      CALL DVOUT(MRELAS,RPRIM,'('' BASIC (INTERNAL) PRIMAL SOLN.'')',
     * IDG)
      CALL IVOUT(NVARS+MRELAS,IBASIS,
     * '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG)
      CALL IVOUT(NVARS+MRELAS,IBB,'('' IBB ARRAY'')',IDG)
      CALL DVOUT(MRELAS,RHS,'('' TRANSLATED RHS'')',IDG)
      CALL DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
20311 CONTINUE
      GO TO 20266
C++  CODE FOR OUTPUT=NO IS INACTIVE
C++  END
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     PROCEDURE (RETURN TO USER)
30001 IF (.NOT.(SAVEDT)) GO TO 20314
      GO TO 30020
20317 CONTINUE
20314 IF(IMAT(LMX-1).NE.(-1)) CALL SCLOSM(IPAGEF)
C
C     THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN
C     COMPILERS.
      RETURN
      END
	  
*DECK DPLPUP
      SUBROUTINE DPLPUP (DUSRMT, MRELAS, NVARS, PRGOPT, DATTRV, BL, BU,
     +   IND, INFO, AMAT, IMAT, SIZEUP, ASMALL, ABIG)
C***BEGIN PROLOGUE  DPLPUP
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPLPUP-S, DPLPUP-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/.
C
C     REVISED 810613-1130
C     REVISED YYMMDD-HHMM
C
C     THIS SUBROUTINE COLLECTS INFORMATION ABOUT THE BOUNDS AND MATRIX
C     FROM THE USER.  IT IS PART OF THE DSPLP( ) PACKAGE.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DPCHNG, DPNNZR, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Corrected references to XERRWV.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   891009  Removed unreferenced variables.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   900510  Convert XERRWV calls to XERMSG calls, changed do-it-yourself
C           DO loops to DO loops.  (RWC)
C   900602  Get rid of ASSIGNed GOTOs.  (RWC)
C***END PROLOGUE  DPLPUP
      DOUBLE PRECISION ABIG,AIJ,AMAT(*),AMN,AMX,ASMALL,BL(*),
     * BU(*),DATTRV(*),PRGOPT(*),XVAL,ZERO
      INTEGER IFLAG(10),IMAT(*),IND(*)
      LOGICAL SIZEUP,FIRST
      CHARACTER*8 XERN1, XERN2
      CHARACTER*16 XERN3, XERN4
C
C***FIRST EXECUTABLE STATEMENT  DPLPUP
      ZERO = 0.D0
C
C     CHECK USER-SUPPLIED BOUNDS
C
C     CHECK THAT IND(*) VALUES ARE 1,2,3 OR 4.
C     ALSO CHECK CONSISTENCY OF UPPER AND LOWER BOUNDS.
C
      DO 10 J=1,NVARS
         IF (IND(J).LT.1 .OR. IND(J).GT.4) THEN
            WRITE (XERN1, '(I8)') J
            CALL XERMSG ('SLATEC', 'DPLPUP',
     *         'IN DSPLP, INDEPENDENT VARIABLE = ' // XERN1 //
     *         ' IS NOT DEFINED.', 10, 1)
            INFO = -10
            RETURN
         ENDIF
C
         IF (IND(J).EQ.3) THEN
            IF (BL(J).GT.BU(J)) THEN
               WRITE (XERN1, '(I8)') J
               WRITE (XERN3, '(1PE15.6)') BL(J)
               WRITE (XERN4, '(1PE15.6)') BU(J)
               CALL XERMSG ('SLATEC', 'DPLPUP',
     *            'IN DSPLP, LOWER BOUND = ' // XERN3 //
     *            ' AND UPPER BOUND = ' // XERN4 //
     *            ' FOR INDEPENDENT VARIABLE = ' // XERN1 //
     *            ' ARE NOT CONSISTENT.', 11, 1)
               RETURN
            ENDIF
         ENDIF
   10 CONTINUE
C
      DO 20 I=NVARS+1,NVARS+MRELAS
         IF (IND(I).LT.1 .OR. IND(I).GT.4) THEN
            WRITE (XERN1, '(I8)') I-NVARS
            CALL XERMSG ('SLATEC', 'DPLPUP',
     *         'IN DSPLP, DEPENDENT VARIABLE = ' // XERN1 //
     *         ' IS NOT DEFINED.', 12, 1)
            INFO = -12
            RETURN
         ENDIF
C
         IF (IND(I).EQ.3) THEN
            IF (BL(I).GT.BU(I)) THEN
               WRITE (XERN1, '(I8)') I
               WRITE (XERN3, '(1PE15.6)') BL(I)
               WRITE (XERN4, '(1PE15.6)') BU(I)
               CALL XERMSG ('SLATEC', 'DPLPUP',
     *            'IN DSPLP, LOWER BOUND = ' // XERN3 //
     *            ' AND UPPER BOUND = ' // XERN4 //
     *            ' FOR DEPENDANT VARIABLE = ' // XERN1 //
     *            ' ARE NOT CONSISTENT.',13,1)
               INFO = -13
               RETURN
            ENDIF
         ENDIF
   20 CONTINUE
C
C     GET UPDATES OR DATA FOR MATRIX FROM THE USER
C
C     GET THE ELEMENTS OF THE MATRIX FROM THE USER.  IT WILL BE STORED
C     BY COLUMNS USING THE SPARSE STORAGE CODES OF RJ HANSON AND
C     JA WISNIEWSKI.
C
      IFLAG(1) = 1
C
C     KEEP ACCEPTING ELEMENTS UNTIL THE USER IS FINISHED GIVING THEM.
C     LIMIT THIS LOOP TO 2*NVARS*MRELAS ITERATIONS.
C
      ITMAX = 2*NVARS*MRELAS+1
      ITCNT = 0
      FIRST = .TRUE.
C
C     CHECK ON THE ITERATION COUNT.
C
   30 ITCNT = ITCNT+1
      IF (ITCNT.GT.ITMAX) THEN
         CALL XERMSG ('SLATEC', 'DPLPUP',
     +      'IN DSPLP, MORE THAN 2*NVARS*MRELAS ITERATIONS DEFINING ' //
     +      'OR UPDATING MATRIX DATA.', 7, 1)
         INFO = -7
         RETURN
      ENDIF
C
      AIJ = ZERO
      CALL DUSRMT(I,J,AIJ,INDCAT,PRGOPT,DATTRV,IFLAG)
      IF (IFLAG(1).EQ.1) THEN
         IFLAG(1) = 2
         GO TO 30
      ENDIF
C
C     CHECK TO SEE THAT THE SUBSCRIPTS I AND J ARE VALID.
C
      IF (I.LT.1 .OR. I.GT.MRELAS .OR. J.LT.1 .OR. J.GT.NVARS) THEN
C
C        CHECK ON SIZE OF MATRIX DATA
C        RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS.
C
         IF (IFLAG(1).EQ.3) THEN
            IF (SIZEUP .AND. ABS(AIJ).NE.ZERO) THEN
               IF (FIRST) THEN
                  AMX = ABS(AIJ)
                  AMN = ABS(AIJ)
                  FIRST = .FALSE.
               ELSEIF (ABS(AIJ).GT.AMX) THEN
                  AMX = ABS(AIJ)
               ELSEIF (ABS(AIJ).LT.AMN) THEN
                  AMN = ABS(AIJ)
               ENDIF
            ENDIF
            GO TO 40
         ENDIF
C
         WRITE (XERN1, '(I8)') I
         WRITE (XERN2, '(I8)') J
         CALL XERMSG ('SLATEC', 'DPLPUP',
     *      'IN DSPLP, ROW INDEX = ' // XERN1 // ' OR COLUMN INDEX = '
     *      // XERN2 // ' IS OUT OF RANGE.', 8, 1)
         INFO = -8
         RETURN
      ENDIF
C
C     IF INDCAT=0 THEN SET A(I,J)=AIJ.
C     IF INDCAT=1 THEN ACCUMULATE ELEMENT, A(I,J)=A(I,J)+AIJ.
C
      IF (INDCAT.EQ.0) THEN
         CALL DPCHNG(I,AIJ,IPLACE,AMAT,IMAT,J)
      ELSEIF (INDCAT.EQ.1) THEN
         INDEX = -(I-1)
         CALL DPNNZR(INDEX,XVAL,IPLACE,AMAT,IMAT,J)
         IF (INDEX.EQ.I) AIJ=AIJ+XVAL
         CALL DPCHNG(I,AIJ,IPLACE,AMAT,IMAT,J)
      ELSE
         WRITE (XERN1, '(I8)') INDCAT
         CALL XERMSG ('SLATEC', 'DPLPUP',
     *      'IN DSPLP, INDICATION FLAG = ' // XERN1 //
     *      ' FOR MATRIX DATA MUST BE EITHER 0 OR 1.', 9, 1)
         INFO = -9
         RETURN
      ENDIF
C
C     CHECK ON SIZE OF MATRIX DATA
C     RECORD THE LARGEST AND SMALLEST(IN MAGNITUDE) NONZERO ELEMENTS.
C
      IF (SIZEUP .AND. ABS(AIJ).NE.ZERO) THEN
         IF (FIRST) THEN
            AMX = ABS(AIJ)
            AMN = ABS(AIJ)
            FIRST = .FALSE.
         ELSEIF (ABS(AIJ).GT.AMX) THEN
            AMX = ABS(AIJ)
         ELSEIF (ABS(AIJ).LT.AMN) THEN
            AMN = ABS(AIJ)
         ENDIF
      ENDIF
      IF (IFLAG(1).NE.3) GO TO 30
C
   40 IF (SIZEUP .AND. .NOT. FIRST) THEN
         IF (AMN.LT.ASMALL .OR. AMX.GT.ABIG) THEN
            CALL XERMSG ('SLATEC', 'DPLPUP',
     +         'IN DSPLP, A MATRIX ELEMENT''S SIZE IS OUT OF THE ' //
     +         'SPECIFIED RANGE.', 22, 1)
            INFO = -22
            RETURN
         ENDIF
      ENDIF
      RETURN
      END
*DECK DPNNZR
      SUBROUTINE DPNNZR (I, XVAL, IPLACE, SX, IX, IRCX)
C***BEGIN PROLOGUE  DPNNZR
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PNNZRS-S, DPNNZR-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C     DPNNZR LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME.
C     SPARSE MATRIX NON ZERO RETRIEVAL SUBROUTINE.
C
C     SUBROUTINE DPNNZR() GETS THE NEXT NONZERO VALUE IN ROW OR COLUMN
C     +/- IRCX WITH AN INDEX GREATER THAN THE VALUE OF I.
C
C             I ABSOLUTE VALUE OF THIS SUBSCRIPT IS TO BE EXCEEDED
C               IN THE SEARCH FOR THE NEXT NONZERO VALUE. A NEGATIVE
C               OR ZERO VALUE OF I CAUSES THE SEARCH TO START AT
C               THE BEGINNING OF THE VECTOR.  A POSITIVE VALUE
C               OF I CAUSES THE SEARCH TO CONTINUE FROM THE LAST PLACE
C               ACCESSED. ON OUTPUT, THE ARGUMENT I
C               CONTAINS THE VALUE OF THE SUBSCRIPT FOUND.  AN OUTPUT
C               VALUE OF I EQUAL TO ZERO INDICATES THAT ALL COMPONENTS
C               WITH AN INDEX GREATER THAN THE INPUT VALUE OF I ARE
C               ZERO.
C          XVAL VALUE OF THE NONZERO ELEMENT FOUND.  ON OUTPUT,
C               XVAL=0. WHENEVER I=0.
C     IPLACE POINTER INFORMATION WHICH IS MAINTAINED BY THE PACKAGE.
C   SX(*),IX(*) THE WORK ARRAYS WHICH ARE USED TO STORE THE SPARSE
C               MATRIX.  THESE ARRAY CONTENTS ARE AUTOMATICALLY
C               MAINTAINED BY THE PACKAGE FOR THE USER.
C          IRCX POINTS TO THE VECTOR OF THE MATRIX BEING SCANNED.  A
C               NEGATIVE VALUE OF IRCX INDICATES THAT ROW -IRCX IS TO BE
C               SCANNED.  A POSITIVE VALUE OF IRCX INDICATES THAT
C               COLUMN IRCX IS TO BE SCANNED.  A ZERO VALUE OF IRCX IS
C               AN ERROR.
C
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LNNZRS,
C     SANDIA LABS. REPT. SAND78-0785.
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C     REVISED 811130-1000
C     REVISED YYMMDD-HHMM
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  IDLOC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   890606  Changed references from IPLOC to IDLOC.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910403  Updated AUTHOR and DESCRIPTION sections.  (WRB)
C***END PROLOGUE  DPNNZR
      DIMENSION IX(*)
      DOUBLE PRECISION XVAL,SX(*),ZERO
      SAVE ZERO
      DATA ZERO /0.D0/
C***FIRST EXECUTABLE STATEMENT  DPNNZR
      IOPT=1
C
C     CHECK VALIDITY OF ROW/COL. INDEX.
C
      IF (.NOT.(IRCX .EQ.0)) GO TO 20002
      NERR=55
      CALL XERMSG ('SLATEC', 'DPNNZR', 'IRCX=0', NERR, IOPT)
C
C     LMX IS THE LENGTH OF THE IN-MEMORY STORAGE AREA.
C
20002 LMX = IX(1)
      IF (.NOT.(IRCX.LT.0)) GO TO 20005
C
C     CHECK SUBSCRIPTS OF THE ROW. THE ROW NUMBER MUST BE .LE. M AND
C     THE INDEX MUST BE .LE. N.
C
      IF (.NOT.(IX(2).LT.-IRCX .OR. IX(3).LT.ABS(I))) GO TO 20008
      NERR=55
      CALL XERMSG ('SLATEC', 'DPNNZR',
     +   'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' //
     +   'BOUNDS.', NERR, IOPT)
20008 L=IX(3)
      GO TO 20006
C
C     CHECK SUBSCRIPTS OF THE COLUMN. THE COL. NUMBER MUST BE .LE. N AND
C     THE INDEX MUST BE .LE. M.
C
20005 IF (.NOT.(IRCX.GT.IX(3) .OR. ABS(I).GT.IX(2))) GO TO 20011
      NERR=55
      CALL XERMSG ('SLATEC', 'DPNNZR',
     +   'SUBSCRIPTS FOR ARRAY ELEMENT TO BE ACCESSED WERE OUT OF ' //
     +   'BOUNDS', NERR, IOPT)
20011 L=IX(2)
C
C     HERE L IS THE LARGEST POSSIBLE SUBSCRIPT WITHIN THE VECTOR.
C
20006 J=ABS(IRCX)
      LL=IX(3)+4
      LPG = LMX - LL
      IF (.NOT.(IRCX.GT.0)) GO TO 20014
C
C     SEARCHING FOR THE NEXT NONZERO IN A COLUMN.
C
C     INITIALIZE STARTING LOCATIONS..
      IF (.NOT.(I.LE.0)) GO TO 20017
      IF (.NOT.(J.EQ.1)) GO TO 20020
      IPLACE=LL+1
      GO TO 20021
20020 IPLACE=IX(J+3)+1
20021 CONTINUE
C
C     THE CASE I.LE.0 SIGNALS THAT THE SCAN FOR THE ENTRY
C     IS TO BEGIN AT THE START OF THE VECTOR.
C
20017 I = ABS(I)
      IF (.NOT.(J.EQ.1)) GO TO 20023
      ISTART = LL+1
      GO TO 20024
20023 ISTART=IX(J+3)+1
20024 IEND = IX(J+4)
C
C     VALIDATE IPLACE. SET TO START OF VECTOR IF OUT OF RANGE.
C
      IF (.NOT.(ISTART.GT.IPLACE .OR. IPLACE.GT.IEND)) GO TO 20026
      IF (.NOT.(J.EQ.1)) GO TO 20029
      IPLACE=LL+1
      GO TO 20030
20029 IPLACE=IX(J+3)+1
20030 CONTINUE
C
C     SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ENTRY.
C
20026 IPL = IDLOC(IPLACE,SX,IX)
C
C     FIX UP IPLACE AND IPL IF THEY POINT TO PAGING DATA.
C     THIS IS NECESSARY BECAUSE THERE IS CONTROL INFORMATION AT THE
C     END OF EACH PAGE.
C
      IDIFF = LMX - IPL
      IF (.NOT.(IDIFF.LE.1.AND.IX(LMX-1).GT.0)) GO TO 20032
C
C     UPDATE THE RELATIVE ADDRESS IN A NEW PAGE.
C
      IPLACE = IPLACE + IDIFF + 1
      IPL = IDLOC(IPLACE,SX,IX)
20032 NP = ABS(IX(LMX-1))
      GO TO 20036
20035 IF (ILAST.EQ.IEND) GO TO 20037
20036 ILAST = MIN(IEND,NP*LPG+LL-2)
C
C     THE VIRTUAL END OF THE DATA FOR THIS PAGE IS ILAST.
C
      IL = IDLOC(ILAST,SX,IX)
      IL = MIN(IL,LMX-2)
C
C     THE RELATIVE END OF DATA FOR THIS PAGE IS IL.
C     SEARCH FOR A NONZERO VALUE WITH AN INDEX .GT. I ON THE PRESENT
C     PAGE.
C
20038 IF (.NOT.(.NOT.(IPL.GE.IL.OR.(IX(IPL).GT.I.AND.SX(IPL).NE.ZERO))))
     * GO TO 20039
      IPL=IPL+1
      GO TO 20038
C
C     TEST IF WE HAVE FOUND THE NEXT NONZERO.
C
20039 IF (.NOT.(IX(IPL).GT.I .AND. SX(IPL).NE.ZERO .AND. IPL.LE.IL)) GO
     *TO 20040
      I = IX(IPL)
      XVAL = SX(IPL)
      IPLACE = (NP-1)*LPG + IPL
      RETURN
C
C     UPDATE TO SCAN THE NEXT PAGE.
20040 IPL = LL + 1
      NP = NP + 1
      GO TO 20035
C
C     NO DATA WAS FOUND. END OF VECTOR ENCOUNTERED.
C
20037 I = 0
      XVAL = ZERO
      IL = IL + 1
      IF(IL.EQ.LMX-1) IL = IL + 2
C
C     IF A NEW ITEM WOULD BE INSERTED, IPLACE POINTS TO THE PLACE
C     TO PUT IT.
C
      IPLACE = (NP-1)*LPG + IL
      RETURN
C
C     SEARCH A ROW FOR THE NEXT NONZERO.
C     FIND ELEMENT J=ABS(IRCX) IN ROWS ABS(I)+1,...,L.
C
20014 I=ABS(I)
C
C     CHECK FOR END OF VECTOR.
C
      IF (.NOT.(I.EQ.L)) GO TO 20043
      I=0
      XVAL=ZERO
      RETURN
20043 I1 = I+1
      II=I1
      N20046=L
      GO TO 20047
20046 II=II+1
20047 IF ((N20046-II).LT.0) GO TO 20048
C
C     INITIALIZE IPPLOC FOR ORTHOGONAL SCAN.
C     LOOK FOR J AS A SUBSCRIPT IN ROWS II, II=I+1,...,L.
C
      IF (.NOT.(II.EQ.1)) GO TO 20050
      IPPLOC = LL + 1
      GO TO 20051
20050 IPPLOC = IX(II+3) + 1
20051 IEND = IX(II+4)
C
C     SCAN THROUGH SEVERAL PAGES, IF NECESSARY, TO FIND MATRIX ENTRY.
C
      IPL = IDLOC(IPPLOC,SX,IX)
C
C     FIX UP IPPLOC AND IPL TO POINT TO MATRIX DATA.
C
      IDIFF = LMX - IPL
      IF (.NOT.(IDIFF.LE.1.AND.IX(LMX-1).GT.0)) GO TO 20053
      IPPLOC = IPPLOC + IDIFF + 1
      IPL = IDLOC(IPPLOC,SX,IX)
20053 NP = ABS(IX(LMX-1))
      GO TO 20057
20056 IF (ILAST.EQ.IEND) GO TO 20058
20057 ILAST = MIN(IEND,NP*LPG+LL-2)
      IL = IDLOC(ILAST,SX,IX)
      IL = MIN(IL,LMX-2)
20059 IF (.NOT.(.NOT.(IPL.GE.IL .OR. IX(IPL).GE.J))) GO TO 20060
      IPL=IPL+1
      GO TO 20059
C
C     TEST IF WE HAVE FOUND THE NEXT NONZERO.
C
20060 IF (.NOT.(IX(IPL).EQ.J .AND. SX(IPL).NE.ZERO .AND. IPL.LE.IL)) GO
     *TO 20061
      I = II
      XVAL = SX(IPL)
      RETURN
20061 IF(IX(IPL).GE.J) ILAST = IEND
      IPL = LL + 1
      NP = NP + 1
      GO TO 20056
20058 GO TO 20046
C
C     ORTHOGONAL SCAN FAILED. THE VALUE J WAS NOT A SUBSCRIPT
C     IN ANY ROW.
C
20048 I=0
      XVAL=ZERO
      RETURN
      END
*DECK DPOCH
      DOUBLE PRECISION FUNCTION DPOCH (A, X)
C***BEGIN PROLOGUE  DPOCH
C***PURPOSE  Evaluate a generalization of Pochhammer's symbol.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C1, C7A
C***TYPE      DOUBLE PRECISION (POCH-S, DPOCH-D)
C***KEYWORDS  FNLIB, POCHHAMMER, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate a double precision generalization of Pochhammer's symbol
C (A)-sub-X = GAMMA(A+X)/GAMMA(A) for double precision A and X.
C For X a non-negative integer, POCH(A,X) is just Pochhammer's symbol.
C This is a preliminary version that does not handle wrong arguments
C properly and may not properly handle the case when the result is
C computed to less than half of double precision.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D9LGMC, DFAC, DGAMMA, DGAMR, DLGAMS, DLNREL, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  DPOCH
      DOUBLE PRECISION A, X, ABSA, ABSAX, ALNGA, ALNGAX, AX, B, PI,
     1  SGNGA, SGNGAX, DFAC, DLNREL, D9LGMC, DGAMMA, DGAMR, DCOT
      EXTERNAL DGAMMA
      SAVE PI
      DATA PI / 3.1415926535 8979323846 2643383279 503 D0 /
C***FIRST EXECUTABLE STATEMENT  DPOCH
      AX = A + X
      IF (AX.GT.0.0D0) GO TO 30
      IF (AINT(AX).NE.AX) GO TO 30
C
      IF (A .GT. 0.0D0 .OR. AINT(A) .NE. A) CALL XERMSG ('SLATEC',
     +   'DPOCH', 'A+X IS NON-POSITIVE INTEGER BUT A IS NOT', 2, 2)
C
C WE KNOW HERE THAT BOTH A+X AND A ARE NON-POSITIVE INTEGERS.
C
      DPOCH = 1.0D0
      IF (X.EQ.0.D0) RETURN
C
      N = X
      IF (MIN(A+X,A).LT.(-20.0D0)) GO TO 20
C
      IA = A
      DPOCH = (-1.0D0)**N * DFAC(-IA)/DFAC(-IA-N)
      RETURN
C
 20   DPOCH = (-1.0D0)**N * EXP ((A-0.5D0)*DLNREL(X/(A-1.0D0))
     1  + X*LOG(-A+1.0D0-X) - X + D9LGMC(-A+1.0D0) - D9LGMC(-A-X+1.D0))
      RETURN
C
C A+X IS NOT ZERO OR A NEGATIVE INTEGER.
C
 30   DPOCH = 0.0D0
      IF (A.LE.0.0D0 .AND. AINT(A).EQ.A) RETURN
C
      N = ABS(X)
      IF (DBLE(N).NE.X .OR. N.GT.20) GO TO 50
C
C X IS A SMALL NON-POSITIVE INTEGER, PRESUMMABLY A COMMON CASE.
C
      DPOCH = 1.0D0
      IF (N.EQ.0) RETURN
      DO 40 I=1,N
        DPOCH = DPOCH * (A+I-1)
 40   CONTINUE
      RETURN
C
 50   ABSAX = ABS(A+X)
      ABSA = ABS(A)
      IF (MAX(ABSAX,ABSA).GT.20.0D0) GO TO 60
      DPOCH = DGAMMA(A+X) * DGAMR(A)
      RETURN
C
 60   IF (ABS(X).GT.0.5D0*ABSA) GO TO 70
C
C ABS(X) IS SMALL AND BOTH ABS(A+X) AND ABS(A) ARE LARGE.  THUS,
C A+X AND A MUST HAVE THE SAME SIGN.  FOR NEGATIVE A, WE USE
C GAMMA(A+X)/GAMMA(A) = GAMMA(-A+1)/GAMMA(-A-X+1) *
C SIN(PI*A)/SIN(PI*(A+X))
C
      B = A
      IF (B.LT.0.0D0) B = -A - X + 1.0D0
      DPOCH = EXP ((B-0.5D0)*DLNREL(X/B) + X*LOG(B+X) - X
     1  + D9LGMC(B+X) - D9LGMC(B) )
      IF (A.LT.0.0D0 .AND. DPOCH.NE.0.0D0) DPOCH =
     1  DPOCH/(COS(PI*X) + DCOT(PI*A)*SIN(PI*X) )
      RETURN
C
 70   CALL DLGAMS (A+X, ALNGAX, SGNGAX)
      CALL DLGAMS (A, ALNGA, SGNGA)
      DPOCH = SGNGAX * SGNGA * EXP(ALNGAX-ALNGA)
C
      RETURN
      END
*DECK DPOCH1
      DOUBLE PRECISION FUNCTION DPOCH1 (A, X)
C***BEGIN PROLOGUE  DPOCH1
C***PURPOSE  Calculate a generalization of Pochhammer's symbol starting
C            from first order.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C1, C7A
C***TYPE      DOUBLE PRECISION (POCH1-S, DPOCH1-D)
C***KEYWORDS  FIRST ORDER, FNLIB, POCHHAMMER, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate a double precision generalization of Pochhammer's symbol
C for double precision A and X for special situations that require
C especially accurate values when X is small in
C        POCH1(A,X) = (POCH(A,X)-1)/X
C                   = (GAMMA(A+X)/GAMMA(A) - 1.0)/X .
C This specification is particularly suited for stably computing
C expressions such as
C        (GAMMA(A+X)/GAMMA(A) - GAMMA(B+X)/GAMMA(B))/X
C             = POCH1(A,X) - POCH1(B,X)
C Note that POCH1(A,0.0) = PSI(A)
C
C When ABS(X) is so small that substantial cancellation will occur if
C the straightforward formula is used, we use an expansion due
C to Fields and discussed by Y. L. Luke, The Special Functions and Their
C Approximations, Vol. 1, Academic Press, 1969, page 34.
C
C The ratio POCH(A,X) = GAMMA(A+X)/GAMMA(A) is written by Luke as
C        (A+(X-1)/2)**X * polynomial in (A+(X-1)/2)**(-2) .
C In order to maintain significance in POCH1, we write for positive a
C        (A+(X-1)/2)**X = EXP(X*LOG(A+(X-1)/2)) = EXP(Q)
C                       = 1.0 + Q*EXPREL(Q) .
C Likewise the polynomial is written
C        POLY = 1.0 + X*POLY1(A,X) .
C Thus,
C        POCH1(A,X) = (POCH(A,X) - 1) / X
C                   = EXPREL(Q)*(Q/X + Q*POLY1(A,X)) + POLY1(A,X)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DCOT, DEXPRL, DPOCH, DPSI, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  DPOCH1
      DOUBLE PRECISION A, X, ABSA, ABSX, ALNEPS, ALNVAR, B, BERN(20),
     1  BINV, BP, GBERN(21), GBK, PI, POLY1, Q, RHO, SINPXX, SINPX2,
     2  SQTBIG, TERM, TRIG, VAR, VAR2, D1MACH, DPSI, DEXPRL, DCOT, DPOCH
      LOGICAL FIRST
      EXTERNAL DCOT
      SAVE BERN, PI, SQTBIG, ALNEPS, FIRST
      DATA BERN  (  1) / +.8333333333 3333333333 3333333333 333 D-1    /
      DATA BERN  (  2) / -.1388888888 8888888888 8888888888 888 D-2    /
      DATA BERN  (  3) / +.3306878306 8783068783 0687830687 830 D-4    /
      DATA BERN  (  4) / -.8267195767 1957671957 6719576719 576 D-6    /
      DATA BERN  (  5) / +.2087675698 7868098979 2100903212 014 D-7    /
      DATA BERN  (  6) / -.5284190138 6874931848 4768220217 955 D-9    /
      DATA BERN  (  7) / +.1338253653 0684678832 8269809751 291 D-10   /
      DATA BERN  (  8) / -.3389680296 3225828668 3019539124 944 D-12   /
      DATA BERN  (  9) / +.8586062056 2778445641 3590545042 562 D-14   /
      DATA BERN  ( 10) / -.2174868698 5580618730 4151642386 591 D-15   /
      DATA BERN  ( 11) / +.5509002828 3602295152 0265260890 225 D-17   /
      DATA BERN  ( 12) / -.1395446468 5812523340 7076862640 635 D-18   /
      DATA BERN  ( 13) / +.3534707039 6294674716 9322997780 379 D-20   /
      DATA BERN  ( 14) / -.8953517427 0375468504 0261131811 274 D-22   /
      DATA BERN  ( 15) / +.2267952452 3376830603 1095073886 816 D-23   /
      DATA BERN  ( 16) / -.5744724395 2026452383 4847971943 400 D-24   /
      DATA BERN  ( 17) / +.1455172475 6148649018 6626486727 132 D-26   /
      DATA BERN  ( 18) / -.3685994940 6653101781 8178247990 866 D-28   /
      DATA BERN  ( 19) / +.9336734257 0950446720 3255515278 562 D-30   /
      DATA BERN  ( 20) / -.2365022415 7006299345 5963519636 983 D-31   /
      DATA PI / 3.1415926535 8979323846 2643383279 503 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DPOCH1
      IF (FIRST) THEN
         SQTBIG = 1.0D0/SQRT(24.0D0*D1MACH(1))
         ALNEPS = LOG(D1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      IF (X.EQ.0.0D0) DPOCH1 = DPSI(A)
      IF (X.EQ.0.0D0) RETURN
C
      ABSX = ABS(X)
      ABSA = ABS(A)
      IF (ABSX.GT.0.1D0*ABSA) GO TO 70
      IF (ABSX*LOG(MAX(ABSA,2.0D0)).GT.0.1D0) GO TO 70
C
      BP = A
      IF (A.LT.(-0.5D0)) BP = 1.0D0 - A - X
      INCR = 0
      IF (BP.LT.10.0D0) INCR = 11.0D0 - BP
      B = BP + INCR
C
      VAR = B + 0.5D0*(X-1.0D0)
      ALNVAR = LOG(VAR)
      Q = X*ALNVAR
C
      POLY1 = 0.0D0
      IF (VAR.GE.SQTBIG) GO TO 40
      VAR2 = (1.0D0/VAR)**2
C
      RHO = 0.5D0*(X+1.0D0)
      GBERN(1) = 1.0D0
      GBERN(2) = -RHO/12.0D0
      TERM = VAR2
      POLY1 = GBERN(2)*TERM
C
      NTERMS = -0.5D0*ALNEPS/ALNVAR + 1.0D0
      IF (NTERMS .GT. 20) CALL XERMSG ('SLATEC', 'DPOCH1',
     +   'NTERMS IS TOO BIG, MAYBE D1MACH(3) IS BAD', 1, 2)
      IF (NTERMS.LT.2) GO TO 40
C
      DO 30 K=2,NTERMS
        GBK = 0.0D0
        DO 20 J=1,K
          NDX = K - J + 1
          GBK = GBK + BERN(NDX)*GBERN(J)
 20     CONTINUE
        GBERN(K+1) = -RHO*GBK/K
C
        TERM = TERM * (2*K-2-X)*(2*K-1-X)*VAR2
        POLY1 = POLY1 + GBERN(K+1)*TERM
 30   CONTINUE
C
 40   POLY1 = (X-1.0D0)*POLY1
      DPOCH1 = DEXPRL(Q)*(ALNVAR+Q*POLY1) + POLY1
C
      IF (INCR.EQ.0) GO TO 60
C
C WE HAVE DPOCH1(B,X), BUT BP IS SMALL, SO WE USE BACKWARDS RECURSION
C TO OBTAIN DPOCH1(BP,X).
C
      DO 50 II=1,INCR
        I = INCR - II
        BINV = 1.0D0/(BP+I)
        DPOCH1 = (DPOCH1 - BINV) / (1.0D0 + X*BINV)
 50   CONTINUE
C
 60   IF (BP.EQ.A) RETURN
C
C WE HAVE DPOCH1(BP,X), BUT A IS LT -0.5.  WE THEREFORE USE A REFLECTION
C FORMULA TO OBTAIN DPOCH1(A,X).
C
      SINPXX = SIN(PI*X)/X
      SINPX2 = SIN(0.5D0*PI*X)
      TRIG = SINPXX*DCOT(PI*B) - 2.0D0*SINPX2*(SINPX2/X)
C
      DPOCH1 = TRIG + (1.0D0 + X*TRIG)*DPOCH1
      RETURN
C
 70   DPOCH1 = (DPOCH(A,X) - 1.0D0) / X
      RETURN
C
      END
*DECK DPOCO
      SUBROUTINE DPOCO (A, LDA, N, RCOND, Z, INFO)
C***BEGIN PROLOGUE  DPOCO
C***PURPOSE  Factor a real symmetric positive definite matrix
C            and estimate the condition of the matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B
C***TYPE      DOUBLE PRECISION (SPOCO-S, DPOCO-D, CPOCO-C)
C***KEYWORDS  CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION, POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPOCO factors a double precision symmetric positive definite
C     matrix and estimates the condition of the matrix.
C
C     If  RCOND  is not needed, DPOFA is slightly faster.
C     To solve  A*X = B , follow DPOCO by DPOSL.
C     To compute  INVERSE(A)*C , follow DPOCO by DPOSL.
C     To compute  DETERMINANT(A) , follow DPOCO by DPODI.
C     To compute  INVERSE(A) , follow DPOCO by DPODI.
C
C     On Entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the symmetric matrix to be factored.  Only the
C                diagonal and upper triangle are used.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix  R  so that  A = TRANS(R)*R
C                where  TRANS(R)  is the transpose.
C                The strict lower triangle is unaltered.
C                If  INFO .NE. 0 , the factorization is not complete.
C
C        RCOND   DOUBLE PRECISION
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.  If INFO .NE. 0 , RCOND is unchanged.
C
C        Z       DOUBLE PRECISION(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C                If  INFO .NE. 0 , Z  is unchanged.
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  signals an error condition.  The leading minor
C                     of order  K  is not positive definite.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DASUM, DAXPY, DDOT, DPOFA, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPOCO
      INTEGER LDA,N,INFO
      DOUBLE PRECISION A(LDA,*),Z(*)
      DOUBLE PRECISION RCOND
C
      DOUBLE PRECISION DDOT,EK,T,WK,WKM
      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM
      INTEGER I,J,JM1,K,KB,KP1
C
C     FIND NORM OF A USING ONLY UPPER HALF
C
C***FIRST EXECUTABLE STATEMENT  DPOCO
      DO 30 J = 1, N
         Z(J) = DASUM(J,A(1,J),1)
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 20
         DO 10 I = 1, JM1
            Z(I) = Z(I) + ABS(A(I,J))
   10    CONTINUE
   20    CONTINUE
   30 CONTINUE
      ANORM = 0.0D0
      DO 40 J = 1, N
         ANORM = MAX(ANORM,Z(J))
   40 CONTINUE
C
C     FACTOR
C
      CALL DPOFA(A,LDA,N,INFO)
      IF (INFO .NE. 0) GO TO 180
C
C        RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C        ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
C        THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C        GROWTH IN THE ELEMENTS OF W  WHERE  TRANS(R)*W = E .
C        THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C        SOLVE TRANS(R)*W = E
C
         EK = 1.0D0
         DO 50 J = 1, N
            Z(J) = 0.0D0
   50    CONTINUE
         DO 110 K = 1, N
            IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K))
            IF (ABS(EK-Z(K)) .LE. A(K,K)) GO TO 60
               S = A(K,K)/ABS(EK-Z(K))
               CALL DSCAL(N,S,Z,1)
               EK = S*EK
   60       CONTINUE
            WK = EK - Z(K)
            WKM = -EK - Z(K)
            S = ABS(WK)
            SM = ABS(WKM)
            WK = WK/A(K,K)
            WKM = WKM/A(K,K)
            KP1 = K + 1
            IF (KP1 .GT. N) GO TO 100
               DO 70 J = KP1, N
                  SM = SM + ABS(Z(J)+WKM*A(K,J))
                  Z(J) = Z(J) + WK*A(K,J)
                  S = S + ABS(Z(J))
   70          CONTINUE
               IF (S .GE. SM) GO TO 90
                  T = WKM - WK
                  WK = WKM
                  DO 80 J = KP1, N
                     Z(J) = Z(J) + T*A(K,J)
   80             CONTINUE
   90          CONTINUE
  100       CONTINUE
            Z(K) = WK
  110    CONTINUE
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
C
C        SOLVE R*Y = W
C
         DO 130 KB = 1, N
            K = N + 1 - KB
            IF (ABS(Z(K)) .LE. A(K,K)) GO TO 120
               S = A(K,K)/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
  120       CONTINUE
            Z(K) = Z(K)/A(K,K)
            T = -Z(K)
            CALL DAXPY(K-1,T,A(1,K),1,Z(1),1)
  130    CONTINUE
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
C
         YNORM = 1.0D0
C
C        SOLVE TRANS(R)*V = Y
C
         DO 150 K = 1, N
            Z(K) = Z(K) - DDOT(K-1,A(1,K),1,Z(1),1)
            IF (ABS(Z(K)) .LE. A(K,K)) GO TO 140
               S = A(K,K)/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
               YNORM = S*YNORM
  140       CONTINUE
            Z(K) = Z(K)/A(K,K)
  150    CONTINUE
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
         YNORM = S*YNORM
C
C        SOLVE R*Z = V
C
         DO 170 KB = 1, N
            K = N + 1 - KB
            IF (ABS(Z(K)) .LE. A(K,K)) GO TO 160
               S = A(K,K)/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
               YNORM = S*YNORM
  160       CONTINUE
            Z(K) = Z(K)/A(K,K)
            T = -Z(K)
            CALL DAXPY(K-1,T,A(1,K),1,Z(1),1)
  170    CONTINUE
C        MAKE ZNORM = 1.0
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
         YNORM = S*YNORM
C
         IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
         IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
  180 CONTINUE
      RETURN
      END
*DECK DPODI
      SUBROUTINE DPODI (A, LDA, N, DET, JOB)
C***BEGIN PROLOGUE  DPODI
C***PURPOSE  Compute the determinant and inverse of a certain real
C            symmetric positive definite matrix using the factors
C            computed by DPOCO, DPOFA or DQRDC.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B, D3B1B
C***TYPE      DOUBLE PRECISION (SPODI-S, DPODI-D, CPODI-C)
C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPODI computes the determinant and inverse of a certain
C     double precision symmetric positive definite matrix (see below)
C     using the factors computed by DPOCO, DPOFA or DQRDC.
C
C     On Entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the output  A  from DPOCO or DPOFA
C                or the output  X  from DQRDC.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        JOB     INTEGER
C                = 11   both determinant and inverse.
C                = 01   inverse only.
C                = 10   determinant only.
C
C     On Return
C
C        A       If DPOCO or DPOFA was used to factor  A , then
C                DPODI produces the upper half of INVERSE(A) .
C                If DQRDC was used to decompose  X , then
C                DPODI produces the upper half of inverse(TRANS(X)*X)
C                where TRANS(X) is the transpose.
C                Elements of  A  below the diagonal are unchanged.
C                If the units digit of JOB is zero,  A  is unchanged.
C
C        DET     DOUBLE PRECISION(2)
C                determinant of  A  or of  TRANS(X)*X  if requested.
C                Otherwise not referenced.
C                Determinant = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. DET(1) .LT. 10.0
C                or  DET(1) .EQ. 0.0 .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal and the inverse is requested.
C        It will not occur if the subroutines are called correctly
C        and if DPOCO or DPOFA has set INFO .EQ. 0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPODI
      INTEGER LDA,N,JOB
      DOUBLE PRECISION A(LDA,*)
      DOUBLE PRECISION DET(2)
C
      DOUBLE PRECISION T
      DOUBLE PRECISION S
      INTEGER I,J,JM1,K,KP1
C***FIRST EXECUTABLE STATEMENT  DPODI
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0D0
         DET(2) = 0.0D0
         S = 10.0D0
         DO 50 I = 1, N
            DET(1) = A(I,I)**2*DET(1)
            IF (DET(1) .EQ. 0.0D0) GO TO 60
   10       IF (DET(1) .GE. 1.0D0) GO TO 20
               DET(1) = S*DET(1)
               DET(2) = DET(2) - 1.0D0
            GO TO 10
   20       CONTINUE
   30       IF (DET(1) .LT. S) GO TO 40
               DET(1) = DET(1)/S
               DET(2) = DET(2) + 1.0D0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(R)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 140
         DO 100 K = 1, N
            A(K,K) = 1.0D0/A(K,K)
            T = -A(K,K)
            CALL DSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = 0.0D0
               CALL DAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM  INVERSE(R) * TRANS(INVERSE(R))
C
         DO 130 J = 1, N
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 120
            DO 110 K = 1, JM1
               T = A(K,J)
               CALL DAXPY(K,T,A(1,J),1,A(1,K),1)
  110       CONTINUE
  120       CONTINUE
            T = A(J,J)
            CALL DSCAL(J,T,A(1,J),1)
  130    CONTINUE
  140 CONTINUE
      RETURN
      END
*DECK DPOFA
      SUBROUTINE DPOFA (A, LDA, N, INFO)
C***BEGIN PROLOGUE  DPOFA
C***PURPOSE  Factor a real symmetric positive definite matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B
C***TYPE      DOUBLE PRECISION (SPOFA-S, DPOFA-D, CPOFA-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPOFA factors a double precision symmetric positive definite
C     matrix.
C
C     DPOFA is usually called by DPOCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (time for DPOCO) = (1 + 18/N)*(time for DPOFA) .
C
C     On Entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the symmetric matrix to be factored.  Only the
C                diagonal and upper triangle are used.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix  R  so that  A = TRANS(R)*R
C                where  TRANS(R)  is the transpose.
C                The strict lower triangle is unaltered.
C                If  INFO .NE. 0 , the factorization is not complete.
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  signals an error condition.  The leading minor
C                     of order  K  is not positive definite.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPOFA
      INTEGER LDA,N,INFO
      DOUBLE PRECISION A(LDA,*)
C
      DOUBLE PRECISION DDOT,T
      DOUBLE PRECISION S
      INTEGER J,JM1,K
C***FIRST EXECUTABLE STATEMENT  DPOFA
         DO 30 J = 1, N
            INFO = J
            S = 0.0D0
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1)
               T = T/A(K,K)
               A(K,J) = T
               S = S + T*T
   10       CONTINUE
   20       CONTINUE
            S = A(J,J) - S
            IF (S .LE. 0.0D0) GO TO 40
            A(J,J) = SQRT(S)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END
*DECK DPOFS
      SUBROUTINE DPOFS (A, LDA, N, V, ITASK, IND, WORK)
C***BEGIN PROLOGUE  DPOFS
C***PURPOSE  Solve a positive definite symmetric system of linear
C            equations.
C***LIBRARY   SLATEC
C***CATEGORY  D2B1B
C***TYPE      DOUBLE PRECISION (SPOFS-S, DPOFS-D, CPOFS-C)
C***KEYWORDS  HERMITIAN, LINEAR EQUATIONS, POSITIVE DEFINITE, SYMMETRIC
C***AUTHOR  Voorhees, E. A., (LANL)
C***DESCRIPTION
C
C    Subroutine DPOFS solves a  positive definite symmetric
C    NxN system of double precision linear equations using
C    LINPACK subroutines DPOCO and DPOSL.  That is, if A is an
C    NxN double precision positive definite symmetric matrix and if
C    X and B are double precision N-vectors, then DPOFS solves
C    the equation
C
C                          A*X=B.
C
C    The matrix A is first factored into upper and lower tri-
C    angular matrices R and R-TRANPOSE.  These factors are used to
C    find the solution vector X.  An approximate condition number is
C    calculated to provide a rough estimate of the number of
C    digits of accuracy in the computed solution.
C
C    If the equation A*X=B is to be solved for more than one vector
C    B, the factoring of A does not need to be performed again and
C    the option only to solve (ITASK .GT. 1) will be faster for
C    the succeeding solutions.  In this case, the contents of A,
C    LDA, and N must not have been altered by the user following
C    factorization (ITASK=1).  IND will not be changed by DPOFS
C    in this case.
C
C  Argument Description ***
C
C    A      DOUBLE PRECISION(LDA,N)
C             on entry, the doubly subscripted array with dimension
C               (LDA,N) which contains the coefficient matrix.  Only
C               the upper triangle, including the diagonal, of the
C               coefficient matrix need be entered and will subse-
C               quently be referenced and changed by the routine.
C             on return, A contains in its upper triangle an upper
C               triangular matrix R such that A = (R-TRANPOSE) * R .
C    LDA    INTEGER
C             the leading dimension of the array A.  LDA must be great-
C             er than or equal to N.  (terminal error message IND=-1)
C    N      INTEGER
C             the order of the matrix A.  N must be greater
C             than or equal to 1.  (terminal error message IND=-2)
C    V      DOUBLE PRECISION(N)
C             on entry, the singly subscripted array(vector) of di-
C               mension N which contains the right hand side B of a
C               system of simultaneous linear equations  A*X=B.
C             on return, V contains the solution vector, X .
C    ITASK  INTEGER
C             If ITASK = 1, the matrix A is factored and then the
C               linear equation is solved.
C             If ITASK .GT. 1, the equation is solved using the existing
C               factored matrix A.
C             If ITASK .LT. 1, then terminal error message IND=-3 is
C               printed.
C    IND    INTEGER
C             GT. 0  IND is a rough estimate of the number of digits
C                     of accuracy in the solution, X.
C             LT. 0  See error message corresponding to IND below.
C    WORK   DOUBLE PRECISION(N)
C             a singly subscripted array of dimension at least N.
C
C  Error Messages Printed ***
C
C    IND=-1  Terminal   N is greater than LDA.
C    IND=-2  Terminal   N is less than 1.
C    IND=-3  Terminal   ITASK is less than 1.
C    IND=-4  Terminal   The matrix A is computationally singular or
C                         is not positive definite.  A solution
C                         has not been computed.
C    IND=-10 Warning    The solution has no apparent significance.
C                         The solution may be inaccurate or the
C                         matrix A may be poorly scaled.
C
C               Note-  The above Terminal(*fatal*) Error Messages are
C                      designed to be handled by XERMSG in which
C                      LEVEL=1 (recoverable) and IFLAG=2 .  LEVEL=0
C                      for warning error messages from XERMSG.  Unless
C                      the user provides otherwise, an error message
C                      will be printed followed by an abort.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  D1MACH, DPOCO, DPOSL, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800514  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPOFS
C
      INTEGER LDA,N,ITASK,IND,INFO
      DOUBLE PRECISION A(LDA,*),V(*),WORK(*),D1MACH
      DOUBLE PRECISION RCOND
      CHARACTER*8 XERN1, XERN2
C***FIRST EXECUTABLE STATEMENT  DPOFS
      IF (LDA.LT.N) THEN
         IND = -1
         WRITE (XERN1, '(I8)') LDA
         WRITE (XERN2, '(I8)') N
         CALL XERMSG ('SLATEC', 'DPOFS', 'LDA = ' // XERN1 //
     *      ' IS LESS THAN N = ' // XERN2, -1, 1)
         RETURN
      ENDIF
C
      IF (N.LE.0) THEN
         IND = -2
         WRITE (XERN1, '(I8)') N
         CALL XERMSG ('SLATEC', 'DPOFS', 'N = ' // XERN1 //
     *      ' IS LESS THAN 1', -2, 1)
         RETURN
      ENDIF
C
      IF (ITASK.LT.1) THEN
         IND = -3
         WRITE (XERN1, '(I8)') ITASK
         CALL XERMSG ('SLATEC', 'DPOFS', 'ITASK = ' // XERN1 //
     *      ' IS LESS THAN 1', -3, 1)
         RETURN
      ENDIF
C
      IF (ITASK.EQ.1) THEN
C
C        FACTOR MATRIX A INTO R
C
         CALL DPOCO(A,LDA,N,RCOND,WORK,INFO)
C
C        CHECK FOR POSITIVE DEFINITE MATRIX
C
         IF (INFO.NE.0) THEN
            IND = -4
            CALL XERMSG ('SLATEC', 'DPOFS',
     *         'SINGULAR OR NOT POSITIVE DEFINITE - NO SOLUTION', -4, 1)
            RETURN
         ENDIF
C
C        COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS)
C        AND CHECK FOR IND GREATER THAN ZERO
C
         IND = -LOG10(D1MACH(4)/RCOND)
         IF (IND.EQ.0) THEN
            IND = -10
            CALL XERMSG ('SLATEC', 'DPOFS',
     *         'SOLUTION MAY HAVE NO SIGNIFICANCE', -10, 0)
         ENDIF
      ENDIF
C
C     SOLVE AFTER FACTORING
C
      CALL DPOSL(A,LDA,N,V)
      RETURN
      END
*DECK DPOLCF
      SUBROUTINE DPOLCF (XX, N, X, C, D, WORK)
C***BEGIN PROLOGUE  DPOLCF
C***PURPOSE  Compute the coefficients of the polynomial fit (including
C            Hermite polynomial fits) produced by a previous call to
C            POLINT.
C***LIBRARY   SLATEC
C***CATEGORY  E1B
C***TYPE      DOUBLE PRECISION (POLCOF-S, DPOLCF-D)
C***KEYWORDS  COEFFICIENTS, POLYNOMIAL
C***AUTHOR  Huddleston, R. E., (SNLL)
C***DESCRIPTION
C
C     Abstract
C        Subroutine DPOLCF computes the coefficients of the polynomial
C     fit (including Hermite polynomial fits ) produced by a previous
C     call to DPLINT.  The coefficients of the polynomial, expanded
C     about XX, are stored in the array D. The expansion is of the form
C     P(Z) = D(1) + D(2)*(Z-XX) +D(3)*((Z-XX)**2) + ... +
C                                                  D(N)*((Z-XX)**(N-1)).
C     Between the call to DPLINT and the call to DPOLCF the variable N
C     and the arrays X and C must not be altered.
C
C     *****  INPUT PARAMETERS
C      *** All TYPE REAL variables are DOUBLE PRECISION ***
C
C     XX   - The point about which the Taylor expansion is to be made.
C
C     N    - ****
C            *     N, X, and C must remain unchanged between the
C     X    - *     call to DPLINT and the call to DPOLCF.
C     C    - ****
C
C     *****  OUTPUT PARAMETER
C      *** All TYPE REAL variables are DOUBLE PRECISION ***
C
C     D    - The array of coefficients for the Taylor expansion as
C            explained in the abstract
C
C     *****  STORAGE PARAMETER
C
C     WORK - This is an array to provide internal working storage. It
C            must be dimensioned by at least 2*N in the calling program.
C
C
C     **** Note - There are two methods for evaluating the fit produced
C     by DPLINT. You may call DPOLVL to perform the task, or you may
C     call DPOLCF to obtain the coefficients of the Taylor expansion and
C     then write your own evaluation scheme. Due to the inherent errors
C     in the computations of the Taylor expansion from the Newton
C     coefficients produced by DPLINT, much more accuracy may be
C     expected by calling DPOLVL as opposed to writing your own scheme.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   890213  DATE WRITTEN
C   891006  Cosmetic changes to prologue.  (WRB)
C   891024  Corrected KEYWORD section.  (WRB)
C   891024  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DPOLCF
C
      INTEGER I,IM1,K,KM1,KM1PI,KM2N,KM2NPI,N,NM1,NMKP1,NPKM1
      DOUBLE PRECISION C(*),D(*),PONE,PTWO,X(*),XX,WORK(*)
C***FIRST EXECUTABLE STATEMENT  DPOLCF
      DO 10010 K=1,N
      D(K)=C(K)
10010 CONTINUE
      IF (N.EQ.1) RETURN
      WORK(1)=1.0D0
      PONE=C(1)
      NM1=N-1
      DO 10020 K=2,N
      KM1=K-1
      NPKM1=N+K-1
      WORK(NPKM1)=XX-X(KM1)
      WORK(K)=WORK(NPKM1)*WORK(KM1)
      PTWO=PONE+WORK(K)*C(K)
      PONE=PTWO
10020 CONTINUE
      D(1)=PTWO
      IF (N.EQ.2) RETURN
      DO 10030 K=2,NM1
      KM1=K-1
      KM2N=K-2+N
      NMKP1=N-K+1
      DO 10030 I=2,NMKP1
      KM2NPI=KM2N+I
      IM1=I-1
      KM1PI=KM1+I
      WORK(I)=WORK(KM2NPI)*WORK(IM1)+WORK(I)
      D(K)=D(K)+WORK(I)*D(KM1PI)
10030 CONTINUE
      RETURN
      END
*DECK DPOLFT
      SUBROUTINE DPOLFT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A)
C***BEGIN PROLOGUE  DPOLFT
C***PURPOSE  Fit discrete data in a least squares sense by polynomials
C            in one variable.
C***LIBRARY   SLATEC
C***CATEGORY  K1A1A2
C***TYPE      DOUBLE PRECISION (POLFIT-S, DPOLFT-D)
C***KEYWORDS  CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT
C***AUTHOR  Shampine, L. F., (SNLA)
C           Davenport, S. M., (SNLA)
C           Huddleston, R. E., (SNLL)
C***DESCRIPTION
C
C     Abstract
C
C     Given a collection of points X(I) and a set of values Y(I) which
C     correspond to some function or measurement at each of the X(I),
C     subroutine  DPOLFT  computes the weighted least-squares polynomial
C     fits of all degrees up to some degree either specified by the user
C     or determined by the routine.  The fits thus obtained are in
C     orthogonal polynomial form.  Subroutine  DP1VLU  may then be
C     called to evaluate the fitted polynomials and any of their
C     derivatives at any point.  The subroutine  DPCOEF  may be used to
C     express the polynomial fits as powers of (X-C) for any specified
C     point C.
C
C     The parameters for  DPOLFT  are
C
C     Input -- All TYPE REAL variables are DOUBLE PRECISION
C         N -      the number of data points.  The arrays X, Y and W
C                  must be dimensioned at least  N  (N .GE. 1).
C         X -      array of values of the independent variable.  These
C                  values may appear in any order and need not all be
C                  distinct.
C         Y -      array of corresponding function values.
C         W -      array of positive values to be used as weights.  If
C                  W(1) is negative,  DPOLFT  will set all the weights
C                  to 1.0, which means unweighted least squares error
C                  will be minimized.  To minimize relative error, the
C                  user should set the weights to:  W(I) = 1.0/Y(I)**2,
C                  I = 1,...,N .
C         MAXDEG - maximum degree to be allowed for polynomial fit.
C                  MAXDEG  may be any non-negative integer less than  N.
C                  Note -- MAXDEG  cannot be equal to  N-1  when a
C                  statistical test is to be used for degree selection,
C                  i.e., when input value of  EPS  is negative.
C         EPS -    specifies the criterion to be used in determining
C                  the degree of fit to be computed.
C                  (1)  If  EPS  is input negative,  DPOLFT  chooses the
C                       degree based on a statistical F test of
C                       significance.  One of three possible
C                       significance levels will be used:  .01, .05 or
C                       .10.  If  EPS=-1.0 , the routine will
C                       automatically select one of these levels based
C                       on the number of data points and the maximum
C                       degree to be considered.  If  EPS  is input as
C                       -.01, -.05, or -.10, a significance level of
C                       .01, .05, or .10, respectively, will be used.
C                  (2)  If  EPS  is set to 0.,  DPOLFT  computes the
C                       polynomials of degrees 0 through  MAXDEG .
C                  (3)  If  EPS  is input positive,  EPS  is the RMS
C                       error tolerance which must be satisfied by the
C                       fitted polynomial.  DPOLFT  will increase the
C                       degree of fit until this criterion is met or
C                       until the maximum degree is reached.
C
C     Output -- All TYPE REAL variables are DOUBLE PRECISION
C         NDEG -   degree of the highest degree fit computed.
C         EPS -    RMS error of the polynomial of degree  NDEG .
C         R -      vector of dimension at least NDEG containing values
C                  of the fit of degree  NDEG  at each of the  X(I) .
C                  Except when the statistical test is used, these
C                  values are more accurate than results from subroutine
C                  DP1VLU  normally are.
C         IERR -   error flag with the following possible values.
C             1 -- indicates normal execution, i.e., either
C                  (1)  the input value of  EPS  was negative, and the
C                       computed polynomial fit of degree  NDEG
C                       satisfies the specified F test, or
C                  (2)  the input value of  EPS  was 0., and the fits of
C                       all degrees up to  MAXDEG  are complete, or
C                  (3)  the input value of  EPS  was positive, and the
C                       polynomial of degree  NDEG  satisfies the RMS
C                       error requirement.
C             2 -- invalid input parameter.  At least one of the input
C                  parameters has an illegal value and must be corrected
C                  before  DPOLFT  can proceed.  Valid input results
C                  when the following restrictions are observed
C                       N .GE. 1
C                       0 .LE. MAXDEG .LE. N-1  for  EPS .GE. 0.
C                       0 .LE. MAXDEG .LE. N-2  for  EPS .LT. 0.
C                       W(1)=-1.0  or  W(I) .GT. 0., I=1,...,N .
C             3 -- cannot satisfy the RMS error requirement with a
C                  polynomial of degree no greater than  MAXDEG .  Best
C                  fit found is of degree  MAXDEG .
C             4 -- cannot satisfy the test for significance using
C                  current value of  MAXDEG .  Statistically, the
C                  best fit found is of order  NORD .  (In this case,
C                  NDEG will have one of the values:  MAXDEG-2,
C                  MAXDEG-1, or MAXDEG).  Using a higher value of
C                  MAXDEG  may result in passing the test.
C         A -      work and output array having at least 3N+3MAXDEG+3
C                  locations
C
C     Note - DPOLFT  calculates all fits of degrees up to and including
C            NDEG .  Any or all of these fits can be evaluated or
C            expressed as powers of (X-C) using  DP1VLU  and  DPCOEF
C            after just one call to  DPOLFT .
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  DP1VLU, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900911  Added variable YP to DOUBLE PRECISION declaration.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C   920527  Corrected erroneous statements in DESCRIPTION.  (WRB)
C***END PROLOGUE  DPOLFT
      INTEGER I,IDEGF,IERR,J,JP1,JPAS,K1,K1PJ,K2,K2PJ,K3,K3PI,K4,
     * K4PI,K5,K5PI,KSIG,M,MAXDEG,MOP1,NDEG,NDER,NFAIL
      DOUBLE PRECISION TEMD1,TEMD2
      DOUBLE PRECISION A(*),DEGF,DEN,EPS,ETST,F,FCRIT,R(*),SIG,SIGJ,
     * SIGJM1,SIGPAS,TEMP,X(*),XM,Y(*),YP,W(*),W1,W11
      DOUBLE PRECISION CO(4,3)
      SAVE CO
      DATA  CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2),
     1      CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3),
     2  CO(4,3)/-13.086850D0,-2.4648165D0,-3.3846535D0,-1.2973162D0,
     3          -3.3381146D0,-1.7812271D0,-3.2578406D0,-1.6589279D0,
     4          -1.6282703D0,-1.3152745D0,-3.2640179D0,-1.9829776D0/
C***FIRST EXECUTABLE STATEMENT  DPOLFT
      M = ABS(N)
      IF (M .EQ. 0) GO TO 30
      IF (MAXDEG .LT. 0) GO TO 30
      A(1) = MAXDEG
      MOP1 = MAXDEG + 1
      IF (M .LT. MOP1) GO TO 30
      IF (EPS .LT. 0.0D0 .AND.  M .EQ. MOP1) GO TO 30
      XM = M
      ETST = EPS*EPS*XM
      IF (W(1) .LT. 0.0D0) GO TO 2
      DO 1 I = 1,M
        IF (W(I) .LE. 0.0D0) GO TO 30
 1      CONTINUE
      GO TO 4
 2    DO 3 I = 1,M
 3      W(I) = 1.0D0
 4    IF (EPS .GE. 0.0D0) GO TO 8
C
C DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR
C CHOOSING DEGREE OF POLYNOMIAL FIT
C
      IF (EPS .GT. (-.55D0)) GO TO 5
      IDEGF = M - MAXDEG - 1
      KSIG = 1
      IF (IDEGF .LT. 10) KSIG = 2
      IF (IDEGF .LT. 5) KSIG = 3
      GO TO 8
 5    KSIG = 1
      IF (EPS .LT. (-.03D0)) KSIG = 2
      IF (EPS .LT. (-.07D0)) KSIG = 3
C
C INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING
C
 8    K1 = MAXDEG + 1
      K2 = K1 + MAXDEG
      K3 = K2 + MAXDEG + 2
      K4 = K3 + M
      K5 = K4 + M
      DO 9 I = 2,K4
 9      A(I) = 0.0D0
      W11 = 0.0D0
      IF (N .LT. 0) GO TO 11
C
C UNCONSTRAINED CASE
C
      DO 10 I = 1,M
        K4PI = K4 + I
        A(K4PI) = 1.0D0
 10     W11 = W11 + W(I)
      GO TO 13
C
C CONSTRAINED CASE
C
 11   DO 12 I = 1,M
        K4PI = K4 + I
 12     W11 = W11 + W(I)*A(K4PI)**2
C
C COMPUTE FIT OF DEGREE ZERO
C
 13   TEMD1 = 0.0D0
      DO 14 I = 1,M
        K4PI = K4 + I
        TEMD1 = TEMD1 + W(I)*Y(I)*A(K4PI)
 14     CONTINUE
      TEMD1 = TEMD1/W11
      A(K2+1) = TEMD1
      SIGJ = 0.0D0
      DO 15 I = 1,M
        K4PI = K4 + I
        K5PI = K5 + I
        TEMD2 = TEMD1*A(K4PI)
        R(I) = TEMD2
        A(K5PI) = TEMD2 - R(I)
 15     SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2
      J = 0
C
C SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION
C
      IF (EPS) 24,26,27
C
C INCREMENT DEGREE
C
 16   J = J + 1
      JP1 = J + 1
      K1PJ = K1 + J
      K2PJ = K2 + J
      SIGJM1 = SIGJ
C
C COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1
C
      IF (J .GT. 1) A(K1PJ) = W11/W1
C
C COMPUTE NEW A COEFFICIENT
C
      TEMD1 = 0.0D0
      DO 18 I = 1,M
        K4PI = K4 + I
        TEMD2 = A(K4PI)
        TEMD1 = TEMD1 + X(I)*W(I)*TEMD2*TEMD2
 18     CONTINUE
      A(JP1) = TEMD1/W11
C
C EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS
C
      W1 = W11
      W11 = 0.0D0
      DO 19 I = 1,M
        K3PI = K3 + I
        K4PI = K4 + I
        TEMP = A(K3PI)
        A(K3PI) = A(K4PI)
        A(K4PI) = (X(I)-A(JP1))*A(K3PI) - A(K1PJ)*TEMP
 19     W11 = W11 + W(I)*A(K4PI)**2
C
C GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE
C PRECISION
C
      TEMD1 = 0.0D0
      DO 20 I = 1,M
        K4PI = K4 + I
        K5PI = K5 + I
        TEMD2 = W(I)*((Y(I)-R(I))-A(K5PI))*A(K4PI)
 20     TEMD1 = TEMD1 + TEMD2
      TEMD1 = TEMD1/W11
      A(K2PJ+1) = TEMD1
C
C UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND
C ACCUMULATE SUM OF SQUARES OF ERRORS.  THE POLYNOMIAL EVALUATIONS ARE
C COMPUTED AND STORED IN EXTENDED PRECISION.  FOR THE I-TH DATA POINT,
C THE MOST SIGNIFICANT BITS ARE STORED IN  R(I) , AND THE LEAST
C SIGNIFICANT BITS ARE IN  A(K5PI) .
C
      SIGJ = 0.0D0
      DO 21 I = 1,M
        K4PI = K4 + I
        K5PI = K5 + I
        TEMD2 = R(I) + A(K5PI) + TEMD1*A(K4PI)
        R(I) = TEMD2
        A(K5PI) = TEMD2 - R(I)
 21     SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2
C
C SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE
C MAXDEG  HAS BEEN REACHED
C
      IF (EPS) 23,26,27
C
C COMPUTE F STATISTICS  (INPUT EPS .LT. 0.)
C
 23   IF (SIGJ .EQ. 0.0D0) GO TO 29
      DEGF = M - J - 1
      DEN = (CO(4,KSIG)*DEGF + 1.0D0)*DEGF
      FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN
      FCRIT = FCRIT*FCRIT
      F = (SIGJM1 - SIGJ)*DEGF/SIGJ
      IF (F .LT. FCRIT) GO TO 25
C
C POLYNOMIAL OF DEGREE J SATISFIES F TEST
C
 24   SIGPAS = SIGJ
      JPAS = J
      NFAIL = 0
      IF (MAXDEG .EQ. J) GO TO 32
      GO TO 16
C
C POLYNOMIAL OF DEGREE J FAILS F TEST.  IF THERE HAVE BEEN THREE
C SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND.
C
 25   NFAIL = NFAIL + 1
      IF (NFAIL .GE. 3) GO TO 29
      IF (MAXDEG .EQ. J) GO TO 32
      GO TO 16
C
C RAISE THE DEGREE IF DEGREE  MAXDEG  HAS NOT YET BEEN REACHED  (INPUT
C EPS = 0.)
C
 26   IF (MAXDEG .EQ. J) GO TO 28
      GO TO 16
C
C SEE IF RMS ERROR CRITERION IS SATISFIED  (INPUT EPS .GT. 0.)
C
 27   IF (SIGJ .LE. ETST) GO TO 28
      IF (MAXDEG .EQ. J) GO TO 31
      GO TO 16
C
C RETURNS
C
 28   IERR = 1
      NDEG = J
      SIG = SIGJ
      GO TO 33
 29   IERR = 1
      NDEG = JPAS
      SIG = SIGPAS
      GO TO 33
 30   IERR = 2
      CALL XERMSG ('SLATEC', 'DPOLFT', 'INVALID INPUT PARAMETER.', 2,
     +   1)
      GO TO 37
 31   IERR = 3
      NDEG = MAXDEG
      SIG = SIGJ
      GO TO 33
 32   IERR = 4
      NDEG = JPAS
      SIG = SIGPAS
C
 33   A(K3) = NDEG
C
C WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT
C ALL THE DATA POINTS IF  R  DOES NOT ALREADY CONTAIN THESE VALUES
C
      IF(EPS .GE. 0.0  .OR.  NDEG .EQ. MAXDEG) GO TO 36
      NDER = 0
      DO 35 I = 1,M
        CALL DP1VLU (NDEG,NDER,X(I),R(I),YP,A)
 35     CONTINUE
 36   EPS = SQRT(SIG/XM)
 37   RETURN
      END
*DECK DPOLVL
      SUBROUTINE DPOLVL (NDER, XX, YFIT, YP, N, X, C, WORK, IERR)
C***BEGIN PROLOGUE  DPOLVL
C***PURPOSE  Calculate the value of a polynomial and its first NDER
C            derivatives where the polynomial was produced by a previous
C            call to DPLINT.
C***LIBRARY   SLATEC
C***CATEGORY  E3
C***TYPE      DOUBLE PRECISION (POLYVL-S, DPOLVL-D)
C***KEYWORDS  POLYNOMIAL EVALUATION
C***AUTHOR  Huddleston, R. E., (SNLL)
C***DESCRIPTION
C
C     Abstract -
C        Subroutine DPOLVL calculates the value of the polynomial and
C     its first NDER derivatives where the polynomial was produced by
C     a previous call to DPLINT.
C        The variable N and the arrays X and C must not be altered
C     between the call to DPLINT and the call to DPOLVL.
C
C     ******  Dimensioning Information *******
C
C     YP   must be dimensioned by at least NDER
C     X    must be dimensioned by at least N (see the abstract )
C     C    must be dimensioned by at least N (see the abstract )
C     WORK must be dimensioned by at least 2*N if NDER is .GT. 0.
C
C     *** Note ***
C       If NDER=0, neither YP nor WORK need to be dimensioned variables.
C       If NDER=1, YP does not need to be a dimensioned variable.
C
C
C     *****  Input parameters
C       ***  All TYPE REAL variables are DOUBLE PRECISION ***
C
C     NDER - the number of derivatives to be evaluated
C
C     XX   - the argument at which the polynomial and its derivatives
C            are to be evaluated.
C
C     N    - *****
C            *       N, X, and C must not be altered between the call
C     X    - *       to DPLINT and the call to DPOLVL.
C     C    - *****
C
C
C     *****  Output Parameters
C       ***  All TYPE REAL variables are DOUBLE PRECISION ***
C
C     YFIT - the value of the polynomial at XX
C
C     YP   - the derivatives of the polynomial at XX.  The derivative of
C            order J at XX is stored in  YP(J) , J = 1,...,NDER.
C
C     IERR - Output error flag with the following possible values.
C          = 1  indicates normal execution
C
C     ***** Storage Parameters
C
C     WORK  = this is an array to provide internal working storage for
C             DPOLVL.  It must be dimensioned by at least 2*N if NDER is
C             .GT. 0.  If NDER=0, WORK does not need to be a dimensioned
C             variable.
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPOLVL
      INTEGER I,IERR,IM1,IZERO,K,KM1,KM1PI,KM2PN,KM2PNI,M,MM,N,NDR,NDER,
     * NMKP1,NPKM1
      DOUBLE PRECISION  C(*),FAC,PIONE,PITWO,PONE,PTWO,X(*),XK,XX,
     * YFIT,YP(*),WORK(*)
C***FIRST EXECUTABLE STATEMENT  DPOLVL
      IERR=1
         IF (NDER.GT.0) GO TO 10020
C
C     *****   CODING FOR THE CASE NDER = 0
C
      PIONE=1.0D0
      PONE=C(1)
      YFIT=PONE
      IF (N.EQ.1) RETURN
      DO 10010 K=2,N
      PITWO=(XX-X(K-1))*PIONE
      PIONE=PITWO
      PTWO=PONE+PITWO*C(K)
      PONE=PTWO
10010 CONTINUE
      YFIT=PTWO
      RETURN
C
C     *****   END OF NDER = 0 CASE
C
10020 CONTINUE
         IF (N.GT.1) GO TO 10040
      YFIT=C(1)
C
C     *****  CODING FOR THE CASE  N=1 AND NDER .GT. 0
C
      DO 10030 K=1,NDER
      YP(K)=0.0D0
10030 CONTINUE
      RETURN
C
C     *****  END OF THE CASE  N = 1 AND  NDER .GT. 0
C
10040 CONTINUE
         IF (NDER.LT.N) GO TO 10050
C
C     *****  SET FLAGS FOR NUMBER OF DERIVATIVES AND FOR DERIVATIVES
C            IN EXCESS OF THE DEGREE (N-1) OF THE POLYNOMIAL.
C
      IZERO=1
      NDR=N-1
         GO TO 10060
10050 CONTINUE
      IZERO=0
      NDR=NDER
10060 CONTINUE
      M=NDR+1
      MM=M
C
C     *****  START OF THE CASE NDER .GT. 0  AND N .GT. 1
C     *****  THE POLYNOMIAL AND ITS DERIVATIVES WILL BE EVALUATED AT XX
C
      DO 10070 K=1,NDR
      YP(K)=C(K+1)
10070 CONTINUE
C
C     *****  THE FOLLOWING SECTION OF CODE IS EASIER TO READ IF ONE
C            BREAKS WORK INTO TWO ARRAYS W AND V. THE CODE WOULD THEN
C            READ
C                W(1) = 1.
C                PONE = C(1)
C               *DO   K = 2,N
C               *   V(K-1) =  XX - X(K-1)
C               *   W(K)   =  V(K-1)*W(K-1)
C               *   PTWO   =  PONE + W(K)*C(K)
C               *   PONE   =  PWO
C
C               YFIT = PTWO
C
      WORK(1)=1.0D0
      PONE=C(1)
      DO 10080 K=2,N
      KM1=K-1
      NPKM1=N+K-1
      WORK(NPKM1)=XX-X(KM1)
      WORK(K)=WORK(NPKM1)*WORK(KM1)
      PTWO=PONE+WORK(K)*C(K)
      PONE=PTWO
10080 CONTINUE
      YFIT=PTWO
C
C     ** AT THIS POINT THE POLYNOMIAL HAS BEEN EVALUATED AND INFORMATION
C        FOR THE DERIVATIVE EVALUATIONS HAVE BEEN STORED IN THE ARRAY
C        WORK
         IF (N.EQ.2) GO TO 10110
      IF (M.EQ.N) MM=NDR
C
C     ***** EVALUATE THE DERIVATIVES AT XX
C
C                  ******  DO K=2,MM   (FOR MOST CASES, MM = NDER + 1)
C                  *  ******  DO I=2,N-K+1
C                  *  *       W(I) = V(K-2+I)*W(I-1) + W(I)
C                  *  *       YP(K-1) = YP(K-1) + W(I)*C(K-1+I)
C                  ******  CONTINUE
C
      DO 10090 K=2,MM
      NMKP1=N-K+1
      KM1=K-1
      KM2PN=K-2+N
      DO 10090 I=2,NMKP1
      KM2PNI=KM2PN+I
      IM1=I-1
      KM1PI=KM1+I
      WORK(I)=WORK(KM2PNI)*WORK(IM1)+WORK(I)
      YP(KM1)=YP(KM1)+WORK(I)*C(KM1PI)
10090 CONTINUE
         IF (NDR.EQ.1) GO TO 10110
      FAC=1.0D0
      DO 10100 K=2,NDR
      XK=K
      FAC=XK*FAC
      YP(K)=FAC*YP(K)
10100 CONTINUE
C
C     ***** END OF DERIVATIVE EVALUATIONS
C
10110 CONTINUE
      IF (IZERO.EQ.0) RETURN
C
C     *****  SET EXCESS DERIVATIVES TO ZERO.
C
      DO 10120 K=N,NDER
      YP(K)=0.0D0
10120 CONTINUE
      RETURN
      END
*DECK DPOPT
      SUBROUTINE DPOPT (PRGOPT, MRELAS, NVARS, INFO, CSC, IBASIS, ROPT,
     +   INTOPT, LOPT)
C***BEGIN PROLOGUE  DPOPT
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (SPOPT-S, DPOPT-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/R1MACH/D1MACH/,/E0/D0/
C
C     REVISED 821122-1045
C     REVISED YYMMDD-HHMM
C
C     THIS SUBROUTINE PROCESSES THE OPTION VECTOR, PRGOPT(*),
C     AND VALIDATES ANY MODIFIED DATA.
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   900510  Fixed an error message.  (RWC)
C***END PROLOGUE  DPOPT
      DOUBLE PRECISION ABIG,ASMALL,COSTSC,CSC(*),EPS,ONE,PRGOPT(*),
     * ROPT(07),TOLLS,TUNE,ZERO,D1MACH,TOLABS
      INTEGER IBASIS(*),INTOPT(08)
      LOGICAL CONTIN,USRBAS,SIZEUP,SAVEDT,COLSCP,CSTSCP,MINPRB,
     * STPEDG,LOPT(8)
C
C***FIRST EXECUTABLE STATEMENT  DPOPT
      IOPT=1
      ZERO=0.D0
      ONE=1.D0
      GO TO 30001
20002 CONTINUE
      GO TO 30002
C
20003 LOPT(1)=CONTIN
      LOPT(2)=USRBAS
      LOPT(3)=SIZEUP
      LOPT(4)=SAVEDT
      LOPT(5)=COLSCP
      LOPT(6)=CSTSCP
      LOPT(7)=MINPRB
      LOPT(8)=STPEDG
C
      INTOPT(1)=IDG
      INTOPT(2)=IPAGEF
      INTOPT(3)=ISAVE
      INTOPT(4)=MXITLP
      INTOPT(5)=KPRINT
      INTOPT(6)=ITBRC
      INTOPT(7)=NPP
      INTOPT(8)=LPRG
C
      ROPT(1)=EPS
      ROPT(2)=ASMALL
      ROPT(3)=ABIG
      ROPT(4)=COSTSC
      ROPT(5)=TOLLS
      ROPT(6)=TUNE
      ROPT(7)=TOLABS
      RETURN
C
C
C     PROCEDURE (INITIALIZE PARAMETERS AND PROCESS USER OPTIONS)
30001 CONTIN = .FALSE.
      USRBAS = .FALSE.
      SIZEUP = .FALSE.
      SAVEDT = .FALSE.
      COLSCP = .FALSE.
      CSTSCP = .FALSE.
      MINPRB = .TRUE.
      STPEDG = .TRUE.
C
C     GET THE MACHINE REL. FLOATING POINT ACCURACY VALUE FROM THE
C     LIBRARY SUBPROGRAM, D1MACH( ).
      EPS=D1MACH(4)
      TOLLS=D1MACH(4)
      TUNE=ONE
      TOLABS=ZERO
C
C     DEFINE NOMINAL FILE NUMBERS FOR MATRIX PAGES AND DATA SAVING.
      IPAGEF=1
      ISAVE=2
      ITBRC=10
      MXITLP=3*(NVARS+MRELAS)
      KPRINT=0
      IDG=-4
      NPP=NVARS
      LPRG=0
C
      LAST = 1
      IADBIG=10000
      ICTMAX=1000
      ICTOPT= 0
20004 NEXT=PRGOPT(LAST)
      IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.IADBIG)) GO TO 20006
C
C     THE CHECKS FOR SMALL OR LARGE VALUES OF NEXT ARE TO PREVENT
C     WORKING WITH UNDEFINED DATA.
      NERR=14
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, THE USER OPTION ARRAY HAS UNDEFINED DATA.', NERR,
     +   IOPT)
      INFO=-NERR
      RETURN
20006 IF (.NOT.(NEXT.EQ.1)) GO TO 10001
      GO TO 20005
10001 IF (.NOT.(ICTOPT.GT.ICTMAX)) GO TO 10002
      NERR=15
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, OPTION ARRAY PROCESSING IS CYCLING.', NERR, IOPT)
      INFO=-NERR
      RETURN
10002 CONTINUE
      KEY = PRGOPT(LAST+1)
C
C     IF KEY = 50, THIS IS TO BE A MAXIMIZATION PROBLEM
C     INSTEAD OF A MINIMIZATION PROBLEM.
      IF (.NOT.(KEY.EQ.50)) GO TO 20010
      MINPRB = PRGOPT(LAST+2).EQ.ZERO
      LDS=3
      GO TO 20009
20010 CONTINUE
C
C     IF KEY = 51, THE LEVEL OF OUTPUT IS BEING MODIFIED.
C     KPRINT = 0, NO OUTPUT
C            = 1, SUMMARY OUTPUT
C            = 2, LOTS OF OUTPUT
C            = 3, EVEN MORE OUTPUT
      IF (.NOT.(KEY.EQ.51)) GO TO 20013
      KPRINT=PRGOPT(LAST+2)
      LDS=3
      GO TO 20009
20013 CONTINUE
C
C     IF KEY = 52, REDEFINE THE FORMAT AND PRECISION USED
C     IN THE OUTPUT.
      IF (.NOT.(KEY.EQ.52)) GO TO 20016
      IF (PRGOPT(LAST+2).NE.ZERO) IDG=PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20016 CONTINUE
C
C     IF KEY = 53, THE ALLOTTED SPACE FOR THE SPARSE MATRIX
C     STORAGE AND/OR SPARSE EQUATION SOLVING HAS BEEN CHANGED.
C    (PROCESSED IN DSPLP(). THIS IS TO COMPUTE THE LENGTH OF PRGOPT(*).)
      IF (.NOT.(KEY.EQ.53)) GO TO 20019
      LDS=5
      GO TO 20009
20019 CONTINUE
C
C     IF KEY = 54, REDEFINE THE FILE NUMBER WHERE THE PAGES
C     FOR THE SPARSE MATRIX ARE STORED.
      IF (.NOT.(KEY.EQ.54)) GO TO 20022
      IF(PRGOPT(LAST+2).NE.ZERO) IPAGEF = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20022 CONTINUE
C
C     IF KEY = 55,  A CONTINUATION FOR A PROBLEM MAY BE REQUESTED.
      IF (.NOT.(KEY .EQ. 55)) GO TO 20025
      CONTIN = PRGOPT(LAST+2).NE.ZERO
      LDS=3
      GO TO 20009
20025 CONTINUE
C
C     IF KEY = 56, REDEFINE THE FILE NUMBER WHERE THE SAVED DATA
C     WILL BE STORED.
      IF (.NOT.(KEY.EQ.56)) GO TO 20028
      IF(PRGOPT(LAST+2).NE.ZERO) ISAVE = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20028 CONTINUE
C
C     IF KEY = 57, SAVE DATA (ON EXTERNAL FILE)  AT MXITLP ITERATIONS OR
C     THE OPTIMUM, WHICHEVER COMES FIRST.
      IF (.NOT.(KEY.EQ.57)) GO TO 20031
      SAVEDT=PRGOPT(LAST+2).NE.ZERO
      LDS=3
      GO TO 20009
20031 CONTINUE
C
C     IF KEY = 58,  SEE IF PROBLEM IS TO RUN ONLY A GIVEN
C     NUMBER OF ITERATIONS.
      IF (.NOT.(KEY.EQ.58)) GO TO 20034
      IF (PRGOPT(LAST+2).NE.ZERO) MXITLP = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20034 CONTINUE
C
C     IF KEY = 59,  SEE IF USER PROVIDES THE BASIS INDICES.
      IF (.NOT.(KEY .EQ. 59)) GO TO 20037
      USRBAS = PRGOPT(LAST+2) .NE. ZERO
      IF (.NOT.(USRBAS)) GO TO 20040
      I=1
      N20043=MRELAS
      GO TO 20044
20043 I=I+1
20044 IF ((N20043-I).LT.0) GO TO 20045
      IBASIS(I) = PRGOPT(LAST+2+I)
      GO TO 20043
20045 CONTINUE
20040 CONTINUE
      LDS=MRELAS+3
      GO TO 20009
20037 CONTINUE
C
C     IF KEY = 60,  SEE IF USER HAS PROVIDED SCALING OF COLUMNS.
      IF (.NOT.(KEY .EQ. 60)) GO TO 20047
      COLSCP = PRGOPT(LAST+2).NE.ZERO
      IF (.NOT.(COLSCP)) GO TO 20050
      J=1
      N20053=NVARS
      GO TO 20054
20053 J=J+1
20054 IF ((N20053-J).LT.0) GO TO 20055
      CSC(J)=ABS(PRGOPT(LAST+2+J))
      GO TO 20053
20055 CONTINUE
20050 CONTINUE
      LDS=NVARS+3
      GO TO 20009
20047 CONTINUE
C
C     IF KEY = 61,  SEE IF USER HAS PROVIDED SCALING OF COSTS.
      IF (.NOT.(KEY .EQ. 61)) GO TO 20057
      CSTSCP = PRGOPT(LAST+2).NE.ZERO
      IF (CSTSCP) COSTSC = PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20057 CONTINUE
C
C     IF KEY = 62,  SEE IF SIZE PARAMETERS ARE PROVIDED WITH THE DATA.
C     THESE WILL BE CHECKED AGAINST THE MATRIX ELEMENT SIZES LATER.
      IF (.NOT.(KEY .EQ. 62)) GO TO 20060
      SIZEUP = PRGOPT(LAST+2).NE.ZERO
      IF (.NOT.(SIZEUP)) GO TO 20063
      ASMALL = PRGOPT(LAST+3)
      ABIG = PRGOPT(LAST+4)
20063 CONTINUE
      LDS=5
      GO TO 20009
20060 CONTINUE
C
C     IF KEY = 63, SEE IF TOLERANCE FOR LINEAR SYSTEM RESIDUAL ERROR IS
C     PROVIDED.
      IF (.NOT.(KEY .EQ. 63)) GO TO 20066
      IF (PRGOPT(LAST+2).NE.ZERO) TOLLS = MAX(EPS,PRGOPT(LAST+3))
      LDS=4
      GO TO 20009
20066 CONTINUE
C
C     IF KEY = 64,  SEE IF MINIMUM REDUCED COST OR STEEPEST EDGE
C     DESCENT IS TO BE USED FOR SELECTING VARIABLES TO ENTER BASIS.
      IF (.NOT.(KEY.EQ.64)) GO TO 20069
      STPEDG = PRGOPT(LAST+2).EQ.ZERO
      LDS=3
      GO TO 20009
20069 CONTINUE
C
C     IF KEY = 65, SET THE NUMBER OF ITERATIONS BETWEEN RECALCULATING
C     THE ERROR IN THE PRIMAL SOLUTION.
      IF (.NOT.(KEY.EQ.65)) GO TO 20072
      IF (PRGOPT(LAST+2).NE.ZERO) ITBRC=MAX(ONE,PRGOPT(LAST+3))
      LDS=4
      GO TO 20009
20072 CONTINUE
C
C     IF KEY = 66, SET THE NUMBER OF NEGATIVE REDUCED COSTS TO BE FOUND
C     IN THE PARTIAL PRICING STRATEGY.
      IF (.NOT.(KEY.EQ.66)) GO TO 20075
      IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20078
      NPP=MAX(PRGOPT(LAST+3),ONE)
      NPP=MIN(NPP,NVARS)
20078 CONTINUE
      LDS=4
      GO TO 20009
20075 CONTINUE
C     IF KEY = 67, CHANGE THE TUNING PARAMETER TO APPLY TO THE ERROR
C     ESTIMATES FOR THE PRIMAL AND DUAL SYSTEMS.
      IF (.NOT.(KEY.EQ.67)) GO TO 20081
      IF (.NOT.(PRGOPT(LAST+2).NE.ZERO)) GO TO 20084
      TUNE=ABS(PRGOPT(LAST+3))
20084 CONTINUE
      LDS=4
      GO TO 20009
20081 CONTINUE
      IF (.NOT.(KEY.EQ.68)) GO TO 20087
      LDS=6
      GO TO 20009
20087 CONTINUE
C
C     RESET THE ABSOLUTE TOLERANCE TO BE USED ON THE FEASIBILITY
C     DECISION PROVIDED THE RELATIVE ERROR TEST FAILED.
      IF (.NOT.(KEY.EQ.69)) GO TO 20090
      IF(PRGOPT(LAST+2).NE.ZERO)TOLABS=PRGOPT(LAST+3)
      LDS=4
      GO TO 20009
20090 CONTINUE
      CONTINUE
C
20009 ICTOPT = ICTOPT+1
      LAST = NEXT
      LPRG=LPRG+LDS
      GO TO 20004
20005 CONTINUE
      GO TO 20002
C
C     PROCEDURE (VALIDATE OPTIONALLY MODIFIED DATA)
C
C     IF USER HAS DEFINED THE BASIS, CHECK FOR VALIDITY OF INDICES.
30002 IF (.NOT.(USRBAS)) GO TO 20093
      I=1
      N20096=MRELAS
      GO TO 20097
20096 I=I+1
20097 IF ((N20096-I).LT.0) GO TO 20098
      ITEST=IBASIS(I)
      IF (.NOT.(ITEST.LE.0 .OR.ITEST.GT.(NVARS+MRELAS))) GO TO 20100
      NERR=16
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, AN INDEX OF USER-SUPPLIED BASIS IS OUT OF RANGE.',
     +   NERR, IOPT)
      INFO=-NERR
      RETURN
20100 CONTINUE
      GO TO 20096
20098 CONTINUE
20093 CONTINUE
C
C     IF USER HAS PROVIDED SIZE PARAMETERS, MAKE SURE THEY ARE ORDERED
C     AND POSITIVE.
      IF (.NOT.(SIZEUP)) GO TO 20103
      IF (.NOT.(ASMALL.LE.ZERO .OR. ABIG.LT.ASMALL)) GO TO 20106
      NERR=17
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, SIZE PARAMETERS FOR MATRIX MUST BE SMALLEST AND ' //
     +   'LARGEST MAGNITUDES OF NONZERO ENTRIES.', NERR, IOPT)
      INFO=-NERR
      RETURN
20106 CONTINUE
20103 CONTINUE
C
C     THE NUMBER OF ITERATIONS OF REV. SIMPLEX STEPS MUST BE POSITIVE.
      IF (.NOT.(MXITLP.LE.0)) GO TO 20109
      NERR=18
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, THE NUMBER OF REVISED SIMPLEX STEPS BETWEEN ' //
     +   'CHECK-POINTS MUST BE POSITIVE.', NERR, IOPT)
      INFO=-NERR
      RETURN
20109 CONTINUE
C
C     CHECK THAT SAVE AND PAGE FILE NUMBERS ARE DEFINED AND NOT EQUAL.
      IF (.NOT.(ISAVE.LE.0.OR.IPAGEF.LE.0.OR.(ISAVE.EQ.IPAGEF))) GO TO 2
     *0112
      NERR=19
      CALL XERMSG ('SLATEC', 'DPOPT',
     +   'IN DSPLP, FILE NUMBERS FOR SAVED DATA AND MATRIX PAGES ' //
     +   'MUST BE POSITIVE AND NOT EQUAL.', NERR, IOPT)
      INFO=-NERR
      RETURN
20112 CONTINUE
      CONTINUE
      GO TO 20003
      END
*DECK DPOSL
      SUBROUTINE DPOSL (A, LDA, N, B)
C***BEGIN PROLOGUE  DPOSL
C***PURPOSE  Solve the real symmetric positive definite linear system
C            using the factors computed by DPOCO or DPOFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B
C***TYPE      DOUBLE PRECISION (SPOSL-S, DPOSL-D, CPOSL-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPOSL solves the double precision symmetric positive definite
C     system A * X = B
C     using the factors computed by DPOCO or DPOFA.
C
C     On Entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the output from DPOCO or DPOFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        B       DOUBLE PRECISION(N)
C                the right hand side vector.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal.  Technically this indicates
C        singularity, but it is usually caused by improper subroutine
C        arguments.  It will not occur if the subroutines are called
C        correctly and  INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL DPOCO(A,LDA,N,RCOND,Z,INFO)
C           IF (RCOND is too small .OR. INFO .NE. 0) GO TO ...
C           DO 10 J = 1, P
C              CALL DPOSL(A,LDA,N,C(1,J))
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPOSL
      INTEGER LDA,N
      DOUBLE PRECISION A(LDA,*),B(*)
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB
C
C     SOLVE TRANS(R)*Y = B
C
C***FIRST EXECUTABLE STATEMENT  DPOSL
      DO 10 K = 1, N
         T = DDOT(K-1,A(1,K),1,B(1),1)
         B(K) = (B(K) - T)/A(K,K)
   10 CONTINUE
C
C     SOLVE R*X = Y
C
      DO 20 KB = 1, N
         K = N + 1 - KB
         B(K) = B(K)/A(K,K)
         T = -B(K)
         CALL DAXPY(K-1,T,A(1,K),1,B(1),1)
   20 CONTINUE
      RETURN
      END
*DECK DPPCO
      SUBROUTINE DPPCO (AP, N, RCOND, Z, INFO)
C***BEGIN PROLOGUE  DPPCO
C***PURPOSE  Factor a symmetric positive definite matrix stored in
C            packed form and estimate the condition number of the
C            matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B
C***TYPE      DOUBLE PRECISION (SPPCO-S, DPPCO-D, CPPCO-C)
C***KEYWORDS  CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION, PACKED, POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPPCO factors a double precision symmetric positive definite
C     matrix stored in packed form
C     and estimates the condition of the matrix.
C
C     If  RCOND  is not needed, DPPFA is slightly faster.
C     To solve  A*X = B , follow DPPCO by DPPSL.
C     To compute  INVERSE(A)*C , follow DPPCO by DPPSL.
C     To compute  DETERMINANT(A) , follow DPPCO by DPPDI.
C     To compute  INVERSE(A) , follow DPPCO by DPPDI.
C
C     On Entry
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                the packed form of a symmetric matrix  A .  The
C                columns of the upper triangle are stored sequentially
C                in a one-dimensional array of length  N*(N+1)/2 .
C                See comments below for details.
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        AP      an upper triangular matrix  R , stored in packed
C                form, so that  A = TRANS(R)*R .
C                If  INFO .NE. 0 , the factorization is not complete.
C
C        RCOND   DOUBLE PRECISION
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.  If INFO .NE. 0 , RCOND is unchanged.
C
C        Z       DOUBLE PRECISION(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is singular to working precision, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C                If  INFO .NE. 0 , Z  is unchanged.
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  signals an error condition.  The leading minor
C                     of order  K  is not positive definite.
C
C     Packed Storage
C
C          The following program segment will pack the upper
C          triangle of a symmetric matrix.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K) = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DASUM, DAXPY, DDOT, DPPFA, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPPCO
      INTEGER N,INFO
      DOUBLE PRECISION AP(*),Z(*)
      DOUBLE PRECISION RCOND
C
      DOUBLE PRECISION DDOT,EK,T,WK,WKM
      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM
      INTEGER I,IJ,J,JM1,J1,K,KB,KJ,KK,KP1
C
C     FIND NORM OF A
C
C***FIRST EXECUTABLE STATEMENT  DPPCO
      J1 = 1
      DO 30 J = 1, N
         Z(J) = DASUM(J,AP(J1),1)
         IJ = J1
         J1 = J1 + J
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 20
         DO 10 I = 1, JM1
            Z(I) = Z(I) + ABS(AP(IJ))
            IJ = IJ + 1
   10    CONTINUE
   20    CONTINUE
   30 CONTINUE
      ANORM = 0.0D0
      DO 40 J = 1, N
         ANORM = MAX(ANORM,Z(J))
   40 CONTINUE
C
C     FACTOR
C
      CALL DPPFA(AP,N,INFO)
      IF (INFO .NE. 0) GO TO 180
C
C        RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C        ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
C        THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C        GROWTH IN THE ELEMENTS OF W  WHERE  TRANS(R)*W = E .
C        THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C        SOLVE TRANS(R)*W = E
C
         EK = 1.0D0
         DO 50 J = 1, N
            Z(J) = 0.0D0
   50    CONTINUE
         KK = 0
         DO 110 K = 1, N
            KK = KK + K
            IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K))
            IF (ABS(EK-Z(K)) .LE. AP(KK)) GO TO 60
               S = AP(KK)/ABS(EK-Z(K))
               CALL DSCAL(N,S,Z,1)
               EK = S*EK
   60       CONTINUE
            WK = EK - Z(K)
            WKM = -EK - Z(K)
            S = ABS(WK)
            SM = ABS(WKM)
            WK = WK/AP(KK)
            WKM = WKM/AP(KK)
            KP1 = K + 1
            KJ = KK + K
            IF (KP1 .GT. N) GO TO 100
               DO 70 J = KP1, N
                  SM = SM + ABS(Z(J)+WKM*AP(KJ))
                  Z(J) = Z(J) + WK*AP(KJ)
                  S = S + ABS(Z(J))
                  KJ = KJ + J
   70          CONTINUE
               IF (S .GE. SM) GO TO 90
                  T = WKM - WK
                  WK = WKM
                  KJ = KK + K
                  DO 80 J = KP1, N
                     Z(J) = Z(J) + T*AP(KJ)
                     KJ = KJ + J
   80             CONTINUE
   90          CONTINUE
  100       CONTINUE
            Z(K) = WK
  110    CONTINUE
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
C
C        SOLVE R*Y = W
C
         DO 130 KB = 1, N
            K = N + 1 - KB
            IF (ABS(Z(K)) .LE. AP(KK)) GO TO 120
               S = AP(KK)/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
  120       CONTINUE
            Z(K) = Z(K)/AP(KK)
            KK = KK - K
            T = -Z(K)
            CALL DAXPY(K-1,T,AP(KK+1),1,Z(1),1)
  130    CONTINUE
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
C
         YNORM = 1.0D0
C
C        SOLVE TRANS(R)*V = Y
C
         DO 150 K = 1, N
            Z(K) = Z(K) - DDOT(K-1,AP(KK+1),1,Z(1),1)
            KK = KK + K
            IF (ABS(Z(K)) .LE. AP(KK)) GO TO 140
               S = AP(KK)/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
               YNORM = S*YNORM
  140       CONTINUE
            Z(K) = Z(K)/AP(KK)
  150    CONTINUE
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
         YNORM = S*YNORM
C
C        SOLVE R*Z = V
C
         DO 170 KB = 1, N
            K = N + 1 - KB
            IF (ABS(Z(K)) .LE. AP(KK)) GO TO 160
               S = AP(KK)/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
               YNORM = S*YNORM
  160       CONTINUE
            Z(K) = Z(K)/AP(KK)
            KK = KK - K
            T = -Z(K)
            CALL DAXPY(K-1,T,AP(KK+1),1,Z(1),1)
  170    CONTINUE
C        MAKE ZNORM = 1.0
         S = 1.0D0/DASUM(N,Z,1)
         CALL DSCAL(N,S,Z,1)
         YNORM = S*YNORM
C
         IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
         IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
  180 CONTINUE
      RETURN
      END
*DECK DPPDI
      SUBROUTINE DPPDI (AP, N, DET, JOB)
C***BEGIN PROLOGUE  DPPDI
C***PURPOSE  Compute the determinant and inverse of a real symmetric
C            positive definite matrix using factors from DPPCO or DPPFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B, D3B1B
C***TYPE      DOUBLE PRECISION (SPPDI-S, DPPDI-D, CPPDI-C)
C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX,
C             PACKED, POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPPDI computes the determinant and inverse
C     of a double precision symmetric positive definite matrix
C     using the factors computed by DPPCO or DPPFA .
C
C     On Entry
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                the output from DPPCO or DPPFA.
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        JOB     INTEGER
C                = 11   both determinant and inverse.
C                = 01   inverse only.
C                = 10   determinant only.
C
C     On Return
C
C        AP      the upper triangular half of the inverse .
C                The strict lower triangle is unaltered.
C
C        DET     DOUBLE PRECISION(2)
C                determinant of original matrix if requested.
C                Otherwise not referenced.
C                DETERMINANT = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. DET(1) .LT. 10.0
C                or  DET(1) .EQ. 0.0 .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal and the inverse is requested.
C        It will not occur if the subroutines are called correctly
C        and if DPOCO or DPOFA has set INFO .EQ. 0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPPDI
      INTEGER N,JOB
      DOUBLE PRECISION AP(*)
      DOUBLE PRECISION DET(2)
C
      DOUBLE PRECISION T
      DOUBLE PRECISION S
      INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1
C***FIRST EXECUTABLE STATEMENT  DPPDI
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0D0
         DET(2) = 0.0D0
         S = 10.0D0
         II = 0
         DO 50 I = 1, N
            II = II + I
            DET(1) = AP(II)**2*DET(1)
            IF (DET(1) .EQ. 0.0D0) GO TO 60
   10       IF (DET(1) .GE. 1.0D0) GO TO 20
               DET(1) = S*DET(1)
               DET(2) = DET(2) - 1.0D0
            GO TO 10
   20       CONTINUE
   30       IF (DET(1) .LT. S) GO TO 40
               DET(1) = DET(1)/S
               DET(2) = DET(2) + 1.0D0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(R)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 140
         KK = 0
         DO 100 K = 1, N
            K1 = KK + 1
            KK = KK + K
            AP(KK) = 1.0D0/AP(KK)
            T = -AP(KK)
            CALL DSCAL(K-1,T,AP(K1),1)
            KP1 = K + 1
            J1 = KK + 1
            KJ = KK + K
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = AP(KJ)
               AP(KJ) = 0.0D0
               CALL DAXPY(K,T,AP(K1),1,AP(J1),1)
               J1 = J1 + J
               KJ = KJ + J
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM  INVERSE(R) * TRANS(INVERSE(R))
C
         JJ = 0
         DO 130 J = 1, N
            J1 = JJ + 1
            JJ = JJ + J
            JM1 = J - 1
            K1 = 1
            KJ = J1
            IF (JM1 .LT. 1) GO TO 120
            DO 110 K = 1, JM1
               T = AP(KJ)
               CALL DAXPY(K,T,AP(J1),1,AP(K1),1)
               K1 = K1 + K
               KJ = KJ + 1
  110       CONTINUE
  120       CONTINUE
            T = AP(JJ)
            CALL DSCAL(J,T,AP(J1),1)
  130    CONTINUE
  140 CONTINUE
      RETURN
      END
*DECK DPPERM
      SUBROUTINE DPPERM (DX, N, IPERM, IER)
C***BEGIN PROLOGUE  DPPERM
C***PURPOSE  Rearrange a given array according to a prescribed
C            permutation vector.
C***LIBRARY   SLATEC
C***CATEGORY  N8
C***TYPE      DOUBLE PRECISION (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H)
C***KEYWORDS  PERMUTATION, REARRANGEMENT
C***AUTHOR  McClain, M. A., (NIST)
C           Rhoads, G. S., (NBS)
C***DESCRIPTION
C
C         DPPERM rearranges the data vector DX according to the
C         permutation IPERM: DX(I) <--- DX(IPERM(I)).  IPERM could come
C         from one of the sorting routines IPSORT, SPSORT, DPSORT or
C         HPSORT.
C
C     Description of Parameters
C         DX - input/output -- double precision array of values to be
C                   rearranged.
C         N - input -- number of values in double precision array DX.
C         IPERM - input -- permutation vector.
C         IER - output -- error indicator:
C             =  0  if no error,
C             =  1  if N is zero or negative,
C             =  2  if IPERM is not a valid permutation.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   901004  DATE WRITTEN
C   920507  Modified by M. McClain to revise prologue text.
C***END PROLOGUE  DPPERM
      INTEGER N, IPERM(*), I, IER, INDX, INDX0, ISTRT
      DOUBLE PRECISION DX(*), DTEMP
C***FIRST EXECUTABLE STATEMENT  DPPERM
      IER=0
      IF(N.LT.1)THEN
         IER=1
         CALL XERMSG ('SLATEC', 'DPPERM',
     +    'The number of values to be rearranged, N, is not positive.',
     +    IER, 1)
         RETURN
      ENDIF
C
C     CHECK WHETHER IPERM IS A VALID PERMUTATION
C
      DO 100 I=1,N
         INDX=ABS(IPERM(I))
         IF((INDX.GE.1).AND.(INDX.LE.N))THEN
            IF(IPERM(INDX).GT.0)THEN
               IPERM(INDX)=-IPERM(INDX)
               GOTO 100
            ENDIF
         ENDIF
         IER=2
         CALL XERMSG ('SLATEC', 'DPPERM',
     +    'The permutation vector, IPERM, is not valid.', IER, 1)
         RETURN
  100 CONTINUE
C
C     REARRANGE THE VALUES OF DX
C
C     USE THE IPERM VECTOR AS A FLAG.
C     IF IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION
C
      DO 330 ISTRT = 1 , N
         IF (IPERM(ISTRT) .GT. 0) GOTO 330
         INDX = ISTRT
         INDX0 = INDX
         DTEMP = DX(ISTRT)
  320    CONTINUE
         IF (IPERM(INDX) .GE. 0) GOTO 325
            DX(INDX) = DX(-IPERM(INDX))
            INDX0 = INDX
            IPERM(INDX) = -IPERM(INDX)
            INDX = IPERM(INDX)
            GOTO 320
  325    CONTINUE
         DX(INDX0) = DTEMP
  330 CONTINUE
C
      RETURN
      END
*DECK DPPFA
      SUBROUTINE DPPFA (AP, N, INFO)
C***BEGIN PROLOGUE  DPPFA
C***PURPOSE  Factor a real symmetric positive definite matrix stored in
C            packed form.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B
C***TYPE      DOUBLE PRECISION (SPPFA-S, DPPFA-D, CPPFA-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPPFA factors a double precision symmetric positive definite
C     matrix stored in packed form.
C
C     DPPFA is usually called by DPPCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (time for DPPCO) = (1 + 18/N)*(time for DPPFA) .
C
C     On Entry
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                the packed form of a symmetric matrix  A .  The
C                columns of the upper triangle are stored sequentially
C                in a one-dimensional array of length  N*(N+1)/2 .
C                See comments below for details.
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        AP      an upper triangular matrix  R , stored in packed
C                form, so that  A = TRANS(R)*R .
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  if the leading minor of order  K  is not
C                     positive definite.
C
C
C     Packed Storage
C
C          The following program segment will pack the upper
C          triangle of a symmetric matrix.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K) = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPPFA
      INTEGER N,INFO
      DOUBLE PRECISION AP(*)
C
      DOUBLE PRECISION DDOT,T
      DOUBLE PRECISION S
      INTEGER J,JJ,JM1,K,KJ,KK
C***FIRST EXECUTABLE STATEMENT  DPPFA
         JJ = 0
         DO 30 J = 1, N
            INFO = J
            S = 0.0D0
            JM1 = J - 1
            KJ = JJ
            KK = 0
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               KJ = KJ + 1
               T = AP(KJ) - DDOT(K-1,AP(KK+1),1,AP(JJ+1),1)
               KK = KK + K
               T = T/AP(KK)
               AP(KJ) = T
               S = S + T*T
   10       CONTINUE
   20       CONTINUE
            JJ = JJ + J
            S = AP(JJ) - S
            IF (S .LE. 0.0D0) GO TO 40
            AP(JJ) = SQRT(S)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END
*DECK DPPGQ8
      SUBROUTINE DPPGQ8 (FUN, LDC, C, XI, LXI, KK, ID, A, B, INPPV, ERR,
     +   ANS, IERR)
C***BEGIN PROLOGUE  DPPGQ8
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DPFQAD
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PPGQ8-S, DPPGQ8-D)
C***AUTHOR  Jones, R. E., (SNLA)
C***DESCRIPTION
C
C     Abstract    **** A DOUBLE PRECISION routine ****
C
C        DPPGQ8, a modification of GAUS8, integrates the
C        product of FUN(X) by the ID-th derivative of a spline
C        DPPVAL(LDC,C,XI,LXI,KK,ID,X,INPPV)  between limits A and B.
C
C     Description of Arguments
C
C      Input-- FUN,C,XI,A,B,ERR are DOUBLE PRECISION
C        FUN - Name of external function of one argument which
C              multiplies DPPVAL.
C        LDC - Leading dimension of matrix C, LDC .GE. KK
C        C   - Matrix of Taylor derivatives of dimension at least
C              (K,LXI)
C        XI  - Breakpoint vector of length LXI+1
C        LXI - Number of polynomial pieces
C        KK  - Order of the spline, KK .GE. 1
C        ID  - Order of the spline derivative, 0 .LE. ID .LE. KK-1
C        A   - Lower limit of integral
C        B   - Upper limit of integral (may be less than A)
C        INPPV- Initialization parameter for DPPVAL
C        ERR - Is a requested pseudorelative error tolerance.  Normally
C              pick a value of ABS(ERR) .LT. 1D-3.  ANS will normally
C              have no more error than ABS(ERR) times the integral of
C              the absolute value of FUN(X)*DPPVAL(LDC,C,XI,LXI,KK,ID,X,
C              INPPV).
C
C
C      Output-- ERR,ANS are DOUBLE PRECISION
C        ERR - Will be an estimate of the absolute error in ANS if the
C              input value of ERR was negative.  (ERR Is unchanged if
C              the input value of ERR was nonnegative.)  The estimated
C              error is solely for information to the user and should
C              not be used as a correction to the computed integral.
C        ANS - Computed value of integral
C        IERR- A status code
C            --Normal Codes
C               1 ANS most likely meets requested error tolerance,
C                 or A=B.
C              -1 A and B are too nearly equal to allow normal
C                 integration.  ANS is set to zero.
C            --Abnormal Code
C               2 ANS probably does not meet requested error tolerance.
C
C***SEE ALSO  DPFQAD
C***ROUTINES CALLED  D1MACH, DPPVAL, I1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated the AUTHOR section.  (WRB)
C***END PROLOGUE  DPPGQ8
C
      INTEGER ID,IERR,INPPV,K,KK,KML,KMX,L,LDC,LMN,LMX,LR,LXI,MXL,
     1 NBITS, NIB, NLMN, NLMX
      INTEGER I1MACH
      DOUBLE PRECISION A,AA,AE,ANIB,ANS,AREA,B,BE,C,CC,EE,EF,EPS,ERR,
     1 EST,GL,GLR,GR,HH,SQ2,TOL,VL,VR,W1, W2, W3, W4, XI, X1,
     2 X2, X3, X4, X, H
      DOUBLE PRECISION D1MACH, DPPVAL, G8, FUN
      DIMENSION XI(*), C(LDC,*)
      DIMENSION AA(60), HH(60), LR(60), VL(60), GR(60)
      SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, NLMN, KMX, KML
      DATA X1, X2, X3, X4/
     1     1.83434642495649805D-01,     5.25532409916328986D-01,
     2     7.96666477413626740D-01,     9.60289856497536232D-01/
      DATA W1, W2, W3, W4/
     1     3.62683783378361983D-01,     3.13706645877887287D-01,
     2     2.22381034453374471D-01,     1.01228536290376259D-01/
      DATA SQ2/1.41421356D0/
      DATA NLMN/1/,KMX/5000/,KML/6/
      G8(X,H)=
     1   H*((W1*(FUN(X-X1*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X1*H,INPPV)
     2          +FUN(X+X1*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X1*H,INPPV))
     3      +W2*(FUN(X-X2*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X2*H,INPPV)
     4          +FUN(X+X2*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X2*H,INPPV)))
     5     +(W3*(FUN(X-X3*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X3*H,INPPV)
     6          +FUN(X+X3*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X3*H,INPPV))
     7      +W4*(FUN(X-X4*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X-X4*H,INPPV)
     8          +FUN(X+X4*H)*DPPVAL(LDC,C,XI,LXI,KK,ID,X+X4*H,INPPV))))
C
C     INITIALIZE
C
C***FIRST EXECUTABLE STATEMENT  DPPGQ8
      K = I1MACH(14)
      ANIB = D1MACH(5)*K/0.30102000D0
      NBITS = INT(ANIB)
      NLMX = MIN((NBITS*5)/8,60)
      ANS = 0.0D0
      IERR = 1
      BE = 0.0D0
      IF (A.EQ.B) GO TO 140
      LMX = NLMX
      LMN = NLMN
      IF (B.EQ.0.0D0) GO TO 10
      IF (SIGN(1.0D0,B)*A.LE.0.0D0) GO TO 10
      CC = ABS(1.0D0-A/B)
      IF (CC.GT.0.1D0) GO TO 10
      IF (CC.LE.0.0D0) GO TO 140
      ANIB = 0.5D0 - LOG(CC)/0.69314718D0
      NIB = INT(ANIB)
      LMX = MIN(NLMX,NBITS-NIB-7)
      IF (LMX.LT.1) GO TO 130
      LMN = MIN(LMN,LMX)
   10 TOL = MAX(ABS(ERR),2.0D0**(5-NBITS))/2.0D0
      IF (ERR.EQ.0.0D0) TOL = SQRT(D1MACH(4))
      EPS = TOL
      HH(1) = (B-A)/4.0D0
      AA(1) = A
      LR(1) = 1
      L = 1
      EST = G8(AA(L)+2.0D0*HH(L),2.0D0*HH(L))
      K = 8
      AREA = ABS(EST)
      EF = 0.5D0
      MXL = 0
C
C     COMPUTE REFINED ESTIMATES, ESTIMATE THE ERROR, ETC.
C
   20 GL = G8(AA(L)+HH(L),HH(L))
      GR(L) = G8(AA(L)+3.0D0*HH(L),HH(L))
      K = K + 16
      AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST))
      GLR = GL + GR(L)
      EE = ABS(EST-GLR)*EF
      AE = MAX(EPS*AREA,TOL*ABS(GLR))
      IF (EE-AE) 40, 40, 50
   30 MXL = 1
   40 BE = BE + (EST-GLR)
      IF (LR(L)) 60, 60, 80
C
C     CONSIDER THE LEFT HALF OF THIS LEVEL
C
   50 IF (K.GT.KMX) LMX = KML
      IF (L.GE.LMX) GO TO 30
      L = L + 1
      EPS = EPS*0.5D0
      EF = EF/SQ2
      HH(L) = HH(L-1)*0.5D0
      LR(L) = -1
      AA(L) = AA(L-1)
      EST = GL
      GO TO 20
C
C     PROCEED TO RIGHT HALF AT THIS LEVEL
C
   60 VL(L) = GLR
   70 EST = GR(L-1)
      LR(L) = 1
      AA(L) = AA(L) + 4.0D0*HH(L)
      GO TO 20
C
C     RETURN ONE LEVEL
C
   80 VR = GLR
   90 IF (L.LE.1) GO TO 120
      L = L - 1
      EPS = EPS*2.0D0
      EF = EF*SQ2
      IF (LR(L)) 100, 100, 110
  100 VL(L) = VL(L+1) + VR
      GO TO 70
  110 VR = VL(L+1) + VR
      GO TO 90
C
C      EXIT
C
  120 ANS = VR
      IF ((MXL.EQ.0) .OR. (ABS(BE).LE.2.0D0*TOL*AREA)) GO TO 140
      IERR = 2
      CALL XERMSG ('SLATEC', 'DPPGQ8',
     +   'ANS IS PROBABLY INSUFFICIENTLY ACCURATE.', 3, 1)
      GO TO 140
  130 IERR = -1
      CALL XERMSG ('SLATEC', 'DPPGQ8',
     +   'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL ' //
     +   'INTEGRATION.  ANSWER IS SET TO ZERO, AND IERR=-1.', 1, -1)
  140 CONTINUE
      IF (ERR.LT.0.0D0) ERR = BE
      RETURN
      END
*DECK DPPQAD
      SUBROUTINE DPPQAD (LDC, C, XI, LXI, K, X1, X2, PQUAD)
C***BEGIN PROLOGUE  DPPQAD
C***PURPOSE  Compute the integral on (X1,X2) of a K-th order B-spline
C            using the piecewise polynomial (PP) representation.
C***LIBRARY   SLATEC
C***CATEGORY  H2A2A1, E3, K6
C***TYPE      DOUBLE PRECISION (PPQAD-S, DPPQAD-D)
C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract    **** a double precision routine ****
C         DPPQAD computes the integral on (X1,X2) of a K-th order
C         B-spline using the piecewise polynomial representation
C         (C,XI,LXI,K).  Here the Taylor expansion about the left
C         end point XI(J) of the J-th interval is integrated and
C         evaluated on subintervals of (X1,X2) which are formed by
C         included break points.  Integration outside (XI(1),XI(LXI+1))
C         is permitted.
C
C     Description of Arguments
C         Input      C,XI,X1,X2 are double precision
C           LDC    - leading dimension of matrix C, LDC .GE. K
C           C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI
C           XI(*)  - break point array of length LXI+1
C           LXI    - number of polynomial pieces
C           K      - order of B-spline, K .GE. 1
C           X1,X2  - end points of quadrature interval, normally in
C                    XI(1) .LE. X .LE. XI(LXI+1)
C
C         Output     PQUAD is double precision
C           PQUAD  - integral of the PP representation over (X1,X2)
C
C     Error Conditions
C         Improper input is a fatal error
C
C***REFERENCES  D. E. Amos, Quadrature subroutines for splines and
C                 B-splines, Report SAND79-1825, Sandia Laboratories,
C                 December 1979.
C***ROUTINES CALLED  DINTRV, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPPQAD
C
      INTEGER I, II, IL, ILO, IL1, IL2, IM, K, LDC, LEFT, LXI, MF1, MF2
      DOUBLE PRECISION A,AA,BB,C,DX,FLK,PQUAD,Q,S,SS,TA,TB,X,XI,X1,X2
      DIMENSION XI(*), C(LDC,*), SS(2)
C
C***FIRST EXECUTABLE STATEMENT  DPPQAD
      PQUAD = 0.0D0
      IF(K.LT.1) GO TO 100
      IF(LXI.LT.1) GO TO 105
      IF(LDC.LT.K) GO TO 110
      AA = MIN(X1,X2)
      BB = MAX(X1,X2)
      IF (AA.EQ.BB) RETURN
      ILO = 1
      CALL DINTRV(XI, LXI, AA, ILO, IL1, MF1)
      CALL DINTRV(XI, LXI, BB, ILO, IL2, MF2)
      Q = 0.0D0
      DO 40 LEFT=IL1,IL2
        TA = XI(LEFT)
        A = MAX(AA,TA)
        IF (LEFT.EQ.1) A = AA
        TB = BB
        IF (LEFT.LT.LXI) TB = XI(LEFT+1)
        X = MIN(BB,TB)
        DO 30 II=1,2
          SS(II) = 0.0D0
          DX = X - XI(LEFT)
          IF (DX.EQ.0.0D0) GO TO 20
          S = C(K,LEFT)
          FLK = K
          IM = K - 1
          IL = IM
          DO 10 I=1,IL
            S = S*DX/FLK + C(IM,LEFT)
            IM = IM - 1
            FLK = FLK - 1.0D0
   10     CONTINUE
          SS(II) = S*DX
   20     CONTINUE
          X = A
   30   CONTINUE
        Q = Q + (SS(1)-SS(2))
   40 CONTINUE
      IF (X1.GT.X2) Q = -Q
      PQUAD = Q
      RETURN
C
C
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPQAD', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPQAD', 'LXI DOES NOT SATISFY LXI.GE.1',
     +   2, 1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPQAD', 'LDC DOES NOT SATISFY LDC.GE.K',
     +   2, 1)
      RETURN
      END
*DECK DPPSL
      SUBROUTINE DPPSL (AP, N, B)
C***BEGIN PROLOGUE  DPPSL
C***PURPOSE  Solve the real symmetric positive definite system using
C            the factors computed by DPPCO or DPPFA.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B
C***TYPE      DOUBLE PRECISION (SPPSL-S, DPPSL-D, CPPSL-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, PACKED,
C             POSITIVE DEFINITE, SOLVE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPPSL solves the double precision symmetric positive definite
C     system A * X = B
C     using the factors computed by DPPCO or DPPFA.
C
C     On Entry
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                the output from DPPCO or DPPFA.
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        B       DOUBLE PRECISION(N)
C                the right hand side vector.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal.  Technically this indicates
C        singularity, but it is usually caused by improper subroutine
C        arguments.  It will not occur if the subroutines are called
C        correctly and  INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL DPPCO(AP,N,RCOND,Z,INFO)
C           IF (RCOND is too small .OR. INFO .NE. 0) GO TO ...
C           DO 10 J = 1, P
C              CALL DPPSL(AP,N,C(1,J))
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPPSL
      INTEGER N
      DOUBLE PRECISION AP(*),B(*)
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,KK
C***FIRST EXECUTABLE STATEMENT  DPPSL
      KK = 0
      DO 10 K = 1, N
         T = DDOT(K-1,AP(KK+1),1,B(1),1)
         KK = KK + K
         B(K) = (B(K) - T)/AP(KK)
   10 CONTINUE
      DO 20 KB = 1, N
         K = N + 1 - KB
         B(K) = B(K)/AP(KK)
         KK = KK - K
         T = -B(K)
         CALL DAXPY(K-1,T,AP(KK+1),1,B(1),1)
   20 CONTINUE
      RETURN
      END
*DECK DPPVAL
      DOUBLE PRECISION FUNCTION DPPVAL (LDC, C, XI, LXI, K, IDERIV, X,
     +   INPPV)
C***BEGIN PROLOGUE  DPPVAL
C***PURPOSE  Calculate the value of the IDERIV-th derivative of the
C            B-spline from the PP-representation.
C***LIBRARY   SLATEC
C***CATEGORY  E3, K6
C***TYPE      DOUBLE PRECISION (PPVAL-S, DPPVAL-D)
C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION, SPLINES
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract    **** a double precision routine ****
C         DPPVAL is the PPVALU function of the reference.
C
C         DPPVAL calculates (at X) the value of the IDERIV-th
C         derivative of the B-spline from the PP-representation
C         (C,XI,LXI,K).  The Taylor expansion about XI(J) for X in
C         the interval XI(J) .LE. X .LT. XI(J+1) is evaluated, J=1,LXI.
C         Right limiting values at X=XI(J) are obtained.  DPPVAL will
C         extrapolate beyond XI(1) and XI(LXI+1).
C
C         To obtain left limiting values (left derivatives) at XI(J)
C         replace LXI by J-1 and set X=XI(J),J=2,LXI+1.
C
C     Description of Arguments
C
C         Input      C,XI,X are double precision
C          LDC     - leading dimension of C matrix, LDC .GE. K
C          C       - matrix of dimension at least (K,LXI) containing
C                    right derivatives at break points XI(*).
C          XI      - break point vector of length LXI+1
C          LXI     - number of polynomial pieces
C          K       - order of B-spline, K .GE. 1
C          IDERIV  - order of the derivative, 0 .LE. IDERIV .LE. K-1
C                    IDERIV=0 gives the B-spline value
C          X       - argument, XI(1) .LE. X .LE. XI(LXI+1)
C          INPPV   - an initialization parameter which must be set
C                    to 1 the first time DPPVAL is called.
C
C         Output     DPPVAL is double precision
C          INPPV   - INPPV contains information for efficient process-
C                    ing after the initial call and INPPV must not
C                    be changed by the user.  Distinct splines require
C                    distinct INPPV parameters.
C          DPPVAL  - value of the IDERIV-th derivative at X
C
C     Error Conditions
C         Improper input is a fatal error
C
C***REFERENCES  Carl de Boor, Package for calculating with B-splines,
C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
C                 pp. 441-472.
C***ROUTINES CALLED  DINTRV, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPPVAL
C
      INTEGER I, IDERIV, INPPV, J, K, LDC, LXI, NDUMMY, KK
      DOUBLE PRECISION C, DX, X, XI
      DIMENSION XI(*), C(LDC,*)
C***FIRST EXECUTABLE STATEMENT  DPPVAL
      DPPVAL = 0.0D0
      IF(K.LT.1) GO TO 90
      IF(LDC.LT.K) GO TO 80
      IF(LXI.LT.1) GO TO 85
      IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 95
      I = K - IDERIV
      KK = I
      CALL DINTRV(XI, LXI, X, INPPV, I, NDUMMY)
      DX = X - XI(I)
      J = K
   10 DPPVAL = (DPPVAL/KK)*DX + C(J,I)
      J = J - 1
      KK = KK - 1
      IF (KK.GT.0) GO TO 10
      RETURN
C
C
   80 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPVAL', 'LDC DOES NOT SATISFY LDC.GE.K',
     +   2, 1)
      RETURN
   85 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPVAL', 'LXI DOES NOT SATISFY LXI.GE.1',
     +   2, 1)
      RETURN
   90 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPVAL', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
   95 CONTINUE
      CALL XERMSG ('SLATEC', 'DPPVAL',
     +   'IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K', 2, 1)
      RETURN
      END
*DECK DPRVEC
      DOUBLE PRECISION FUNCTION DPRVEC (M, U, V)
C***BEGIN PROLOGUE  DPRVEC
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DBVSUP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PRVEC-S, DPRVEC-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C  This subroutine computes the inner product of a vector U
C  with the imaginary product or mate vector corresponding to V.
C
C***SEE ALSO  DBVSUP
C***ROUTINES CALLED  DDOT
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DPRVEC
C
      DOUBLE PRECISION DDOT
      INTEGER M, N, NP
      DOUBLE PRECISION U(*), V(*), VP
C***FIRST EXECUTABLE STATEMENT  DPRVEC
      N = M/2
      NP = N + 1
      VP = DDOT(N,U(1),1,V(NP),1)
      DPRVEC = DDOT(N,U(NP),1,V(1),1) - VP
      RETURN
      END
*DECK DPRWPG
      SUBROUTINE DPRWPG (KEY, IPAGE, LPG, SX, IX)
C***BEGIN PROLOGUE  DPRWPG
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PRWPGE-S, DPRWPG-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C     DPRWPG LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME.
C     VIRTUAL MEMORY PAGE READ/WRITE SUBROUTINE.
C
C     DEPENDING ON THE VALUE OF KEY, SUBROUTINE DPRWPG() PERFORMS A PAGE
C     READ OR WRITE OF PAGE IPAGE. THE PAGE HAS LENGTH LPG.
C
C     KEY       IS A FLAG INDICATING WHETHER A PAGE READ OR WRITE IS
C               TO BE PERFORMED.
C               IF KEY = 1 DATA IS READ.
C               IF KEY = 2 DATA IS WRITTEN.
C     IPAGE     IS THE PAGE NUMBER OF THE MATRIX TO BE ACCESSED.
C     LPG       IS THE LENGTH OF THE PAGE OF THE MATRIX TO BE ACCESSED.
C   SX(*),IX(*) IS THE MATRIX TO BE ACCESSED.
C
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWPGE,
C     SANDIA LABS. REPT. SAND78-0785.
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C     REVISED 811130-1000
C     REVISED YYMMDD-HHMM
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DPRWVR, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   900510  Fixed error messages and replaced GOTOs with
C           IF-THEN-ELSE.  (RWC)
C   910403  Updated AUTHOR and DESCRIPTION sections.  (WRB)
C***END PROLOGUE  DPRWPG
      DOUBLE PRECISION SX(*)
      DIMENSION IX(*)
C***FIRST EXECUTABLE STATEMENT  DPRWPG
C
C     CHECK IF IPAGE IS IN RANGE.
C
      IF (IPAGE.LT.1) THEN
         CALL XERMSG ('SLATEC', 'DPRWPG',
     +      'THE VALUE OF IPAGE (PAGE NUMBER) WAS NOT IN THE RANGE' //
     +      '1.LE.IPAGE.LE.MAXPGE.', 55, 1)
      ENDIF
C
C     CHECK IF LPG IS POSITIVE.
C
      IF (LPG.LE.0) THEN
         CALL XERMSG ('SLATEC', 'DPRWPG',
     +      'THE VALUE OF LPG (PAGE LENGTH) WAS NONPOSITIVE.', 55, 1)
      ENDIF
C
C     DECIDE IF WE ARE READING OR WRITING.
C
      IF (KEY.EQ.1) THEN
C
C        CODE TO DO A PAGE READ.
C
         CALL DPRWVR(KEY,IPAGE,LPG,SX,IX)
      ELSE IF (KEY.EQ.2) THEN
C
C        CODE TO DO A PAGE WRITE.
C
         CALL DPRWVR(KEY,IPAGE,LPG,SX,IX)
      ELSE
         CALL XERMSG ('SLATEC', 'DPRWPG',
     +   'THE VALUE OF KEY (READ-WRITE FLAG) WAS NOT 1 OR 2.', 55, 1)
      ENDIF
      RETURN
      END
*DECK DPRWVR
      SUBROUTINE DPRWVR (KEY, IPAGE, LPG, SX, IX)
C***BEGIN PROLOGUE  DPRWVR
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DSPLP
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PRWVIR-S, DPRWVR-D)
C***AUTHOR  Hanson, R. J., (SNLA)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C     DPRWVR LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SPARSE MATRIX
C     STORAGE SCHEME.  THE PAGE STORAGE IS ON RANDOM ACCESS DISK.
C     DPRWVR IS PART OF THE SPARSE LP PACKAGE, DSPLP.
C
C     KEY       IS A FLAG WHICH INDICATES WHETHER A READ OR WRITE
C               OPERATION IS TO BE PERFORMED. A VALUE OF KEY=1 INDICATES
C               A READ. A VALUE OF KEY=2 INDICATES A WRITE.
C     IPAGE     IS THE PAGE OF MATRIX MN WE ARE ACCESSING.
C     LPG       IS THE LENGTH OF THE PAGE.
C   SX(*),IX(*) IS THE MATRIX DATA.
C
C     THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWVIR,
C     SANDIA LABS. REPT. SAND78-0785.
C     MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON
C
C***SEE ALSO  DSPLP
C***ROUTINES CALLED  DREADP, DWRITP, SOPENM
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   891009  Removed unreferenced variables.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910403  Updated AUTHOR and DESCRIPTION sections.  (WRB)
C***END PROLOGUE  DPRWVR
      DIMENSION IX(*)
      DOUBLE PRECISION SX(*),ZERO,ONE
      LOGICAL FIRST
      SAVE ZERO, ONE
      DATA ZERO,ONE/0.D0,1.D0/
C***FIRST EXECUTABLE STATEMENT  DPRWVR
C
C     COMPUTE STARTING ADDRESS OF PAGE.
C
      IPAGEF=SX(3)
      ISTART = IX(3) + 5
C
C     OPEN RANDOM ACCESS FILE NUMBER IPAGEF, IF FIRST PAGE WRITE.
C
      FIRST=SX(4).EQ.ZERO
      IF (.NOT.(FIRST)) GO TO 20002
      CALL SOPENM(IPAGEF,LPG)
      SX(4)=ONE
C
C     PERFORM EITHER A READ OR A WRITE.
C
20002 IADDR = 2*IPAGE - 1
      IF (.NOT.(KEY.EQ.1)) GO TO 20005
      CALL DREADP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR)
      GO TO 20006
20005 IF (.NOT.(KEY.EQ.2)) GO TO 10001
      CALL DWRITP(IPAGEF,IX(ISTART),SX(ISTART),LPG,IADDR)
10001 CONTINUE
20006 RETURN
      END
*DECK DPSI
      DOUBLE PRECISION FUNCTION DPSI (X)
C***BEGIN PROLOGUE  DPSI
C***PURPOSE  Compute the Psi (or Digamma) function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7C
C***TYPE      DOUBLE PRECISION (PSI-S, DPSI-D, CPSI-C)
C***KEYWORDS  DIGAMMA FUNCTION, FNLIB, PSI FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DPSI calculates the double precision Psi (or Digamma) function for
C double precision argument X.  PSI(X) is the logarithmic derivative
C of the Gamma function of X.
C
C Series for PSI        on the interval  0.          to  1.00000E+00
C                                        with weighted error   5.79E-32
C                                         log weighted error  31.24
C                               significant figures required  30.93
C                                    decimal places required  32.05
C
C
C Series for APSI       on the interval  0.          to  1.00000E-02
C                                        with weighted error   7.75E-33
C                                         log weighted error  32.11
C                               significant figures required  28.88
C                                    decimal places required  32.71
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DCOT, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C   920618  Removed space from variable name.  (RWC, WRB)
C***END PROLOGUE  DPSI
      DOUBLE PRECISION X, PSICS(42), APSICS(16), AUX, DXREL, PI, XBIG,
     1  Y, DCOT, DCSEVL, D1MACH
      LOGICAL FIRST
      EXTERNAL DCOT
      SAVE PSICS, APSICS, PI, NTPSI, NTAPSI, XBIG, DXREL, FIRST
      DATA PSICS(  1) / -.3805708083 5217921520 4376776670 39 D-1     /
      DATA PSICS(  2) / +.4914153930 2938712748 2046996542 77 D+0     /
      DATA PSICS(  3) / -.5681574782 1244730242 8920647340 81 D-1     /
      DATA PSICS(  4) / +.8357821225 9143131362 7756507478 62 D-2     /
      DATA PSICS(  5) / -.1333232857 9943425998 0792741723 93 D-2     /
      DATA PSICS(  6) / +.2203132870 6930824892 8723979795 21 D-3     /
      DATA PSICS(  7) / -.3704023817 8456883592 8890869492 29 D-4     /
      DATA PSICS(  8) / +.6283793654 8549898933 6514187176 90 D-5     /
      DATA PSICS(  9) / -.1071263908 5061849855 2835417470 74 D-5     /
      DATA PSICS( 10) / +.1831283946 5484165805 7315898103 78 D-6     /
      DATA PSICS( 11) / -.3135350936 1808509869 0057797968 85 D-7     /
      DATA PSICS( 12) / +.5372808776 2007766260 4719191436 15 D-8     /
      DATA PSICS( 13) / -.9211681415 9784275717 8806326247 30 D-9     /
      DATA PSICS( 14) / +.1579812652 1481822782 2528840328 23 D-9     /
      DATA PSICS( 15) / -.2709864613 2380443065 4405894097 07 D-10    /
      DATA PSICS( 16) / +.4648722859 9096834872 9473195295 49 D-11    /
      DATA PSICS( 17) / -.7975272563 8303689726 5047977727 37 D-12    /
      DATA PSICS( 18) / +.1368272385 7476992249 2510538928 38 D-12    /
      DATA PSICS( 19) / -.2347515606 0658972717 3206779807 19 D-13    /
      DATA PSICS( 20) / +.4027630715 5603541107 9079250062 81 D-14    /
      DATA PSICS( 21) / -.6910251853 1179037846 5474229747 71 D-15    /
      DATA PSICS( 22) / +.1185604713 8863349552 9291395257 68 D-15    /
      DATA PSICS( 23) / -.2034168961 6261559308 1542104842 23 D-16    /
      DATA PSICS( 24) / +.3490074968 6463043850 3742329323 51 D-17    /
      DATA PSICS( 25) / -.5988014693 4976711003 0110813934 93 D-18    /
      DATA PSICS( 26) / +.1027380162 8080588258 3980057122 13 D-18    /
      DATA PSICS( 27) / -.1762704942 4561071368 3592601053 86 D-19    /
      DATA PSICS( 28) / +.3024322801 8156920457 4540354901 33 D-20    /
      DATA PSICS( 29) / -.5188916830 2092313774 2860888746 66 D-21    /
      DATA PSICS( 30) / +.8902773034 5845713905 0058874879 99 D-22    /
      DATA PSICS( 31) / -.1527474289 9426728392 8949719040 00 D-22    /
      DATA PSICS( 32) / +.2620731479 8962083136 3583180799 99 D-23    /
      DATA PSICS( 33) / -.4496464273 8220696772 5983880533 33 D-24    /
      DATA PSICS( 34) / +.7714712959 6345107028 9193642666 66 D-25    /
      DATA PSICS( 35) / -.1323635476 1887702968 1026389333 33 D-25    /
      DATA PSICS( 36) / +.2270999436 2408300091 2773119999 99 D-26    /
      DATA PSICS( 37) / -.3896419021 5374115954 4913919999 99 D-27    /
      DATA PSICS( 38) / +.6685198138 8855302310 6798933333 33 D-28    /
      DATA PSICS( 39) / -.1146998665 4920864872 5299199999 99 D-28    /
      DATA PSICS( 40) / +.1967938588 6541405920 5154133333 33 D-29    /
      DATA PSICS( 41) / -.3376448818 9750979801 9072000000 00 D-30    /
      DATA PSICS( 42) / +.5793070319 3214159246 6773333333 33 D-31    /
      DATA APSICS(  1) / -.8327107910 6929076017 4456932269 D-3        /
      DATA APSICS(  2) / -.4162518421 9273935282 1627121990 D-3        /
      DATA APSICS(  3) / +.1034315609 7874129117 4463193961 D-6        /
      DATA APSICS(  4) / -.1214681841 3590415298 7299556365 D-9        /
      DATA APSICS(  5) / +.3113694319 9835615552 1240278178 D-12       /
      DATA APSICS(  6) / -.1364613371 9317704177 6516100945 D-14       /
      DATA APSICS(  7) / +.9020517513 1541656513 0837974000 D-17       /
      DATA APSICS(  8) / -.8315429974 2159146482 9933635466 D-19       /
      DATA APSICS(  9) / +.1012242570 7390725418 8479482666 D-20       /
      DATA APSICS( 10) / -.1562702494 3562250762 0478933333 D-22       /
      DATA APSICS( 11) / +.2965427168 0890389613 3226666666 D-24       /
      DATA APSICS( 12) / -.6746868867 6570216374 1866666666 D-26       /
      DATA APSICS( 13) / +.1803453116 9718990421 3333333333 D-27       /
      DATA APSICS( 14) / -.5569016182 4598360746 6666666666 D-29       /
      DATA APSICS( 15) / +.1958679226 0773625173 3333333333 D-30       /
      DATA APSICS( 16) / -.7751958925 2333568000 0000000000 D-32       /
      DATA PI / 3.1415926535 8979323846 2643383279 50 D0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DPSI
      IF (FIRST) THEN
         NTPSI = INITDS (PSICS, 42, 0.1*REAL(D1MACH(3)) )
         NTAPSI = INITDS (APSICS, 16, 0.1*REAL(D1MACH(3)) )
C
         XBIG = 1.0D0/SQRT(D1MACH(3))
         DXREL = SQRT(D1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
C
      IF (Y.GT.10.0D0) GO TO 50
C
C DPSI(X) FOR ABS(X) .LE. 2
C
      N = X
      IF (X.LT.0.D0) N = N - 1
      Y = X - N
      N = N - 1
      DPSI = DCSEVL (2.D0*Y-1.D0, PSICS, NTPSI)
      IF (N.EQ.0) RETURN
C
      IF (N.GT.0) GO TO 30
C
      N = -N
      IF (X .EQ. 0.D0) CALL XERMSG ('SLATEC', 'DPSI', 'X IS 0', 2, 2)
      IF (X .LT. 0.D0 .AND. X+N-2 .EQ. 0.D0) CALL XERMSG ('SLATEC',
     +   'DPSI', 'X IS A NEGATIVE INTEGER', 3, 2)
      IF (X .LT. (-0.5D0) .AND. ABS((X-AINT(X-0.5D0))/X) .LT. DXREL)
     +   CALL XERMSG ('SLATEC', 'DPSI',
     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR NEGATIVE INTEGER',
     +   1, 1)
C
      DO 20 I=1,N
        DPSI = DPSI - 1.D0/(X+I-1)
 20   CONTINUE
      RETURN
C
C DPSI(X) FOR X .GE. 2.0 AND X .LE. 10.0
C
 30   DO 40 I=1,N
        DPSI = DPSI + 1.0D0/(Y+I)
 40   CONTINUE
      RETURN
C
C DPSI(X) FOR ABS(X) .GT. 10.0
C
 50   AUX = 0.D0
      IF (Y.LT.XBIG) AUX = DCSEVL (2.D0*(10.D0/Y)**2-1.D0, APSICS,
     1  NTAPSI)
C
      IF (X.LT.0.D0) DPSI = LOG(ABS(X)) - 0.5D0/X + AUX
     1  - PI*DCOT(PI*X)
      IF (X.GT.0.D0) DPSI = LOG(X) - 0.5D0/X + AUX
      RETURN
C
      END
*DECK DPSIFN
      SUBROUTINE DPSIFN (X, N, KODE, M, ANS, NZ, IERR)
C***BEGIN PROLOGUE  DPSIFN
C***PURPOSE  Compute derivatives of the Psi function.
C***LIBRARY   SLATEC
C***CATEGORY  C7C
C***TYPE      DOUBLE PRECISION (PSIFN-S, DPSIFN-D)
C***KEYWORDS  DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION,
C             PSI FUNCTION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C         The following definitions are used in DPSIFN:
C
C      Definition 1
C         PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of
C                  the log GAMMA function.
C      Definition 2
C                     K   K
C         PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X).
C   ___________________________________________________________________
C      DPSIFN computes a sequence of SCALED derivatives of
C      the PSI function; i.e. for fixed X and M it computes
C      the M-member sequence
C
C                    ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X)
C                       for K = N,...,N+M-1
C
C      where PSI(K,X) is as defined above.   For KODE=1, DPSIFN returns
C      the scaled derivatives as described.  KODE=2 is operative only
C      when K=0 and in that case DPSIFN returns -PSI(X) + LN(X).  That
C      is, the logarithmic behavior for large X is removed when KODE=2
C      and K=0.  When sums or differences of PSI functions are computed
C      the logarithmic terms can be combined analytically and computed
C      separately to help retain significant digits.
C
C         Note that CALL DPSIFN(X,0,1,1,ANS) results in
C                   ANS = -PSI(X)
C
C     Input      X is DOUBLE PRECISION
C           X      - Argument, X .gt. 0.0D0
C           N      - First member of the sequence, 0 .le. N .le. 100
C                    N=0 gives ANS(1) = -PSI(X)       for KODE=1
C                                       -PSI(X)+LN(X) for KODE=2
C           KODE   - Selection parameter
C                    KODE=1 returns scaled derivatives of the PSI
C                    function.
C                    KODE=2 returns scaled derivatives of the PSI
C                    function EXCEPT when N=0. In this case,
C                    ANS(1) = -PSI(X) + LN(X) is returned.
C           M      - Number of members of the sequence, M.ge.1
C
C    Output     ANS is DOUBLE PRECISION
C           ANS    - A vector of length at least M whose first M
C                    components contain the sequence of derivatives
C                    scaled according to KODE.
C           NZ     - Underflow flag
C                    NZ.eq.0, A normal return
C                    NZ.ne.0, Underflow, last NZ components of ANS are
C                             set to zero, ANS(M-K+1)=0.0, K=1,...,NZ
C           IERR   - Error flag
C                    IERR=0, A normal return, computation completed
C                    IERR=1, Input error,     no computation
C                    IERR=2, Overflow,        X too small or N+M-1 too
C                            large or both
C                    IERR=3, Error,           N too large. Dimensioned
C                            array TRMR(NMAX) is not large enough for N
C
C         The nominal computational accuracy is the maximum of unit
C         roundoff (=D1MACH(4)) and 1.0D-18 since critical constants
C         are given to only 18 digits.
C
C         PSIFN is the single precision version of DPSIFN.
C
C *Long Description:
C
C         The basic method of evaluation is the asymptotic expansion
C         for large X.ge.XMIN followed by backward recursion on a two
C         term recursion relation
C
C                  W(X+1) + X**(-N-1) = W(X).
C
C         This is supplemented by a series
C
C                  SUM( (X+K)**(-N-1) , K=0,1,2,... )
C
C         which converges rapidly for large N. Both XMIN and the
C         number of terms of the series are calculated from the unit
C         roundoff of the machine environment.
C
C***REFERENCES  Handbook of Mathematical Functions, National Bureau
C                 of Standards Applied Mathematics Series 55, edited
C                 by M. Abramowitz and I. A. Stegun, equations 6.3.5,
C                 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964.
C               D. E. Amos, A portable Fortran subroutine for
C                 derivatives of the Psi function, Algorithm 610, ACM
C                 Transactions on Mathematical Software 9, 4 (1983),
C                 pp. 494-502.
C***ROUTINES CALLED  D1MACH, I1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPSIFN
      INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ,
     *  FN
      INTEGER I1MACH
      DOUBLE PRECISION ANS, ARG, B, DEN, ELIM, EPS, FLN,
     * FX, RLN, RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM,
     * TRMR, TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN,
     * XM, XMIN, XQ, YINT
      DOUBLE PRECISION D1MACH
      DIMENSION B(22), TRM(22), TRMR(100), ANS(*)
      SAVE NMAX, B
      DATA NMAX /100/
C-----------------------------------------------------------------------
C             BERNOULLI NUMBERS
C-----------------------------------------------------------------------
      DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10),
     * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19),
     * B(20), B(21), B(22) /1.00000000000000000D+00,
     * -5.00000000000000000D-01,1.66666666666666667D-01,
     * -3.33333333333333333D-02,2.38095238095238095D-02,
     * -3.33333333333333333D-02,7.57575757575757576D-02,
     * -2.53113553113553114D-01,1.16666666666666667D+00,
     * -7.09215686274509804D+00,5.49711779448621554D+01,
     * -5.29124242424242424D+02,6.19212318840579710D+03,
     * -8.65802531135531136D+04,1.42551716666666667D+06,
     * -2.72982310678160920D+07,6.01580873900642368D+08,
     * -1.51163157670921569D+10,4.29614643061166667D+11,
     * -1.37116552050883328D+13,4.88332318973593167D+14,
     * -1.92965793419400681D+16/
C
C***FIRST EXECUTABLE STATEMENT  DPSIFN
      IERR = 0
      NZ=0
      IF (X.LE.0.0D0) IERR=1
      IF (N.LT.0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (M.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
      MM=M
      NX = MIN(-I1MACH(15),I1MACH(16))
      R1M5 = D1MACH(5)
      R1M4 = D1MACH(4)*0.5D0
      WDTOL = MAX(R1M4,0.5D-18)
C-----------------------------------------------------------------------
C     ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT
C-----------------------------------------------------------------------
      ELIM = 2.302D0*(NX*R1M5-3.0D0)
      XLN = LOG(X)
   41 CONTINUE
      NN = N + MM - 1
      FN = NN
      T = (FN+1)*XLN
C-----------------------------------------------------------------------
C     OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X
C-----------------------------------------------------------------------
      IF (ABS(T).GT.ELIM) GO TO 290
      IF (X.LT.WDTOL) GO TO 260
C-----------------------------------------------------------------------
C     COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1
C-----------------------------------------------------------------------
      RLN = R1M5*I1MACH(14)
      RLN = MIN(RLN,18.06D0)
      FLN = MAX(RLN,3.0D0) - 3.0D0
      YINT = 3.50D0 + 0.40D0*FLN
      SLOPE = 0.21D0 + FLN*(0.0006038D0*FLN+0.008677D0)
      XM = YINT + SLOPE*FN
      MX = INT(XM) + 1
      XMIN = MX
      IF (N.EQ.0) GO TO 50
      XM = -2.302D0*RLN - MIN(0.0D0,XLN)
      ARG = XM/N
      ARG = MIN(0.0D0,ARG)
      EPS = EXP(ARG)
      XM = 1.0D0 - EPS
      IF (ABS(ARG).LT.1.0D-3) XM = -ARG
      FLN = X*XM/EPS
      XM = XMIN - X
      IF (XM.GT.7.0D0 .AND. FLN.LT.15.0D0) GO TO 200
   50 CONTINUE
      XDMY = X
      XDMLN = XLN
      XINC = 0.0D0
      IF (X.GE.XMIN) GO TO 60
      NX = INT(X)
      XINC = XMIN - NX
      XDMY = X + XINC
      XDMLN = LOG(XDMY)
   60 CONTINUE
C-----------------------------------------------------------------------
C     GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
      T = FN*XDMLN
      T1 = XDMLN + XDMLN
      T2 = T + XDMLN
      TK = MAX(ABS(T),ABS(T1),ABS(T2))
      IF (TK.GT.ELIM) GO TO 380
      TSS = EXP(-T)
      TT = 0.5D0/XDMY
      T1 = TT
      TST = WDTOL*TT
      IF (NN.NE.0) T1 = TT + 1.0D0/FN
      RXSQ = 1.0D0/(XDMY*XDMY)
      TA = 0.5D0*RXSQ
      T = (FN+1)*TA
      S = T*B(3)
      IF (ABS(S).LT.TST) GO TO 80
      TK = 2.0D0
      DO 70 K=4,22
        T = T*((TK+FN+1)/(TK+1.0D0))*((TK+FN)/(TK+2.0D0))*RXSQ
        TRM(K) = T*B(K)
        IF (ABS(TRM(K)).LT.TST) GO TO 80
        S = S + TRM(K)
        TK = TK + 2.0D0
   70 CONTINUE
   80 CONTINUE
      S = (S+T1)*TSS
      IF (XINC.EQ.0.0D0) GO TO 100
C-----------------------------------------------------------------------
C     BACKWARD RECUR FROM XDMY TO X
C-----------------------------------------------------------------------
      NX = INT(XINC)
      NP = NN + 1
      IF (NX.GT.NMAX) GO TO 390
      IF (NN.EQ.0) GO TO 160
      XM = XINC - 1.0D0
      FX = X + XM
C-----------------------------------------------------------------------
C     THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL
C-----------------------------------------------------------------------
      DO 90 I=1,NX
        TRMR(I) = FX**(-NP)
        S = S + TRMR(I)
        XM = XM - 1.0D0
        FX = X + XM
   90 CONTINUE
  100 CONTINUE
      ANS(MM) = S
      IF (FN.EQ.0) GO TO 180
C-----------------------------------------------------------------------
C     GENERATE LOWER DERIVATIVES, J.LT.N+MM-1
C-----------------------------------------------------------------------
      IF (MM.EQ.1) RETURN
      DO 150 J=2,MM
        FN = FN - 1
        TSS = TSS*XDMY
        T1 = TT
        IF (FN.NE.0) T1 = TT + 1.0D0/FN
        T = (FN+1)*TA
        S = T*B(3)
        IF (ABS(S).LT.TST) GO TO 120
        TK = 4 + FN
        DO 110 K=4,22
          TRM(K) = TRM(K)*(FN+1)/TK
          IF (ABS(TRM(K)).LT.TST) GO TO 120
          S = S + TRM(K)
          TK = TK + 2.0D0
  110   CONTINUE
  120   CONTINUE
        S = (S+T1)*TSS
        IF (XINC.EQ.0.0D0) GO TO 140
        IF (FN.EQ.0) GO TO 160
        XM = XINC - 1.0D0
        FX = X + XM
        DO 130 I=1,NX
          TRMR(I) = TRMR(I)*FX
          S = S + TRMR(I)
          XM = XM - 1.0D0
          FX = X + XM
  130   CONTINUE
  140   CONTINUE
        MX = MM - J + 1
        ANS(MX) = S
        IF (FN.EQ.0) GO TO 180
  150 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     RECURSION FOR N = 0
C-----------------------------------------------------------------------
  160 CONTINUE
      DO 170 I=1,NX
        S = S + 1.0D0/(X+NX-I)
  170 CONTINUE
  180 CONTINUE
      IF (KODE.EQ.2) GO TO 190
      ANS(1) = S - XDMLN
      RETURN
  190 CONTINUE
      IF (XDMY.EQ.X) RETURN
      XQ = XDMY/X
      ANS(1) = S - LOG(XQ)
      RETURN
C-----------------------------------------------------------------------
C     COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,...
C-----------------------------------------------------------------------
  200 CONTINUE
      NN = INT(FLN) + 1
      NP = N + 1
      T1 = (N+1)*XLN
      T = EXP(-T1)
      S = T
      DEN = X
      DO 210 I=1,NN
        DEN = DEN + 1.0D0
        TRM(I) = DEN**(-NP)
        S = S + TRM(I)
  210 CONTINUE
      ANS(1) = S
      IF (N.NE.0) GO TO 220
      IF (KODE.EQ.2) ANS(1) = S + XLN
  220 CONTINUE
      IF (MM.EQ.1) RETURN
C-----------------------------------------------------------------------
C     GENERATE HIGHER DERIVATIVES, J.GT.N
C-----------------------------------------------------------------------
      TOL = WDTOL/5.0D0
      DO 250 J=2,MM
        T = T/X
        S = T
        TOLS = T*TOL
        DEN = X
        DO 230 I=1,NN
          DEN = DEN + 1.0D0
          TRM(I) = TRM(I)/DEN
          S = S + TRM(I)
          IF (TRM(I).LT.TOLS) GO TO 240
  230   CONTINUE
  240   CONTINUE
        ANS(J) = S
  250 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     SMALL X.LT.UNIT ROUND OFF
C-----------------------------------------------------------------------
  260 CONTINUE
      ANS(1) = X**(-N-1)
      IF (MM.EQ.1) GO TO 280
      K = 1
      DO 270 I=2,MM
        ANS(K+1) = ANS(K)/X
        K = K + 1
  270 CONTINUE
  280 CONTINUE
      IF (N.NE.0) RETURN
      IF (KODE.EQ.2) ANS(1) = ANS(1) + XLN
      RETURN
  290 CONTINUE
      IF (T.GT.0.0D0) GO TO 380
      NZ=0
      IERR=2
      RETURN
  380 CONTINUE
      NZ=NZ+1
      ANS(MM)=0.0D0
      MM=MM-1
      IF (MM.EQ.0) RETURN
      GO TO 41
  390 CONTINUE
      NZ=0
      IERR=3
      RETURN
      END
*DECK DPSIXN
      DOUBLE PRECISION FUNCTION DPSIXN (N)
C***BEGIN PROLOGUE  DPSIXN
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DEXINT
C***LIBRARY   SLATEC
C***TYPE      DOUBLE PRECISION (PSIXN-S, DPSIXN-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     This subroutine returns values of PSI(X)=derivative of log
C     GAMMA(X), X.GT.0.0 at integer arguments. A table look-up is
C     performed for N .LE. 100, and the asymptotic expansion is
C     evaluated for N.GT.100.
C
C***SEE ALSO  DEXINT
C***ROUTINES CALLED  D1MACH
C***REVISION HISTORY  (YYMMDD)
C   800501  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  DPSIXN
C
      INTEGER N, K
      DOUBLE PRECISION AX, B, C, FN, RFN2, TRM, S, WDTOL
      DOUBLE PRECISION D1MACH
      DIMENSION B(6), C(100)
C
C             DPSIXN(N), N = 1,100
      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
     1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
     2     C(19), C(20), C(21), C(22), C(23), C(24)/
     3    -5.77215664901532861D-01,     4.22784335098467139D-01,
     4     9.22784335098467139D-01,     1.25611766843180047D+00,
     5     1.50611766843180047D+00,     1.70611766843180047D+00,
     6     1.87278433509846714D+00,     2.01564147795561000D+00,
     7     2.14064147795561000D+00,     2.25175258906672111D+00,
     8     2.35175258906672111D+00,     2.44266167997581202D+00,
     9     2.52599501330914535D+00,     2.60291809023222227D+00,
     1     2.67434666166079370D+00,     2.74101332832746037D+00,
     2     2.80351332832746037D+00,     2.86233685773922507D+00,
     3     2.91789241329478063D+00,     2.97052399224214905D+00,
     4     3.02052399224214905D+00,     3.06814303986119667D+00,
     5     3.11359758531574212D+00,     3.15707584618530734D+00/
      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
     1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
     2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
     3     3.19874251285197401D+00,     3.23874251285197401D+00,
     4     3.27720405131351247D+00,     3.31424108835054951D+00,
     5     3.34995537406483522D+00,     3.38443813268552488D+00,
     6     3.41777146601885821D+00,     3.45002953053498724D+00,
     7     3.48127953053498724D+00,     3.51158256083801755D+00,
     8     3.54099432554389990D+00,     3.56956575411532847D+00,
     9     3.59734353189310625D+00,     3.62437055892013327D+00,
     1     3.65068634839381748D+00,     3.67632737403484313D+00,
     2     3.70132737403484313D+00,     3.72571761793728215D+00,
     3     3.74952714174680596D+00,     3.77278295570029433D+00,
     4     3.79551022842756706D+00,     3.81773245064978928D+00,
     5     3.83947158108457189D+00,     3.86074817682925274D+00/
      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
     1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
     2     C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/
     3     3.88158151016258607D+00,     3.90198967342789220D+00,
     4     3.92198967342789220D+00,     3.94159751656514710D+00,
     5     3.96082828579591633D+00,     3.97969621032421822D+00,
     6     3.99821472884273674D+00,     4.01639654702455492D+00,
     7     4.03425368988169777D+00,     4.05179754953082058D+00,
     8     4.06903892884116541D+00,     4.08598808138353829D+00,
     9     4.10265474805020496D+00,     4.11904819067315578D+00,
     1     4.13517722293122029D+00,     4.15105023880423617D+00,
     2     4.16667523880423617D+00,     4.18205985418885155D+00,
     3     4.19721136934036670D+00,     4.21213674247469506D+00,
     4     4.22684262482763624D+00,     4.24133537845082464D+00,
     5     4.25562109273653893D+00,     4.26970559977879245D+00/
      DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80),
     1     C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88),
     2     C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/
     3     4.28359448866768134D+00,     4.29729311880466764D+00,
     4     4.31080663231818115D+00,     4.32413996565151449D+00,
     5     4.33729786038835659D+00,     4.35028487337536958D+00,
     6     4.36310538619588240D+00,     4.37576361404398366D+00,
     7     4.38826361404398366D+00,     4.40060929305632934D+00,
     8     4.41280441500754886D+00,     4.42485260777863319D+00,
     9     4.43675736968339510D+00,     4.44852207556574804D+00,
     1     4.46014998254249223D+00,     4.47164423541605544D+00,
     2     4.48300787177969181D+00,     4.49424382683587158D+00,
     3     4.50535493794698269D+00,     4.51634394893599368D+00,
     4     4.52721351415338499D+00,     4.53796620232542800D+00,
     5     4.54860450019776842D+00,     4.55913081598724211D+00/
      DATA C(97), C(98), C(99), C(100)/
     1     4.56954748265390877D+00,     4.57985676100442424D+00,
     2     4.59006084263707730D+00,     4.60016185273808740D+00/
C             COEFFICIENTS OF ASYMPTOTIC EXPANSION
      DATA B(1), B(2), B(3), B(4), B(5), B(6)/
     1     8.33333333333333333D-02,    -8.33333333333333333D-03,
     2     3.96825396825396825D-03,    -4.16666666666666666D-03,
     3     7.57575757575757576D-03,    -2.10927960927960928D-02/
C
C***FIRST EXECUTABLE STATEMENT  DPSIXN
      IF (N.GT.100) GO TO 10
      DPSIXN = C(N)
      RETURN
   10 CONTINUE
      WDTOL = MAX(D1MACH(4),1.0D-18)
      FN = N
      AX = 1.0D0
      S = -0.5D0/FN
      IF (ABS(S).LE.WDTOL) GO TO 30
      RFN2 = 1.0D0/(FN*FN)
      DO 20 K=1,6
        AX = AX*RFN2
        TRM = -B(K)*AX
        IF (ABS(TRM).LT.WDTOL) GO TO 30
        S = S + TRM
   20 CONTINUE
   30 CONTINUE
      DPSIXN = S + LOG(FN)
      RETURN
      END
*DECK DPSORT
      SUBROUTINE DPSORT (DX, N, IPERM, KFLAG, IER)
C***BEGIN PROLOGUE  DPSORT
C***PURPOSE  Return the permutation vector generated by sorting a given
C            array and, optionally, rearrange the elements of the array.
C            The array may be sorted in increasing or decreasing order.
C            A slightly modified quicksort algorithm is used.
C***LIBRARY   SLATEC
C***CATEGORY  N6A1B, N6A2B
C***TYPE      DOUBLE PRECISION (SPSORT-S, DPSORT-D, IPSORT-I, HPSORT-H)
C***KEYWORDS  NUMBER SORTING, PASSIVE SORTING, SINGLETON QUICKSORT, SORT
C***AUTHOR  Jones, R. E., (SNLA)
C           Rhoads, G. S., (NBS)
C           Wisniewski, J. A., (SNLA)
C***DESCRIPTION
C
C   DPSORT returns the permutation vector IPERM generated by sorting
C   the array DX and, optionally, rearranges the values in DX.  DX may
C   be sorted in increasing or decreasing order.  A slightly modified
C   quicksort algorithm is used.
C
C   IPERM is such that DX(IPERM(I)) is the Ith value in the
C   rearrangement of DX.  IPERM may be applied to another array by
C   calling IPPERM, SPPERM, DPPERM or HPPERM.
C
C   The main difference between DPSORT and its active sorting equivalent
C   DSORT is that the data are referenced indirectly rather than
C   directly.  Therefore, DPSORT should require approximately twice as
C   long to execute as DSORT.  However, DPSORT is more general.
C
C   Description of Parameters
C      DX - input/output -- double precision array of values to be
C           sorted.  If ABS(KFLAG) = 2, then the values in DX will be
C           rearranged on output; otherwise, they are unchanged.
C      N  - input -- number of values in array DX to be sorted.
C      IPERM - output -- permutation array such that IPERM(I) is the
C              index of the value in the original order of the
C              DX array that is in the Ith location in the sorted
C              order.
C      KFLAG - input -- control parameter:
C            =  2  means return the permutation vector resulting from
C                  sorting DX in increasing order and sort DX also.
C            =  1  means return the permutation vector resulting from
C                  sorting DX in increasing order and do not sort DX.
C            = -1  means return the permutation vector resulting from
C                  sorting DX in decreasing order and do not sort DX.
C            = -2  means return the permutation vector resulting from
C                  sorting DX in decreasing order and sort DX also.
C      IER - output -- error indicator:
C          =  0  if no error,
C          =  1  if N is zero or negative,
C          =  2  if KFLAG is not 2, 1, -1, or -2.
C***REFERENCES  R. C. Singleton, Algorithm 347, An efficient algorithm
C                 for sorting with minimal storage, Communications of
C                 the ACM, 12, 3 (1969), pp. 185-187.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   761101  DATE WRITTEN
C   761118  Modified by John A. Wisniewski to use the Singleton
C           quicksort algorithm.
C   870423  Modified by Gregory S. Rhoads for passive sorting with the
C           option for the rearrangement of the original data.
C   890619  Double precision version of SPSORT created by D. W. Lozier.
C   890620  Algorithm for rearranging the data vector corrected by R.
C           Boisvert.
C   890622  Prologue upgraded to Version 4.0 style by D. Lozier.
C   891128  Error when KFLAG.LT.0 and N=1 corrected by R. Boisvert.
C   920507  Modified by M. McClain to revise prologue text.
C   920818  Declarations section rebuilt and code restructured to use
C           IF-THEN-ELSE-ENDIF.  (SMR, WRB)
C***END PROLOGUE  DPSORT
C     .. Scalar Arguments ..
      INTEGER IER, KFLAG, N
C     .. Array Arguments ..
      DOUBLE PRECISION DX(*)
      INTEGER IPERM(*)
C     .. Local Scalars ..
      DOUBLE PRECISION R, TEMP
      INTEGER I, IJ, INDX, INDX0, ISTRT, J, K, KK, L, LM, LMT, M, NN
C     .. Local Arrays ..
      INTEGER IL(21), IU(21)
C     .. External Subroutines ..
      EXTERNAL XERMSG
C     .. Intrinsic Functions ..
      INTRINSIC ABS, INT
C***FIRST EXECUTABLE STATEMENT  DPSORT
      IER = 0
      NN = N
      IF (NN .LT. 1) THEN
         IER = 1
         CALL XERMSG ('SLATEC', 'DPSORT',
     +    'The number of values to be sorted, N, is not positive.',
     +    IER, 1)
         RETURN
      ENDIF
C
      KK = ABS(KFLAG)
      IF (KK.NE.1 .AND. KK.NE.2) THEN
         IER = 2
         CALL XERMSG ('SLATEC', 'DPSORT',
     +    'The sort control parameter, KFLAG, is not 2, 1, -1, or -2.',
     +    IER, 1)
         RETURN
      ENDIF
C
C     Initialize permutation vector
C
      DO 10 I=1,NN
         IPERM(I) = I
   10 CONTINUE
C
C     Return if only one value is to be sorted
C
      IF (NN .EQ. 1) RETURN
C
C     Alter array DX to get decreasing order if needed
C
      IF (KFLAG .LE. -1) THEN
         DO 20 I=1,NN
            DX(I) = -DX(I)
   20    CONTINUE
      ENDIF
C
C     Sort DX only
C
      M = 1
      I = 1
      J = NN
      R = .375D0
C
   30 IF (I .EQ. J) GO TO 80
      IF (R .LE. 0.5898437D0) THEN
         R = R+3.90625D-2
      ELSE
         R = R-0.21875D0
      ENDIF
C
   40 K = I
C
C     Select a central element of the array and save it in location L
C
      IJ = I + INT((J-I)*R)
      LM = IPERM(IJ)
C
C     If first element of array is greater than LM, interchange with LM
C
      IF (DX(IPERM(I)) .GT. DX(LM)) THEN
         IPERM(IJ) = IPERM(I)
         IPERM(I) = LM
         LM = IPERM(IJ)
      ENDIF
      L = J
C
C     If last element of array is less than LM, interchange with LM
C
      IF (DX(IPERM(J)) .LT. DX(LM)) THEN
         IPERM(IJ) = IPERM(J)
         IPERM(J) = LM
         LM = IPERM(IJ)
C
C        If first element of array is greater than LM, interchange
C        with LM
C
         IF (DX(IPERM(I)) .GT. DX(LM)) THEN
            IPERM(IJ) = IPERM(I)
            IPERM(I) = LM
            LM = IPERM(IJ)
         ENDIF
      ENDIF
      GO TO 60
   50 LMT = IPERM(L)
      IPERM(L) = IPERM(K)
      IPERM(K) = LMT
C
C     Find an element in the second half of the array which is smaller
C     than LM
C
   60 L = L-1
      IF (DX(IPERM(L)) .GT. DX(LM)) GO TO 60
C
C     Find an element in the first half of the array which is greater
C     than LM
C
   70 K = K+1
      IF (DX(IPERM(K)) .LT. DX(LM)) GO TO 70
C
C     Interchange these elements
C
      IF (K .LE. L) GO TO 50
C
C     Save upper and lower subscripts of the array yet to be sorted
C
      IF (L-I .GT. J-K) THEN
         IL(M) = I
         IU(M) = L
         I = K
         M = M+1
      ELSE
         IL(M) = K
         IU(M) = J
         J = L
         M = M+1
      ENDIF
      GO TO 90
C
C     Begin again on another portion of the unsorted array
C
   80 M = M-1
      IF (M .EQ. 0) GO TO 120
      I = IL(M)
      J = IU(M)
C
   90 IF (J-I .GE. 1) GO TO 40
      IF (I .EQ. 1) GO TO 30
      I = I-1
C
  100 I = I+1
      IF (I .EQ. J) GO TO 80
      LM = IPERM(I+1)
      IF (DX(IPERM(I)) .LE. DX(LM)) GO TO 100
      K = I
C
  110 IPERM(K+1) = IPERM(K)
      K = K-1
      IF (DX(LM) .LT. DX(IPERM(K))) GO TO 110
      IPERM(K+1) = LM
      GO TO 100
C
C     Clean up
C
  120 IF (KFLAG .LE. -1) THEN
         DO 130 I=1,NN
            DX(I) = -DX(I)
  130    CONTINUE
      ENDIF
C
C     Rearrange the values of DX if desired
C
      IF (KK .EQ. 2) THEN
C
C        Use the IPERM vector as a flag.
C        If IPERM(I) < 0, then the I-th value is in correct location
C
         DO 150 ISTRT=1,NN
            IF (IPERM(ISTRT) .GE. 0) THEN
               INDX = ISTRT
               INDX0 = INDX
               TEMP = DX(ISTRT)
  140          IF (IPERM(INDX) .GT. 0) THEN
                  DX(INDX) = DX(IPERM(INDX))
                  INDX0 = INDX
                  IPERM(INDX) = -IPERM(INDX)
                  INDX = ABS(IPERM(INDX))
                  GO TO 140
               ENDIF
               DX(INDX0) = TEMP
            ENDIF
  150    CONTINUE
C
C        Revert the signs of the IPERM values
C
         DO 160 I=1,NN
            IPERM(I) = -IPERM(I)
  160    CONTINUE
C
      ENDIF
C
      RETURN
      END
*DECK DPTSL
      SUBROUTINE DPTSL (N, D, E, B)
C***BEGIN PROLOGUE  DPTSL
C***PURPOSE  Solve a positive definite tridiagonal linear system.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B2A
C***TYPE      DOUBLE PRECISION (SPTSL-S, DPTSL-D, CPTSL-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, POSITIVE DEFINITE, SOLVE,
C             TRIDIAGONAL
C***AUTHOR  Dongarra, J., (ANL)
C***DESCRIPTION
C
C     DPTSL, given a positive definite symmetric tridiagonal matrix and
C     a right hand side, will find the solution.
C
C     On Entry
C
C        N        INTEGER
C                 is the order of the tridiagonal matrix.
C
C        D        DOUBLE PRECISION(N)
C                 is the diagonal of the tridiagonal matrix.
C                 On output D is destroyed.
C
C        E        DOUBLE PRECISION(N)
C                 is the offdiagonal of the tridiagonal matrix.
C                 E(1) through E(N-1) should contain the
C                 offdiagonal.
C
C        B        DOUBLE PRECISION(N)
C                 is the right hand side vector.
C
C     On Return
C
C        B        contains the solution.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890505  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPTSL
      INTEGER N
      DOUBLE PRECISION D(*),E(*),B(*)
C
      INTEGER K,KBM1,KE,KF,KP1,NM1,NM1D2
      DOUBLE PRECISION T1,T2
C
C     CHECK FOR 1 X 1 CASE
C
C***FIRST EXECUTABLE STATEMENT  DPTSL
      IF (N .NE. 1) GO TO 10
         B(1) = B(1)/D(1)
      GO TO 70
   10 CONTINUE
         NM1 = N - 1
         NM1D2 = NM1/2
         IF (N .EQ. 2) GO TO 30
            KBM1 = N - 1
C
C           ZERO TOP HALF OF SUBDIAGONAL AND BOTTOM HALF OF
C           SUPERDIAGONAL
C
            DO 20 K = 1, NM1D2
               T1 = E(K)/D(K)
               D(K+1) = D(K+1) - T1*E(K)
               B(K+1) = B(K+1) - T1*B(K)
               T2 = E(KBM1)/D(KBM1+1)
               D(KBM1) = D(KBM1) - T2*E(KBM1)
               B(KBM1) = B(KBM1) - T2*B(KBM1+1)
               KBM1 = KBM1 - 1
   20       CONTINUE
   30    CONTINUE
         KP1 = NM1D2 + 1
C
C        CLEAN UP FOR POSSIBLE 2 X 2 BLOCK AT CENTER
C
         IF (MOD(N,2) .NE. 0) GO TO 40
            T1 = E(KP1)/D(KP1)
            D(KP1+1) = D(KP1+1) - T1*E(KP1)
            B(KP1+1) = B(KP1+1) - T1*B(KP1)
            KP1 = KP1 + 1
   40    CONTINUE
C
C        BACK SOLVE STARTING AT THE CENTER, GOING TOWARDS THE TOP
C        AND BOTTOM
C
         B(KP1) = B(KP1)/D(KP1)
         IF (N .EQ. 2) GO TO 60
            K = KP1 - 1
            KE = KP1 + NM1D2 - 1
            DO 50 KF = KP1, KE
               B(K) = (B(K) - E(K)*B(K+1))/D(K)
               B(KF+1) = (B(KF+1) - E(KF)*B(KF))/D(KF+1)
               K = K - 1
   50       CONTINUE
   60    CONTINUE
         IF (MOD(N,2) .EQ. 0) B(1) = (B(1) - E(1)*B(2))/D(1)
   70 CONTINUE
      RETURN
      END
