*DECK BAKVEC
      SUBROUTINE BAKVEC (NM, N, T, E, M, Z, IERR)
C***BEGIN PROLOGUE  BAKVEC
C***PURPOSE  Form the eigenvectors of a certain real non-symmetric
C            tridiagonal matrix from a symmetric tridiagonal matrix
C            output from FIGI.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (BAKVEC-S)
C***KEYWORDS  EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine forms the eigenvectors of a NONSYMMETRIC
C     TRIDIAGONAL matrix by back transforming those of the
C     corresponding symmetric matrix determined by  FIGI.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, T and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix T.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        T contains the nonsymmetric matrix.  Its subdiagonal is
C          stored in the last N-1 positions of the first column,
C          its diagonal in the N positions of the second column,
C          and its superdiagonal in the first N-1 positions of
C          the third column.  T(1,1) and T(N,3) are arbitrary.
C          T is a two-dimensional REAL array, dimensioned T(NM,3).
C
C        E contains the subdiagonal elements of the symmetric
C          matrix in its last N-1 positions.  E(1) is arbitrary.
C          E is a one-dimensional REAL array, dimensioned E(N).
C
C        M is the number of eigenvectors to be back transformed.
C          M is an INTEGER variable.
C
C        Z contains the eigenvectors to be back transformed
C          in its first M columns.  Z is a two-dimensional REAL
C          array, dimensioned Z(NM,M).
C
C     On OUTPUT
C
C        T is unaltered.
C
C        E is destroyed.
C
C        Z contains the transformed eigenvectors in its first M columns.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          2*N+I      if E(I) is zero with T(I,1) or T(I-1,3) non-zero.
C                     In this case, the symmetric matrix is not similar
C                     to the original matrix, and the eigenvectors
C                     cannot be found by this program.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BAKVEC
C
      INTEGER I,J,M,N,NM,IERR
      REAL T(NM,3),E(*),Z(NM,*)
C
C***FIRST EXECUTABLE STATEMENT  BAKVEC
      IERR = 0
      IF (M .EQ. 0) GO TO 1001
      E(1) = 1.0E0
      IF (N .EQ. 1) GO TO 1001
C
      DO 100 I = 2, N
         IF (E(I) .NE. 0.0E0) GO TO 80
         IF (T(I,1) .NE. 0.0E0 .OR. T(I-1,3) .NE. 0.0E0) GO TO 1000
         E(I) = 1.0E0
         GO TO 100
   80    E(I) = E(I-1) * E(I) / T(I-1,3)
  100 CONTINUE
C
      DO 120 J = 1, M
C
         DO 120 I = 2, N
         Z(I,J) = Z(I,J) * E(I)
  120 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- EIGENVECTORS CANNOT BE
C                FOUND BY THIS PROGRAM ..........
 1000 IERR = 2 * N + I
 1001 RETURN
      END
*DECK BALANC
      SUBROUTINE BALANC (NM, N, A, LOW, IGH, SCALE)
C***BEGIN PROLOGUE  BALANC
C***PURPOSE  Balance a real general matrix and isolate eigenvalues
C            whenever possible.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1A
C***TYPE      SINGLE PRECISION (BALANC-S, CBAL-C)
C***KEYWORDS  EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure BALANCE,
C     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
C     HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971).
C
C     This subroutine balances a REAL matrix and isolates
C     eigenvalues whenever possible.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, A, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        A contains the input matrix to be balanced.  A is a
C          two-dimensional REAL array, dimensioned A(NM,N).
C
C     On OUTPUT
C
C        A contains the balanced matrix.
C
C        LOW and IGH are two INTEGER variables such that A(I,J)
C          is equal to zero if
C           (1) I is greater than J and
C           (2) J=1,...,LOW-1 or I=IGH+1,...,N.
C
C        SCALE contains information determining the permutations and
C          scaling factors used.  SCALE is a one-dimensional REAL array,
C          dimensioned SCALE(N).
C
C     Suppose that the principal submatrix in rows LOW through IGH
C     has been balanced, that P(J) denotes the index interchanged
C     with J during the permutation step, and that the elements
C     of the diagonal matrix used are denoted by D(I,J).  Then
C        SCALE(J) = P(J),    for J = 1,...,LOW-1
C                 = D(J,J),      J = LOW,...,IGH
C                 = P(J)         J = IGH+1,...,N.
C     The order in which the interchanges are made is N to IGH+1,
C     then 1 TO LOW-1.
C
C     Note that 1 is returned for IGH if IGH is zero formally.
C
C     The ALGOL procedure EXC contained in BALANCE appears in
C     BALANC  in line.  (Note that the ALGOL roles of identifiers
C     K,L have been reversed.)
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BALANC
C
      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
      REAL A(NM,*),SCALE(*)
      REAL C,F,G,R,S,B2,RADIX
      LOGICAL NOCONV
C
C***FIRST EXECUTABLE STATEMENT  BALANC
      RADIX = 16
C
      B2 = RADIX * RADIX
      K = 1
      L = N
      GO TO 100
C     .......... IN-LINE PROCEDURE FOR ROW AND
C                COLUMN EXCHANGE ..........
   20 SCALE(M) = J
      IF (J .EQ. M) GO TO 50
C
      DO 30 I = 1, L
         F = A(I,J)
         A(I,J) = A(I,M)
         A(I,M) = F
   30 CONTINUE
C
      DO 40 I = K, N
         F = A(J,I)
         A(J,I) = A(M,I)
         A(M,I) = F
   40 CONTINUE
C
   50 GO TO (80,130), IEXC
C     .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
C                AND PUSH THEM DOWN ..........
   80 IF (L .EQ. 1) GO TO 280
      L = L - 1
C     .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
  100 DO 120 JJ = 1, L
         J = L + 1 - JJ
C
         DO 110 I = 1, L
            IF (I .EQ. J) GO TO 110
            IF (A(J,I) .NE. 0.0E0) GO TO 120
  110    CONTINUE
C
         M = L
         IEXC = 1
         GO TO 20
  120 CONTINUE
C
      GO TO 140
C     .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
C                AND PUSH THEM LEFT ..........
  130 K = K + 1
C
  140 DO 170 J = K, L
C
         DO 150 I = K, L
            IF (I .EQ. J) GO TO 150
            IF (A(I,J) .NE. 0.0E0) GO TO 170
  150    CONTINUE
C
         M = K
         IEXC = 2
         GO TO 20
  170 CONTINUE
C     .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
      DO 180 I = K, L
  180 SCALE(I) = 1.0E0
C     .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
  190 NOCONV = .FALSE.
C
      DO 270 I = K, L
         C = 0.0E0
         R = 0.0E0
C
         DO 200 J = K, L
            IF (J .EQ. I) GO TO 200
            C = C + ABS(A(J,I))
            R = R + ABS(A(I,J))
  200    CONTINUE
C     .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
         IF (C .EQ. 0.0E0 .OR. R .EQ. 0.0E0) GO TO 270
         G = R / RADIX
         F = 1.0E0
         S = C + R
  210    IF (C .GE. G) GO TO 220
         F = F * RADIX
         C = C * B2
         GO TO 210
  220    G = R * RADIX
  230    IF (C .LT. G) GO TO 240
         F = F / RADIX
         C = C / B2
         GO TO 230
C     .......... NOW BALANCE ..........
  240    IF ((C + R) / F .GE. 0.95E0 * S) GO TO 270
         G = 1.0E0 / F
         SCALE(I) = SCALE(I) * F
         NOCONV = .TRUE.
C
         DO 250 J = K, N
  250    A(I,J) = A(I,J) * G
C
         DO 260 J = 1, L
  260    A(J,I) = A(J,I) * F
C
  270 CONTINUE
C
      IF (NOCONV) GO TO 190
C
  280 LOW = K
      IGH = L
      RETURN
      END
*DECK BALBAK
      SUBROUTINE BALBAK (NM, N, LOW, IGH, SCALE, M, Z)
C***BEGIN PROLOGUE  BALBAK
C***PURPOSE  Form the eigenvectors of a real general matrix from the
C            eigenvectors of matrix output from BALANC.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      SINGLE PRECISION (BALBAK-S, CBABK2-C)
C***KEYWORDS  EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure BALBAK,
C     NUM. MATH. 13, 293-304(1969) by Parlett and Reinsch.
C     HANDBOOK FOR AUTO. COMP., Vol.II-LINEAR ALGEBRA, 315-326(1971).
C
C     This subroutine forms the eigenvectors of a REAL GENERAL
C     matrix by back transforming those of the corresponding
C     balanced matrix determined by  BALANC.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, Z, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the number of components of the vectors in matrix Z.
C          N is an INTEGER variable.  N must be less than or equal
C          to NM.
C
C        LOW and IGH are INTEGER variables determined by  BALANC.
C
C        SCALE contains information determining the permutations and
C          scaling factors used by  BALANC.  SCALE is a one-dimensional
C          REAL array, dimensioned SCALE(N).
C
C        M is the number of columns of Z to be back transformed.
C          M is an INTEGER variable.
C
C        Z contains the real and imaginary parts of the eigen-
C          vectors to be back transformed in its first M columns.
C          Z is a two-dimensional REAL array, dimensioned Z(NM,M).
C
C     On OUTPUT
C
C        Z contains the real and imaginary parts of the
C          transformed eigenvectors in its first M columns.
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BALBAK
C
      INTEGER I,J,K,M,N,II,NM,IGH,LOW
      REAL SCALE(*),Z(NM,*)
      REAL S
C
C***FIRST EXECUTABLE STATEMENT  BALBAK
      IF (M .EQ. 0) GO TO 200
      IF (IGH .EQ. LOW) GO TO 120
C
      DO 110 I = LOW, IGH
         S = SCALE(I)
C     .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
C                IF THE FOREGOING STATEMENT IS REPLACED BY
C                S=1.0E0/SCALE(I). ..........
         DO 100 J = 1, M
  100    Z(I,J) = Z(I,J) * S
C
  110 CONTINUE
C     ......... FOR I=LOW-1 STEP -1 UNTIL 1,
C               IGH+1 STEP 1 UNTIL N DO -- ..........
  120 DO 140 II = 1, N
         I = II
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140
         IF (I .LT. LOW) I = LOW - II
         K = SCALE(I)
         IF (K .EQ. I) GO TO 140
C
         DO 130 J = 1, M
            S = Z(I,J)
            Z(I,J) = Z(K,J)
            Z(K,J) = S
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END
*DECK BANDR
      SUBROUTINE BANDR (NM, N, MB, A, D, E, E2, MATZ, Z)
C***BEGIN PROLOGUE  BANDR
C***PURPOSE  Reduce a real symmetric band matrix to symmetric
C            tridiagonal matrix and, optionally, accumulate
C            orthogonal similarity transformations.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B1
C***TYPE      SINGLE PRECISION (BANDR-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure BANDRD,
C     NUM. MATH. 12, 231-241(1968) by Schwarz.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 273-283(1971).
C
C     This subroutine reduces a REAL SYMMETRIC BAND matrix
C     to a symmetric tridiagonal matrix using and optionally
C     accumulating orthogonal similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        MB is the (half) band width of the matrix, defined as the
C          number of adjacent diagonals, including the principal
C          diagonal, required to specify the non-zero portion of the
C          lower triangle of the matrix.  MB is less than or equal
C          to N.  MB is an INTEGER variable.
C
C        A contains the lower triangle of the real symmetric band
C          matrix.  Its lowest subdiagonal is stored in the last
C          N+1-MB  positions of the first column, its next subdiagonal
C          in the last  N+2-MB  positions of the second column, further
C          subdiagonals similarly, and finally its principal diagonal
C          in the  N  positions of the last column.  Contents of storage
C          locations not part of the matrix are arbitrary.  A is a
C          two-dimensional REAL array, dimensioned A(NM,MB).
C
C        MATZ should be set to .TRUE. if the transformation matrix is
C          to be accumulated, and to .FALSE. otherwise.  MATZ is a
C          LOGICAL variable.
C
C     On OUTPUT
C
C        A has been destroyed, except for its last two columns which
C          contain a copy of the tridiagonal matrix.
C
C        D contains the diagonal elements of the tridiagonal matrix.
C          D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the tridiagonal
C          matrix in its last N-1 positions.  E(1) is set to zero.
C          E is a one-dimensional REAL array, dimensioned E(N).
C
C        E2 contains the squares of the corresponding elements of E.
C          E2 may coincide with E if the squares are not needed.
C          E2 is a one-dimensional REAL array, dimensioned E2(N).
C
C        Z contains the orthogonal transformation matrix produced in
C          the reduction if MATZ has been set to .TRUE.  Otherwise, Z
C          is not referenced.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BANDR
C
      INTEGER J,K,L,N,R,I1,I2,J1,J2,KR,MB,MR,M1,NM,N2,R1,UGL,MAXL,MAXR
      REAL A(NM,*),D(*),E(*),E2(*),Z(NM,*)
      REAL G,U,B1,B2,C2,F1,F2,S2,DMIN,DMINRT
      LOGICAL MATZ
C
C***FIRST EXECUTABLE STATEMENT  BANDR
      DMIN = 2.0D0**(-64)
      DMINRT = 2.0E0**(-32)
C     .......... INITIALIZE DIAGONAL SCALING MATRIX ..........
      DO 30 J = 1, N
   30 D(J) = 1.0E0
C
      IF (.NOT. MATZ) GO TO 60
C
      DO 50 J = 1, N
C
         DO 40 K = 1, N
   40    Z(J,K) = 0.0E0
C
         Z(J,J) = 1.0E0
   50 CONTINUE
C
   60 M1 = MB - 1
      IF (M1 - 1) 900, 800, 70
   70 N2 = N - 2
C
      DO 700 K = 1, N2
         MAXR = MIN(M1,N-K)
C     .......... FOR R=MAXR STEP -1 UNTIL 2 DO -- ..........
         DO 600 R1 = 2, MAXR
            R = MAXR + 2 - R1
            KR = K + R
            MR = MB - R
            G = A(KR,MR)
            A(KR-1,1) = A(KR-1,MR+1)
            UGL = K
C
            DO 500 J = KR, N, M1
               J1 = J - 1
               J2 = J1 - 1
               IF (G .EQ. 0.0E0) GO TO 600
               B1 = A(J1,1) / G
               B2 = B1 * D(J1) / D(J)
               S2 = 1.0E0 / (1.0E0 + B1 * B2)
               IF (S2 .GE. 0.5E0 ) GO TO 450
               B1 = G / A(J1,1)
               B2 = B1 * D(J) / D(J1)
               C2 = 1.0E0 - S2
               D(J1) = C2 * D(J1)
               D(J) = C2 * D(J)
               F1 = 2.0E0 * A(J,M1)
               F2 = B1 * A(J1,MB)
               A(J,M1) = -B2 * (B1 * A(J,M1) - A(J,MB)) - F2 + A(J,M1)
               A(J1,MB) = B2 * (B2 * A(J,MB) + F1) + A(J1,MB)
               A(J,MB) = B1 * (F2 - F1) + A(J,MB)
C
               DO 200 L = UGL, J2
                  I2 = MB - J + L
                  U = A(J1,I2+1) + B2 * A(J,I2)
                  A(J,I2) = -B1 * A(J1,I2+1) + A(J,I2)
                  A(J1,I2+1) = U
  200          CONTINUE
C
               UGL = J
               A(J1,1) = A(J1,1) + B2 * G
               IF (J .EQ. N) GO TO 350
               MAXL = MIN(M1,N-J1)
C
               DO 300 L = 2, MAXL
                  I1 = J1 + L
                  I2 = MB - L
                  U = A(I1,I2) + B2 * A(I1,I2+1)
                  A(I1,I2+1) = -B1 * A(I1,I2) + A(I1,I2+1)
                  A(I1,I2) = U
  300          CONTINUE
C
               I1 = J + M1
               IF (I1 .GT. N) GO TO 350
               G = B2 * A(I1,1)
  350          IF (.NOT. MATZ) GO TO 500
C
               DO 400 L = 1, N
                  U = Z(L,J1) + B2 * Z(L,J)
                  Z(L,J) = -B1 * Z(L,J1) + Z(L,J)
                  Z(L,J1) = U
  400          CONTINUE
C
               GO TO 500
C
  450          U = D(J1)
               D(J1) = S2 * D(J)
               D(J) = S2 * U
               F1 = 2.0E0 * A(J,M1)
               F2 = B1 * A(J,MB)
               U = B1 * (F2 - F1) + A(J1,MB)
               A(J,M1) = B2 * (B1 * A(J,M1) - A(J1,MB)) + F2 - A(J,M1)
               A(J1,MB) = B2 * (B2 * A(J1,MB) + F1) + A(J,MB)
               A(J,MB) = U
C
               DO 460 L = UGL, J2
                  I2 = MB - J + L
                  U = B2 * A(J1,I2+1) + A(J,I2)
                  A(J,I2) = -A(J1,I2+1) + B1 * A(J,I2)
                  A(J1,I2+1) = U
  460          CONTINUE
C
               UGL = J
               A(J1,1) = B2 * A(J1,1) + G
               IF (J .EQ. N) GO TO 480
               MAXL = MIN(M1,N-J1)
C
               DO 470 L = 2, MAXL
                  I1 = J1 + L
                  I2 = MB - L
                  U = B2 * A(I1,I2) + A(I1,I2+1)
                  A(I1,I2+1) = -A(I1,I2) + B1 * A(I1,I2+1)
                  A(I1,I2) = U
  470          CONTINUE
C
               I1 = J + M1
               IF (I1 .GT. N) GO TO 480
               G = A(I1,1)
               A(I1,1) = B1 * A(I1,1)
  480          IF (.NOT. MATZ) GO TO 500
C
               DO 490 L = 1, N
                  U = B2 * Z(L,J1) + Z(L,J)
                  Z(L,J) = -Z(L,J1) + B1 * Z(L,J)
                  Z(L,J1) = U
  490          CONTINUE
C
  500       CONTINUE
C
  600    CONTINUE
C
         IF (MOD(K,64) .NE. 0) GO TO 700
C     .......... RESCALE TO AVOID UNDERFLOW OR OVERFLOW ..........
         DO 650 J = K, N
            IF (D(J) .GE. DMIN) GO TO 650
            MAXL = MAX(1,MB+1-J)
C
            DO 610 L = MAXL, M1
  610       A(J,L) = DMINRT * A(J,L)
C
            IF (J .EQ. N) GO TO 630
            MAXL = MIN(M1,N-J)
C
            DO 620 L = 1, MAXL
               I1 = J + L
               I2 = MB - L
               A(I1,I2) = DMINRT * A(I1,I2)
  620       CONTINUE
C
  630       IF (.NOT. MATZ) GO TO 645
C
            DO 640 L = 1, N
  640       Z(L,J) = DMINRT * Z(L,J)
C
  645       A(J,MB) = DMIN * A(J,MB)
            D(J) = D(J) / DMIN
  650    CONTINUE
C
  700 CONTINUE
C     .......... FORM SQUARE ROOT OF SCALING MATRIX ..........
  800 DO 810 J = 2, N
  810 E(J) = SQRT(D(J))
C
      IF (.NOT. MATZ) GO TO 840
C
      DO 830 J = 1, N
C
         DO 820 K = 2, N
  820    Z(J,K) = E(K) * Z(J,K)
C
  830 CONTINUE
C
  840 U = 1.0E0
C
      DO 850 J = 2, N
         A(J,M1) = U * E(J) * A(J,M1)
         U = E(J)
         E2(J) = A(J,M1) ** 2
         A(J,MB) = D(J) * A(J,MB)
         D(J) = A(J,MB)
         E(J) = A(J,M1)
  850 CONTINUE
C
      D(1) = A(1,MB)
      E(1) = 0.0E0
      E2(1) = 0.0E0
      GO TO 1001
C
  900 DO 950 J = 1, N
         D(J) = A(J,MB)
         E(J) = 0.0E0
         E2(J) = 0.0E0
  950 CONTINUE
C
 1001 RETURN
      END
*DECK BANDV
      SUBROUTINE BANDV (NM, N, MBW, A, E21, M, W, Z, IERR, NV, RV, RV6)
C***BEGIN PROLOGUE  BANDV
C***PURPOSE  Form the eigenvectors of a real symmetric band matrix
C            associated with a set of ordered approximate eigenvalues
C            by inverse iteration.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C3
C***TYPE      SINGLE PRECISION (BANDV-S)
C***KEYWORDS  EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine finds those eigenvectors of a REAL SYMMETRIC
C     BAND matrix corresponding to specified eigenvalues, using inverse
C     iteration.  The subroutine may also be used to solve systems
C     of linear equations with a symmetric or non-symmetric band
C     coefficient matrix.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        MBW is the number of columns of the array A used to store the
C          band matrix.  If the matrix is symmetric, MBW is its (half)
C          band width, denoted MB and defined as the number of adjacent
C          diagonals, including the principal diagonal, required to
C          specify the non-zero portion of the lower triangle of the
C          matrix.  If the subroutine is being used to solve systems
C          of linear equations and the coefficient matrix is not
C          symmetric, it must however have the same number of adjacent
C          diagonals above the main diagonal as below, and in this
C          case, MBW=2*MB-1.  MBW is an INTEGER variable.  MB must not
C          be greater than N.
C
C        A contains the lower triangle of the symmetric band input
C          matrix stored as an N by MB array.  Its lowest subdiagonal
C          is stored in the last N+1-MB positions of the first column,
C          its next subdiagonal in the last N+2-MB positions of the
C          second column, further subdiagonals similarly, and finally
C          its principal diagonal in the N positions of column MB.
C          If the subroutine is being used to solve systems of linear
C          equations and the coefficient matrix is not symmetric, A is
C          N by 2*MB-1 instead with lower triangle as above and with
C          its first superdiagonal stored in the first N-1 positions of
C          column MB+1, its second superdiagonal in the first N-2
C          positions of column MB+2, further superdiagonals similarly,
C          and finally its highest superdiagonal in the first N+1-MB
C          positions of the last column.  Contents of storage locations
C          not part of the matrix are arbitrary.  A is a two-dimensional
C          REAL array, dimensioned A(NM,MBW).
C
C        E21 specifies the ordering of the eigenvalues and contains
C            0.0E0 if the eigenvalues are in ascending order, or
C            2.0E0 if the eigenvalues are in descending order.
C          If the subroutine is being used to solve systems of linear
C          equations, E21 should be set to 1.0E0 if the coefficient
C          matrix is symmetric and to -1.0E0 if not.  E21 is a REAL
C          variable.
C
C        M is the number of specified eigenvalues or the number of
C          systems of linear equations.  M is an INTEGER variable.
C
C        W contains the M eigenvalues in ascending or descending order.
C          If the subroutine is being used to solve systems of linear
C          equations (A-W(J)*I)*X(J)=B(J), where I is the identity
C          matrix, W(J) should be set accordingly, for J=1,2,...,M.
C          W is a one-dimensional REAL array, dimensioned W(M).
C
C        Z contains the constant matrix columns (B(J),J=1,2,...,M), if
C          the subroutine is used to solve systems of linear equations.
C          Z is a two-dimensional REAL array, dimensioned Z(NM,M).
C
C        NV must be set to the dimension of the array parameter RV
C          as declared in the calling program dimension statement.
C          NV is an INTEGER variable.
C
C     On OUTPUT
C
C        A and W are unaltered.
C
C        Z contains the associated set of orthogonal eigenvectors.
C          Any vector which fails to converge is set to zero.  If the
C          subroutine is used to solve systems of linear equations,
C          Z contains the solution matrix columns (X(J),J=1,2,...,M).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          -J         if the eigenvector corresponding to the J-th
C                     eigenvalue fails to converge, or if the J-th
C                     system of linear equations is nearly singular.
C
C        RV and RV6 are temporary storage arrays.  If the subroutine
C          is being used to solve systems of linear equations, the
C          determinant (up to sign) of A-W(M)*I is available, upon
C          return, as the product of the first N elements of RV.
C          RV and RV6 are one-dimensional REAL arrays.  Note that RV
C          is dimensioned RV(NV), where NV must be at least N*(2*MB-1).
C          RV6 is dimensioned RV6(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BANDV
C
      INTEGER I,J,K,M,N,R,II,IJ,JJ,KJ,MB,M1,NM,NV,IJ1,ITS,KJ1,MBW,M21
      INTEGER IERR,MAXJ,MAXK,GROUP
      REAL A(NM,*),W(*),Z(NM,*),RV(*),RV6(*)
      REAL U,V,UK,XU,X0,X1,E21,EPS2,EPS3,EPS4,NORM,ORDER,S
C
C***FIRST EXECUTABLE STATEMENT  BANDV
      IERR = 0
      IF (M .EQ. 0) GO TO 1001
      MB = MBW
      IF (E21 .LT. 0.0E0) MB = (MBW + 1) / 2
      M1 = MB - 1
      M21 = M1 + MB
      ORDER = 1.0E0 - ABS(E21)
C     .......... FIND VECTORS BY INVERSE ITERATION ..........
      DO 920 R = 1, M
         ITS = 1
         X1 = W(R)
         IF (R .NE. 1) GO TO 100
C     .......... COMPUTE NORM OF MATRIX ..........
         NORM = 0.0E0
C
         DO 60 J = 1, MB
            JJ = MB + 1 - J
            KJ = JJ + M1
            IJ = 1
            S = 0.0E0
C
            DO 40 I = JJ, N
               S = S + ABS(A(I,J))
               IF (E21 .GE. 0.0E0) GO TO 40
               S = S + ABS(A(IJ,KJ))
               IJ = IJ + 1
   40       CONTINUE
C
            NORM = MAX(NORM,S)
   60    CONTINUE
C
         IF (E21 .LT. 0.0E0) NORM = 0.5E0 * NORM
C     .......... EPS2 IS THE CRITERION FOR GROUPING,
C                EPS3 REPLACES ZERO PIVOTS AND EQUAL
C                ROOTS ARE MODIFIED BY EPS3,
C                EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ..........
         IF (NORM .EQ. 0.0E0) NORM = 1.0E0
         EPS2 = 1.0E-3 * NORM * ABS(ORDER)
         EPS3 = NORM
   70    EPS3 = 0.5E0*EPS3
         IF (NORM + EPS3 .GT. NORM) GO TO 70
         UK = SQRT(REAL(N))
         EPS3 = UK * EPS3
         EPS4 = UK * EPS3
   80    GROUP = 0
         GO TO 120
C     .......... LOOK FOR CLOSE OR COINCIDENT ROOTS ..........
  100    IF (ABS(X1-X0) .GE. EPS2) GO TO 80
         GROUP = GROUP + 1
         IF (ORDER * (X1 - X0) .LE. 0.0E0) X1 = X0 + ORDER * EPS3
C     .......... EXPAND MATRIX, SUBTRACT EIGENVALUE,
C                AND INITIALIZE VECTOR ..........
  120    DO 200 I = 1, N
            IJ = I + MIN(0,I-M1) * N
            KJ = IJ + MB * N
            IJ1 = KJ + M1 * N
            IF (M1 .EQ. 0) GO TO 180
C
            DO 150 J = 1, M1
               IF (IJ .GT. M1) GO TO 125
               IF (IJ .GT. 0) GO TO 130
               RV(IJ1) = 0.0E0
               IJ1 = IJ1 + N
               GO TO 130
  125          RV(IJ) = A(I,J)
  130          IJ = IJ + N
               II = I + J
               IF (II .GT. N) GO TO 150
               JJ = MB - J
               IF (E21 .GE. 0.0E0) GO TO 140
               II = I
               JJ = MB + J
  140          RV(KJ) = A(II,JJ)
               KJ = KJ + N
  150       CONTINUE
C
  180       RV(IJ) = A(I,MB) - X1
            RV6(I) = EPS4
            IF (ORDER .EQ. 0.0E0) RV6(I) = Z(I,R)
  200    CONTINUE
C
         IF (M1 .EQ. 0) GO TO 600
C     .......... ELIMINATION WITH INTERCHANGES ..........
         DO 580 I = 1, N
            II = I + 1
            MAXK = MIN(I+M1-1,N)
            MAXJ = MIN(N-I,M21-2) * N
C
            DO 360 K = I, MAXK
               KJ1 = K
               J = KJ1 + N
               JJ = J + MAXJ
C
               DO 340 KJ = J, JJ, N
                  RV(KJ1) = RV(KJ)
                  KJ1 = KJ
  340          CONTINUE
C
               RV(KJ1) = 0.0E0
  360       CONTINUE
C
            IF (I .EQ. N) GO TO 580
            U = 0.0E0
            MAXK = MIN(I+M1,N)
            MAXJ = MIN(N-II,M21-2) * N
C
            DO 450 J = I, MAXK
               IF (ABS(RV(J)) .LT. ABS(U)) GO TO 450
               U = RV(J)
               K = J
  450       CONTINUE
C
            J = I + N
            JJ = J + MAXJ
            IF (K .EQ. I) GO TO 520
            KJ = K
C
            DO 500 IJ = I, JJ, N
               V = RV(IJ)
               RV(IJ) = RV(KJ)
               RV(KJ) = V
               KJ = KJ + N
  500       CONTINUE
C
            IF (ORDER .NE. 0.0E0) GO TO 520
            V = RV6(I)
            RV6(I) = RV6(K)
            RV6(K) = V
  520       IF (U .EQ. 0.0E0) GO TO 580
C
            DO 560 K = II, MAXK
               V = RV(K) / U
               KJ = K
C
               DO 540 IJ = J, JJ, N
                  KJ = KJ + N
                  RV(KJ) = RV(KJ) - V * RV(IJ)
  540          CONTINUE
C
               IF (ORDER .EQ. 0.0E0) RV6(K) = RV6(K) - V * RV6(I)
  560       CONTINUE
C
  580    CONTINUE
C     .......... BACK SUBSTITUTION
C                FOR I=N STEP -1 UNTIL 1 DO -- ..........
  600    DO 630 II = 1, N
            I = N + 1 - II
            MAXJ = MIN(II,M21)
            IF (MAXJ .EQ. 1) GO TO 620
            IJ1 = I
            J = IJ1 + N
            JJ = J + (MAXJ - 2) * N
C
            DO 610 IJ = J, JJ, N
               IJ1 = IJ1 + 1
               RV6(I) = RV6(I) - RV(IJ) * RV6(IJ1)
  610       CONTINUE
C
  620       V = RV(I)
            IF (ABS(V) .GE. EPS3) GO TO 625
C     .......... SET ERROR -- NEARLY SINGULAR LINEAR SYSTEM ..........
            IF (ORDER .EQ. 0.0E0) IERR = -R
            V = SIGN(EPS3,V)
  625       RV6(I) = RV6(I) / V
  630    CONTINUE
C
         XU = 1.0E0
         IF (ORDER .EQ. 0.0E0) GO TO 870
C     .......... ORTHOGONALIZE WITH RESPECT TO PREVIOUS
C                MEMBERS OF GROUP ..........
         IF (GROUP .EQ. 0) GO TO 700
C
         DO 680 JJ = 1, GROUP
            J = R - GROUP - 1 + JJ
            XU = 0.0E0
C
            DO 640 I = 1, N
  640       XU = XU + RV6(I) * Z(I,J)
C
            DO 660 I = 1, N
  660       RV6(I) = RV6(I) - XU * Z(I,J)
C
  680    CONTINUE
C
  700    NORM = 0.0E0
C
         DO 720 I = 1, N
  720    NORM = NORM + ABS(RV6(I))
C
         IF (NORM .GE. 0.1E0) GO TO 840
C     .......... IN-LINE PROCEDURE FOR CHOOSING
C                A NEW STARTING VECTOR ..........
         IF (ITS .GE. N) GO TO 830
         ITS = ITS + 1
         XU = EPS4 / (UK + 1.0E0)
         RV6(1) = EPS4
C
         DO 760 I = 2, N
  760    RV6(I) = XU
C
         RV6(ITS) = RV6(ITS) - EPS4 * UK
         GO TO 600
C     .......... SET ERROR -- NON-CONVERGED EIGENVECTOR ..........
  830    IERR = -R
         XU = 0.0E0
         GO TO 870
C     .......... NORMALIZE SO THAT SUM OF SQUARES IS
C                1 AND EXPAND TO FULL ORDER ..........
  840    U = 0.0E0
C
         DO 860 I = 1, N
  860    U = U + RV6(I)**2
C
         XU = 1.0E0 / SQRT(U)
C
  870    DO 900 I = 1, N
  900    Z(I,R) = RV6(I) * XU
C
         X0 = X1
  920 CONTINUE
C
 1001 RETURN
      END
*DECK BCRH
      FUNCTION BCRH (XLL, XRR, IZ, C, A, BH, F, SGN)
C***BEGIN PROLOGUE  BCRH
C***SUBSIDIARY
C***PURPOSE  Subsidiary to CBLKTR
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BCRH-S, BSRH-S)
C***AUTHOR  (UNKNOWN)
C***SEE ALSO  CBLKTR
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    CCBLK
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  BCRH
      DIMENSION       A(*)       ,C(*)       ,BH(*)
      COMMON /CCBLK/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C***FIRST EXECUTABLE STATEMENT  BCRH
      XL = XLL
      XR = XRR
      DX = .5*ABS(XR-XL)
  101 X = .5*(XL+XR)
      IF (SGN*F(X,IZ,C,A,BH)) 103,105,102
  102 XR = X
      GO TO 104
  103 XL = X
  104 DX = .5*DX
      IF (DX-CNV) 105,105,101
  105 BCRH = .5*(XL+XR)
      RETURN
      END
*DECK BDIFF
      SUBROUTINE BDIFF (L, V)
C***BEGIN PROLOGUE  BDIFF
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BSKIN
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BDIFF-S, DBDIFF-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     BDIFF computes the sum of B(L,K)*V(K)*(-1)**K where B(L,K)
C     are the binomial coefficients.  Truncated sums are computed by
C     setting last part of the V vector to zero. On return, the binomial
C     sum is in V(L).
C
C***SEE ALSO  BSKIN
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  BDIFF
      INTEGER I, J, K, L
      REAL V
      DIMENSION V(*)
C***FIRST EXECUTABLE STATEMENT  BDIFF
      IF (L.EQ.1) RETURN
      DO 20 J=2,L
        K = L
        DO 10 I=J,L
          V(K) = V(K-1) - V(K)
          K = K - 1
   10   CONTINUE
   20 CONTINUE
      RETURN
      END
*DECK BESI
      SUBROUTINE BESI (X, ALPHA, KODE, N, Y, NZ)
C***BEGIN PROLOGUE  BESI
C***PURPOSE  Compute an N member sequence of I Bessel functions
C            I/SUB(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions
C            EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative
C            ALPHA and X.
C***LIBRARY   SLATEC
C***CATEGORY  C10B3
C***TYPE      SINGLE PRECISION (BESI-S, DBESI-D)
C***KEYWORDS  I BESSEL FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C           Daniel, S. L., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESI computes an N member sequence of I Bessel functions
C         I/sub(ALPHA+K-1)/(X), K=1,...,N or scaled Bessel functions
C         EXP(-X)*I/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA
C         and X.  A combination of the power series, the asymptotic
C         expansion for X to infinity, and the uniform asymptotic
C         expansion for NU to infinity are applied over subdivisions of
C         the (NU,X) plane.  For values not covered by one of these
C         formulae, the order is incremented by an integer so that one
C         of these formulae apply.  Backward recursion is used to reduce
C         orders by integer values.  The asymptotic expansion for X to
C         infinity is used only when the entire sequence (specifically
C         the last member) lies within the region covered by the
C         expansion.  Leading terms of these expansions are used to test
C         for over or underflow where appropriate.  If a sequence is
C         requested and the last member would underflow, the result is
C         set to zero and the next lower order tried, etc., until a
C         member comes on scale or all are set to zero.  An overflow
C         cannot occur with scaling.
C
C     Description of Arguments
C
C         Input
C           X      - X .GE. 0.0E0
C           ALPHA  - order of first member of the sequence,
C                    ALPHA .GE. 0.0E0
C           KODE   - a parameter to indicate the scaling option
C                    KODE=1 returns
C                           Y(K)=        I/sub(ALPHA+K-1)/(X),
C                                K=1,...,N
C                    KODE=2 returns
C                           Y(K)=EXP(-X)*I/sub(ALPHA+K-1)/(X),
C                                K=1,...,N
C           N      - number of members in the sequence, N .GE. 1
C
C         Output
C           Y      - a vector whose first N components contain
C                    values for I/sub(ALPHA+K-1)/(X) or scaled
C                    values for EXP(-X)*I/sub(ALPHA+K-1)/(X),
C                    K=1,...,N depending on KODE
C           NZ     - number of components of Y set to zero due to
C                    underflow,
C                    NZ=0   , normal return, computation completed
C                    NZ .NE. 0, last NZ components of Y set to zero,
C                             Y(K)=0.0E0, K=N-NZ+1,...,N.
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow with KODE=1 - a fatal error
C         Underflow - a non-fatal error (NZ .NE. 0)
C
C***REFERENCES  D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600
C                 subroutines IBESS and JBESS for Bessel functions
C                 I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM
C                 Transactions on Mathematical Software 3, (1977),
C                 pp. 76-92.
C               F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C***ROUTINES CALLED  ALNGAM, ASYIK, I1MACH, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  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  BESI
C
      INTEGER I, IALP, IN, INLIM, IS, I1, K, KK, KM, KODE, KT,
     1 N, NN, NS, NZ
      INTEGER I1MACH
      REAL AIN, AK, AKM, ALPHA, ANS, AP, ARG, ATOL, TOLLN, DFN,
     1 DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA,
     2 RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL,
     3 TRX, T2, X, XO2, XO2L, Y, Z
      REAL R1MACH, ALNGAM
      DIMENSION Y(*), TEMP(3)
      SAVE RTTPI, INLIM
      DATA RTTPI           / 3.98942280401433E-01/
      DATA INLIM           /          80         /
C***FIRST EXECUTABLE STATEMENT  BESI
      NZ = 0
      KT = 1
C     I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE
C     I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE
      RA = R1MACH(3)
      TOL = MAX(RA,1.0E-15)
      I1 = -I1MACH(12)
      GLN = R1MACH(5)
      ELIM = 2.303E0*(I1*GLN-3.0E0)
C     TOLLN = -LN(TOL)
      I1 = I1MACH(11)+1
      TOLLN = 2.303E0*GLN*I1
      TOLLN = MIN(TOLLN,34.5388E0)
      IF (N-1) 590, 10, 20
   10 KT = 2
   20 NN = N
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570
      IF (X) 600, 30, 80
   30 IF (ALPHA) 580, 40, 50
   40 Y(1) = 1.0E0
      IF (N.EQ.1) RETURN
      I1 = 2
      GO TO 60
   50 I1 = 1
   60 DO 70 I=I1,N
        Y(I) = 0.0E0
   70 CONTINUE
      RETURN
   80 CONTINUE
      IF (ALPHA.LT.0.0E0) GO TO 580
C
      IALP = INT(ALPHA)
      FNI = IALP + N - 1
      FNF = ALPHA - IALP
      DFN = FNI + FNF
      FNU = DFN
      IN = 0
      XO2 = X*0.5E0
      SXO2 = XO2*XO2
      ETX = KODE - 1
      SX = ETX*X
C
C     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
C     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
C     APPLIED.
C
      IF (SXO2.LE.(FNU+1.0E0)) GO TO 90
      IF (X.LE.12.0E0) GO TO 110
      FN = 0.55E0*FNU*FNU
      FN = MAX(17.0E0,FN)
      IF (X.GE.FN) GO TO 430
      ANS = MAX(36.0E0-FNU,0.0E0)
      NS = INT(ANS)
      FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      IS = KT
      KM = N - 1 + NS
      IF (KM.GT.0) IS = 3
      GO TO 120
   90 FN = FNU
      FNP1 = FN + 1.0E0
      XO2L = LOG(XO2)
      IS = KT
      IF (X.LE.0.5E0) GO TO 230
      NS = 0
  100 FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      FNP1 = FN + 1.0E0
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 230
  110 XO2L = LOG(XO2)
      NS = INT(SXO2-FNU)
      GO TO 100
  120 CONTINUE
C
C     OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION
C
      IF (KODE.EQ.2) GO TO 130
      IF (ALPHA.LT.1.0E0) GO TO 150
      Z = X/ALPHA
      RA = SQRT(1.0E0+Z*Z)
      GLN = LOG((1.0E0+RA)/Z)
      T = RA*(1.0E0-ETX) + ETX/(Z+RA)
      ARG = ALPHA*(T-GLN)
      IF (ARG.GT.ELIM) GO TO 610
      IF (KM.EQ.0) GO TO 140
  130 CONTINUE
C
C     UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION
C
      Z = X/FN
      RA = SQRT(1.0E0+Z*Z)
      GLN = LOG((1.0E0+RA)/Z)
      T = RA*(1.0E0-ETX) + ETX/(Z+RA)
      ARG = FN*(T-GLN)
  140 IF (ARG.LT.(-ELIM)) GO TO 280
      GO TO 190
  150 IF (X.GT.ELIM) GO TO 610
      GO TO 130
C
C     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
C
  160 IF (KM.NE.0) GO TO 170
      Y(1) = TEMP(3)
      RETURN
  170 TEMP(1) = TEMP(3)
      IN = NS
      KT = 1
      I1 = 0
  180 CONTINUE
      IS = 2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF(I1.EQ.2) GO TO 350
      Z = X/FN
      RA = SQRT(1.0E0+Z*Z)
      GLN = LOG((1.0E0+RA)/Z)
      T = RA*(1.0E0-ETX) + ETX/(Z+RA)
      ARG = FN*(T-GLN)
  190 CONTINUE
      I1 = ABS(3-IS)
      I1 = MAX(I1,1)
      FLGIK = 1.0E0
      CALL ASYIK(X,FN,KODE,FLGIK,RA,ARG,I1,TEMP(IS))
      GO TO (180, 350, 510), IS
C
C     SERIES FOR (X/2)**2.LE.NU+1
C
  230 CONTINUE
      GLN = ALNGAM(FNP1)
      ARG = FN*XO2L - GLN - SX
      IF (ARG.LT.(-ELIM)) GO TO 300
      EARG = EXP(ARG)
  240 CONTINUE
      S = 1.0E0
      IF (X.LT.TOL) GO TO 260
      AK = 3.0E0
      T2 = 1.0E0
      T = 1.0E0
      S1 = FN
      DO 250 K=1,17
        S2 = T2 + S1
        T = T*SXO2/S2
        S = S + T
        IF (ABS(T).LT.TOL) GO TO 260
        T2 = T2 + AK
        AK = AK + 2.0E0
        S1 = S1 + FN
  250 CONTINUE
  260 CONTINUE
      TEMP(IS) = S*EARG
      GO TO (270, 350, 500), IS
  270 EARG = EARG*FN/XO2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IS = 2
      GO TO 240
C
C     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
C
  280 Y(NN) = 0.0E0
      NN = NN - 1
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 340, 290, 130
  290 KT = 2
      IS = 2
      GO TO 130
  300 Y(NN) = 0.0E0
      NN = NN - 1
      FNP1 = FN
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 340, 310, 320
  310 KT = 2
      IS = 2
  320 IF (SXO2.LE.FNP1) GO TO 330
      GO TO 130
  330 ARG = ARG - XO2L + LOG(FNP1)
      IF (ARG.LT.(-ELIM)) GO TO 300
      GO TO 230
  340 NZ = N - NN
      RETURN
C
C     BACKWARD RECURSION SECTION
C
  350 CONTINUE
      NZ = N - NN
  360 CONTINUE
      IF(KT.EQ.2) GO TO 420
      S1 = TEMP(1)
      S2 = TEMP(2)
      TRX = 2.0E0/X
      DTM = FNI
      TM = (DTM+FNF)*TRX
      IF (IN.EQ.0) GO TO 390
C     BACKWARD RECUR TO INDEX ALPHA+NN-1
      DO 380 I=1,IN
        S = S2
        S2 = TM*S2 + S1
        S1 = S
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  380 CONTINUE
      Y(NN) = S1
      IF (NN.EQ.1) RETURN
      Y(NN-1) = S2
      IF (NN.EQ.2) RETURN
      GO TO 400
  390 CONTINUE
C     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
      Y(NN) = S1
      Y(NN-1) = S2
      IF (NN.EQ.2) RETURN
  400 K = NN + 1
      DO 410 I=3,NN
        K = K - 1
        Y(K-2) = TM*Y(K-1) + Y(K)
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  410 CONTINUE
      RETURN
  420 Y(1) = TEMP(2)
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR X TO INFINITY
C
  430 CONTINUE
      EARG = RTTPI/SQRT(X)
      IF (KODE.EQ.2) GO TO 440
      IF (X.GT.ELIM) GO TO 610
      EARG = EARG*EXP(X)
  440 ETX = 8.0E0*X
      IS = KT
      IN = 0
      FN = FNU
  450 DX = FNI + FNI
      TM = 0.0E0
      IF (FNI.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 460
      TM = 4.0E0*FNF*(FNI+FNI+FNF)
  460 CONTINUE
      DTM = DX*DX
      S1 = ETX
      TRX = DTM - 1.0E0
      DX = -(TRX+TM)/ETX
      T = DX
      S = 1.0E0 + DX
      ATOL = TOL*ABS(S)
      S2 = 1.0E0
      AK = 8.0E0
      DO 470 K=1,25
        S1 = S1 + ETX
        S2 = S2 + AK
        DX = DTM - S2
        AP = DX + TM
        T = -T*AP/S1
        S = S + T
        IF (ABS(T).LE.ATOL) GO TO 480
        AK = AK + 8.0E0
  470 CONTINUE
  480 TEMP(IS) = S*EARG
      IF(IS.EQ.2) GO TO 360
      IS = 2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      GO TO 450
C
C     BACKWARD RECURSION WITH NORMALIZATION BY
C     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
C
  500 CONTINUE
C     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
      AKM = MAX(3.0E0-FN,0.0E0)
      KM = INT(AKM)
      TFN = FN + KM
      TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0)
      TA = XO2L - TA
      TB = -(1.0E0-1.0E0/TFN)/TFN
      AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0
      IN = INT(AIN)
      IN = IN + KM
      GO TO 520
  510 CONTINUE
C     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
      T = 1.0E0/(FN*RA)
      AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5E0
      IN = INT(AIN)
      IF (IN.GT.INLIM) GO TO 160
  520 CONTINUE
      TRX = 2.0E0/X
      DTM = FNI + IN
      TM = (DTM+FNF)*TRX
      TA = 0.0E0
      TB = TOL
      KK = 1
  530 CONTINUE
C
C     BACKWARD RECUR UNINDEXED
C
      DO 540 I=1,IN
        S = TB
        TB = TM*TB + TA
        TA = S
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  540 CONTINUE
C     NORMALIZATION
      IF (KK.NE.1) GO TO 550
      TA = (TA/TB)*TEMP(3)
      TB = TEMP(3)
      KK = 2
      IN = NS
      IF (NS.NE.0) GO TO 530
  550 Y(NN) = TB
      NZ = N - NN
      IF (NN.EQ.1) RETURN
      TB = TM*TB + TA
      K = NN - 1
      Y(K) = TB
      IF (NN.EQ.2) RETURN
      DTM = DTM - 1.0E0
      TM = (DTM+FNF)*TRX
      KM = K - 1
C
C     BACKWARD RECUR INDEXED
C
      DO 560 I=1,KM
        Y(K-1) = TM*Y(K) + Y(K+1)
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
        K = K - 1
  560 CONTINUE
      RETURN
C
C
C
  570 CONTINUE
      CALL XERMSG ('SLATEC', 'BESI',
     +   'SCALING OPTION, KODE, NOT 1 OR 2.', 2, 1)
      RETURN
  580 CONTINUE
      CALL XERMSG ('SLATEC', 'BESI', 'ORDER, ALPHA, LESS THAN ZERO.',
     +   2, 1)
      RETURN
  590 CONTINUE
      CALL XERMSG ('SLATEC', 'BESI', 'N LESS THAN ONE.', 2, 1)
      RETURN
  600 CONTINUE
      CALL XERMSG ('SLATEC', 'BESI', 'X LESS THAN ZERO.', 2, 1)
      RETURN
  610 CONTINUE
      CALL XERMSG ('SLATEC', 'BESI',
     +   'OVERFLOW, X TOO LARGE FOR KODE = 1.', 6, 1)
      RETURN
      END
*DECK BESI0
      FUNCTION BESI0 (X)
C***BEGIN PROLOGUE  BESI0
C***PURPOSE  Compute the hyperbolic Bessel function of the first kind
C            of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESI0-S, DBESI0-D)
C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESI0(X) computes the modified (hyperbolic) Bessel function
C of the first kind of order zero and real argument X.
C
C Series for BI0        on the interval  0.          to  9.00000D+00
C                                        with weighted error   2.46E-18
C                                         log weighted error  17.61
C                               significant figures required  17.90
C                                    decimal places required  18.15
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI0E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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***END PROLOGUE  BESI0
      DIMENSION BI0CS(12)
      LOGICAL FIRST
      SAVE BI0CS, NTI0, XSML, XMAX, FIRST
      DATA BI0CS( 1) /   -.0766054725 2839144951E0 /
      DATA BI0CS( 2) /   1.9273379539 93808270E0 /
      DATA BI0CS( 3) /    .2282644586 920301339E0 /
      DATA BI0CS( 4) /    .0130489146 6707290428E0 /
      DATA BI0CS( 5) /    .0004344270 9008164874E0 /
      DATA BI0CS( 6) /    .0000094226 5768600193E0 /
      DATA BI0CS( 7) /    .0000001434 0062895106E0 /
      DATA BI0CS( 8) /    .0000000016 1384906966E0 /
      DATA BI0CS( 9) /    .0000000000 1396650044E0 /
      DATA BI0CS(10) /    .0000000000 0009579451E0 /
      DATA BI0CS(11) /    .0000000000 0000053339E0 /
      DATA BI0CS(12) /    .0000000000 0000000245E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESI0
      IF (FIRST) THEN
         NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3))
         XSML = SQRT (4.5*R1MACH(3))
         XMAX = LOG (R1MACH(2))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0) GO TO 20
C
      BESI0 = 1.0
      IF (Y.GT.XSML) BESI0 = 2.75 + CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0)
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESI0',
     +   'ABS(X) SO BIG I0 OVERFLOWS', 1, 2)
C
      BESI0 = EXP(Y) * BESI0E(X)
C
      RETURN
      END
*DECK BESI0E
      FUNCTION BESI0E (X)
C***BEGIN PROLOGUE  BESI0E
C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
C            Bessel function of the first kind of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESI0E-S, DBSI0E-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FIRST KIND, FNLIB,
C             HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION,
C             ORDER ZERO, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESI0E(X) calculates the exponentially scaled modified (hyperbolic)
C Bessel function of the first kind of order zero for real argument X;
C i.e., EXP(-ABS(X))*I0(X).
C
C
C Series for BI0        on the interval  0.          to  9.00000D+00
C                                        with weighted error   2.46E-18
C                                         log weighted error  17.61
C                               significant figures required  17.90
C                                    decimal places required  18.15
C
C
C Series for AI0        on the interval  1.25000D-01 to  3.33333D-01
C                                        with weighted error   7.87E-17
C                                         log weighted error  16.10
C                               significant figures required  14.69
C                                    decimal places required  16.76
C
C
C Series for AI02       on the interval  0.          to  1.25000D-01
C                                        with weighted error   3.79E-17
C                                         log weighted error  16.42
C                               significant figures required  14.86
C                                    decimal places required  17.09
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890313  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  BESI0E
      DIMENSION BI0CS(12), AI0CS(21), AI02CS(22)
      LOGICAL FIRST
      SAVE BI0CS, AI0CS, AI02CS, NTI0, NTAI0, NTAI02, XSML, FIRST
      DATA BI0CS( 1) /   -.0766054725 2839144951E0 /
      DATA BI0CS( 2) /   1.9273379539 93808270E0 /
      DATA BI0CS( 3) /    .2282644586 920301339E0 /
      DATA BI0CS( 4) /    .0130489146 6707290428E0 /
      DATA BI0CS( 5) /    .0004344270 9008164874E0 /
      DATA BI0CS( 6) /    .0000094226 5768600193E0 /
      DATA BI0CS( 7) /    .0000001434 0062895106E0 /
      DATA BI0CS( 8) /    .0000000016 1384906966E0 /
      DATA BI0CS( 9) /    .0000000000 1396650044E0 /
      DATA BI0CS(10) /    .0000000000 0009579451E0 /
      DATA BI0CS(11) /    .0000000000 0000053339E0 /
      DATA BI0CS(12) /    .0000000000 0000000245E0 /
      DATA AI0CS( 1) /    .0757599449 4023796E0 /
      DATA AI0CS( 2) /    .0075913808 1082334E0 /
      DATA AI0CS( 3) /    .0004153131 3389237E0 /
      DATA AI0CS( 4) /    .0000107007 6463439E0 /
      DATA AI0CS( 5) /   -.0000079011 7997921E0 /
      DATA AI0CS( 6) /   -.0000007826 1435014E0 /
      DATA AI0CS( 7) /    .0000002783 8499429E0 /
      DATA AI0CS( 8) /    .0000000082 5247260E0 /
      DATA AI0CS( 9) /   -.0000000120 4463945E0 /
      DATA AI0CS(10) /    .0000000015 5964859E0 /
      DATA AI0CS(11) /    .0000000002 2925563E0 /
      DATA AI0CS(12) /   -.0000000001 1916228E0 /
      DATA AI0CS(13) /    .0000000000 1757854E0 /
      DATA AI0CS(14) /    .0000000000 0112822E0 /
      DATA AI0CS(15) /   -.0000000000 0114684E0 /
      DATA AI0CS(16) /    .0000000000 0027155E0 /
      DATA AI0CS(17) /   -.0000000000 0002415E0 /
      DATA AI0CS(18) /   -.0000000000 0000608E0 /
      DATA AI0CS(19) /    .0000000000 0000314E0 /
      DATA AI0CS(20) /   -.0000000000 0000071E0 /
      DATA AI0CS(21) /    .0000000000 0000007E0 /
      DATA AI02CS( 1) /    .0544904110 1410882E0 /
      DATA AI02CS( 2) /    .0033691164 7825569E0 /
      DATA AI02CS( 3) /    .0000688975 8346918E0 /
      DATA AI02CS( 4) /    .0000028913 7052082E0 /
      DATA AI02CS( 5) /    .0000002048 9185893E0 /
      DATA AI02CS( 6) /    .0000000226 6668991E0 /
      DATA AI02CS( 7) /    .0000000033 9623203E0 /
      DATA AI02CS( 8) /    .0000000004 9406022E0 /
      DATA AI02CS( 9) /    .0000000000 1188914E0 /
      DATA AI02CS(10) /   -.0000000000 3149915E0 /
      DATA AI02CS(11) /   -.0000000000 1321580E0 /
      DATA AI02CS(12) /   -.0000000000 0179419E0 /
      DATA AI02CS(13) /    .0000000000 0071801E0 /
      DATA AI02CS(14) /    .0000000000 0038529E0 /
      DATA AI02CS(15) /    .0000000000 0001539E0 /
      DATA AI02CS(16) /   -.0000000000 0004151E0 /
      DATA AI02CS(17) /   -.0000000000 0000954E0 /
      DATA AI02CS(18) /    .0000000000 0000382E0 /
      DATA AI02CS(19) /    .0000000000 0000176E0 /
      DATA AI02CS(20) /   -.0000000000 0000034E0 /
      DATA AI02CS(21) /   -.0000000000 0000027E0 /
      DATA AI02CS(22) /    .0000000000 0000003E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESI0E
      IF (FIRST) THEN
         NTI0 = INITS (BI0CS, 12, 0.1*R1MACH(3))
         NTAI0 = INITS (AI0CS, 21, 0.1*R1MACH(3))
         NTAI02 = INITS (AI02CS, 22, 0.1*R1MACH(3))
         XSML = SQRT (4.5*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0) GO TO 20
C
      BESI0E = 1.0 - X
      IF (Y.GT.XSML) BESI0E = EXP(-Y) * ( 2.75 +
     1  CSEVL (Y*Y/4.5-1.0, BI0CS, NTI0) )
      RETURN
C
 20   IF (Y.LE.8.) BESI0E = (.375 + CSEVL ((48./Y-11.)/5., AI0CS, NTAI0)
     1  ) / SQRT(Y)
      IF (Y.GT.8.) BESI0E = (.375 + CSEVL (16./Y-1., AI02CS, NTAI02))
     1  / SQRT(Y)
C
      RETURN
      END
*DECK BESI1
      FUNCTION BESI1 (X)
C***BEGIN PROLOGUE  BESI1
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            first kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESI1-S, DBESI1-D)
C***KEYWORDS  FIRST KIND, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESI1(X) calculates the modified (hyperbolic) Bessel function
C of the first kind of order one for real argument X.
C
C Series for BI1        on the interval  0.          to  9.00000D+00
C                                        with weighted error   2.40E-17
C                                         log weighted error  16.62
C                               significant figures required  16.23
C                                    decimal places required  17.14
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI1E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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***END PROLOGUE  BESI1
      DIMENSION BI1CS(11)
      LOGICAL FIRST
      SAVE BI1CS, NTI1, XMIN, XSML, XMAX, FIRST
      DATA BI1CS( 1) /   -.0019717132 61099859E0 /
      DATA BI1CS( 2) /    .4073488766 7546481E0 /
      DATA BI1CS( 3) /    .0348389942 99959456E0 /
      DATA BI1CS( 4) /    .0015453945 56300123E0 /
      DATA BI1CS( 5) /    .0000418885 21098377E0 /
      DATA BI1CS( 6) /    .0000007649 02676483E0 /
      DATA BI1CS( 7) /    .0000000100 42493924E0 /
      DATA BI1CS( 8) /    .0000000000 99322077E0 /
      DATA BI1CS( 9) /    .0000000000 00766380E0 /
      DATA BI1CS(10) /    .0000000000 00004741E0 /
      DATA BI1CS(11) /    .0000000000 00000024E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESI1
      IF (FIRST) THEN
         NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3))
         XMIN = 2.0*R1MACH(1)
         XSML = SQRT (4.5*R1MACH(3))
         XMAX = LOG (R1MACH(2))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0) GO TO 20
C
      BESI1 = 0.0
      IF (Y.EQ.0.0)  RETURN
C
      IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'BESI1',
     +   'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1)
      IF (Y.GT.XMIN) BESI1 = 0.5*X
      IF (Y.GT.XSML) BESI1 = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS, NTI1))
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESI1',
     +   'ABS(X) SO BIG I1 OVERFLOWS', 2, 2)
C
      BESI1 = EXP(Y) * BESI1E(X)
C
      RETURN
      END
*DECK BESI1E
      FUNCTION BESI1E (X)
C***BEGIN PROLOGUE  BESI1E
C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
C            Bessel function of the first kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESI1E-S, DBSI1E-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FIRST KIND, FNLIB,
C             HYPERBOLIC BESSEL FUNCTION, MODIFIED BESSEL FUNCTION,
C             ORDER ONE, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESI1E(X) calculates the exponentially scaled modified (hyperbolic)
C Bessel function of the first kind of order one for real argument X;
C i.e., EXP(-ABS(X))*I1(X).
C
C Series for BI1        on the interval  0.          to  9.00000D+00
C                                        with weighted error   2.40E-17
C                                         log weighted error  16.62
C                               significant figures required  16.23
C                                    decimal places required  17.14
C
C Series for AI1        on the interval  1.25000D-01 to  3.33333D-01
C                                        with weighted error   6.98E-17
C                                         log weighted error  16.16
C                               significant figures required  14.53
C                                    decimal places required  16.82
C
C Series for AI12       on the interval  0.          to  1.25000D-01
C                                        with weighted error   3.55E-17
C                                         log weighted error  16.45
C                               significant figures required  14.69
C                                    decimal places required  17.12
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890210  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   920618  Removed space from variable names.  (RWC, WRB)
C***END PROLOGUE  BESI1E
      DIMENSION BI1CS(11), AI1CS(21), AI12CS(22)
      LOGICAL FIRST
      SAVE BI1CS, AI1CS, AI12CS, NTI1, NTAI1, NTAI12, XMIN, XSML, FIRST
      DATA BI1CS( 1) /   -.0019717132 61099859E0 /
      DATA BI1CS( 2) /    .4073488766 7546481E0 /
      DATA BI1CS( 3) /    .0348389942 99959456E0 /
      DATA BI1CS( 4) /    .0015453945 56300123E0 /
      DATA BI1CS( 5) /    .0000418885 21098377E0 /
      DATA BI1CS( 6) /    .0000007649 02676483E0 /
      DATA BI1CS( 7) /    .0000000100 42493924E0 /
      DATA BI1CS( 8) /    .0000000000 99322077E0 /
      DATA BI1CS( 9) /    .0000000000 00766380E0 /
      DATA BI1CS(10) /    .0000000000 00004741E0 /
      DATA BI1CS(11) /    .0000000000 00000024E0 /
      DATA AI1CS( 1) /   -.0284674418 1881479E0 /
      DATA AI1CS( 2) /   -.0192295323 1443221E0 /
      DATA AI1CS( 3) /   -.0006115185 8579437E0 /
      DATA AI1CS( 4) /   -.0000206997 1253350E0 /
      DATA AI1CS( 5) /    .0000085856 1914581E0 /
      DATA AI1CS( 6) /    .0000010494 9824671E0 /
      DATA AI1CS( 7) /   -.0000002918 3389184E0 /
      DATA AI1CS( 8) /   -.0000000155 9378146E0 /
      DATA AI1CS( 9) /    .0000000131 8012367E0 /
      DATA AI1CS(10) /   -.0000000014 4842341E0 /
      DATA AI1CS(11) /   -.0000000002 9085122E0 /
      DATA AI1CS(12) /    .0000000001 2663889E0 /
      DATA AI1CS(13) /   -.0000000000 1664947E0 /
      DATA AI1CS(14) /   -.0000000000 0166665E0 /
      DATA AI1CS(15) /    .0000000000 0124260E0 /
      DATA AI1CS(16) /   -.0000000000 0027315E0 /
      DATA AI1CS(17) /    .0000000000 0002023E0 /
      DATA AI1CS(18) /    .0000000000 0000730E0 /
      DATA AI1CS(19) /   -.0000000000 0000333E0 /
      DATA AI1CS(20) /    .0000000000 0000071E0 /
      DATA AI1CS(21) /   -.0000000000 0000006E0 /
      DATA AI12CS( 1) /    .0285762350 1828014E0 /
      DATA AI12CS( 2) /   -.0097610974 9136147E0 /
      DATA AI12CS( 3) /   -.0001105889 3876263E0 /
      DATA AI12CS( 4) /   -.0000038825 6480887E0 /
      DATA AI12CS( 5) /   -.0000002512 2362377E0 /
      DATA AI12CS( 6) /   -.0000000263 1468847E0 /
      DATA AI12CS( 7) /   -.0000000038 3538039E0 /
      DATA AI12CS( 8) /   -.0000000005 5897433E0 /
      DATA AI12CS( 9) /   -.0000000000 1897495E0 /
      DATA AI12CS(10) /    .0000000000 3252602E0 /
      DATA AI12CS(11) /    .0000000000 1412580E0 /
      DATA AI12CS(12) /    .0000000000 0203564E0 /
      DATA AI12CS(13) /   -.0000000000 0071985E0 /
      DATA AI12CS(14) /   -.0000000000 0040836E0 /
      DATA AI12CS(15) /   -.0000000000 0002101E0 /
      DATA AI12CS(16) /    .0000000000 0004273E0 /
      DATA AI12CS(17) /    .0000000000 0001041E0 /
      DATA AI12CS(18) /   -.0000000000 0000382E0 /
      DATA AI12CS(19) /   -.0000000000 0000186E0 /
      DATA AI12CS(20) /    .0000000000 0000033E0 /
      DATA AI12CS(21) /    .0000000000 0000028E0 /
      DATA AI12CS(22) /   -.0000000000 0000003E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESI1E
      IF (FIRST) THEN
         NTI1 = INITS (BI1CS, 11, 0.1*R1MACH(3))
         NTAI1 = INITS (AI1CS, 21, 0.1*R1MACH(3))
         NTAI12 = INITS (AI12CS, 22, 0.1*R1MACH(3))
C
         XMIN = 2.0*R1MACH(1)
         XSML = SQRT (4.5*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.3.0) GO TO 20
C
      BESI1E = 0.0
      IF (Y.EQ.0.0)  RETURN
C
      IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'BESI1E',
     +   'ABS(X) SO SMALL I1 UNDERFLOWS', 1, 1)
      IF (Y.GT.XMIN) BESI1E = 0.5*X
      IF (Y.GT.XSML) BESI1E = X * (.875 + CSEVL(Y*Y/4.5-1., BI1CS,NTI1))
      BESI1E = EXP(-Y) * BESI1E
      RETURN
C
 20   IF (Y.LE.8.) BESI1E = (.375 + CSEVL ((48./Y-11.)/5., AI1CS, NTAI1)
     1  ) / SQRT(Y)
      IF (Y.GT.8.) BESI1E = (.375 + CSEVL (16./Y-1.0, AI12CS, NTAI12))
     1  / SQRT(Y)
      BESI1E = SIGN (BESI1E, X)
C
      RETURN
      END
*DECK BESJ
      SUBROUTINE BESJ (X, ALPHA, N, Y, NZ)
C***BEGIN PROLOGUE  BESJ
C***PURPOSE  Compute an N member sequence of J Bessel functions
C            J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA
C            and X.
C***LIBRARY   SLATEC
C***CATEGORY  C10A3
C***TYPE      SINGLE PRECISION (BESJ-S, DBESJ-D)
C***KEYWORDS  J BESSEL FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C           Daniel, S. L., (SNLA)
C           Weston, M. K., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESJ computes an N member sequence of J Bessel functions
C         J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X.
C         A combination of the power series, the asymptotic expansion
C         for X to infinity and the uniform asymptotic expansion for
C         NU to infinity are applied over subdivisions of the (NU,X)
C         plane.  For values of (NU,X) not covered by one of these
C         formulae, the order is incremented or decremented by integer
C         values into a region where one of the formulae apply. Backward
C         recursion is applied to reduce orders by integer values except
C         where the entire sequence lies in the oscillatory region.  In
C         this case forward recursion is stable and values from the
C         asymptotic expansion for X to infinity start the recursion
C         when it is efficient to do so.  Leading terms of the series
C         and uniform expansion are tested for underflow.  If a sequence
C         is requested and the last member would underflow, the result
C         is set to zero and the next lower order tried, etc., until a
C         member comes on scale or all members are set to zero.
C         Overflow cannot occur.
C
C     Description of Arguments
C
C         Input
C           X      - X .GE. 0.0E0
C           ALPHA  - order of first member of the sequence,
C                    ALPHA .GE. 0.0E0
C           N      - number of members in the sequence, N .GE. 1
C
C         Output
C           Y      - a vector whose first  N components contain
C                    values for J/sub(ALPHA+K-1)/(X), K=1,...,N
C           NZ     - number of components of Y set to zero due to
C                    underflow,
C                    NZ=0   , normal return, computation completed
C                    NZ .NE. 0, last NZ components of Y set to zero,
C                             Y(K)=0.0E0, K=N-NZ+1,...,N.
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Underflow  - a non-fatal error (NZ .NE. 0)
C
C***REFERENCES  D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600
C                 subroutines IBESS and JBESS for Bessel functions
C                 I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM
C                 Transactions on Mathematical Software 3, (1977),
C                 pp. 76-92.
C               F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C***ROUTINES CALLED  ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   750101  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  BESJ
      EXTERNAL JAIRY
      INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN,
     1        NS,NZ
      INTEGER I1MACH
      REAL       AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM,EARG,
     1           ELIM1,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU,FNULIM,
     2           GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN,
     3           S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL,
     4           TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y,RTOL,SLIM
      SAVE RTWO, PDF, RTTP, PIDT, PP, INLIM, FNULIM
      REAL R1MACH, ALNGAM
      DIMENSION Y(*), TEMP(3), FNULIM(2), PP(4), WK(7)
      DATA RTWO,PDF,RTTP,PIDT                    / 1.34839972492648E+00,
     1 7.85398163397448E-01, 7.97884560802865E-01, 1.57079632679490E+00/
      DATA  PP(1),  PP(2),  PP(3),  PP(4)        / 8.72909153935547E+00,
     1 2.65693932265030E-01, 1.24578576865586E-01, 7.70133747430388E-04/
      DATA INLIM           /      150            /
      DATA FNULIM(1), FNULIM(2) /      100.0E0,     60.0E0     /
C***FIRST EXECUTABLE STATEMENT  BESJ
      NZ = 0
      KT = 1
      NS=0
C     I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE
C     I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE
      TA = R1MACH(3)
      TOL = MAX(TA,1.0E-15)
      I1 = I1MACH(11) + 1
      I2 = I1MACH(12)
      TB = R1MACH(5)
      ELIM1 = -2.303E0*(I2*TB+3.0E0)
      RTOL=1.0E0/TOL
      SLIM=R1MACH(1)*1.0E+3*RTOL
C     TOLLN = -LN(TOL)
      TOLLN = 2.303E0*TB*I1
      TOLLN = MIN(TOLLN,34.5388E0)
      IF (N-1) 720, 10, 20
   10 KT = 2
   20 NN = N
      IF (X) 730, 30, 80
   30 IF (ALPHA) 710, 40, 50
   40 Y(1) = 1.0E0
      IF (N.EQ.1) RETURN
      I1 = 2
      GO TO 60
   50 I1 = 1
   60 DO 70 I=I1,N
        Y(I) = 0.0E0
   70 CONTINUE
      RETURN
   80 CONTINUE
      IF (ALPHA.LT.0.0E0) GO TO 710
C
      IALP = INT(ALPHA)
      FNI = IALP + N - 1
      FNF = ALPHA - IALP
      DFN = FNI + FNF
      FNU = DFN
      XO2 = X*0.5E0
      SXO2 = XO2*XO2
C
C     DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X
C     TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE
C     APPLIED.
C
      IF (SXO2.LE.(FNU+1.0E0)) GO TO 90
      TA = MAX(20.0E0,FNU)
      IF (X.GT.TA) GO TO 120
      IF (X.GT.12.0E0) GO TO 110
      XO2L = LOG(XO2)
      NS = INT(SXO2-FNU) + 1
      GO TO 100
   90 FN = FNU
      FNP1 = FN + 1.0E0
      XO2L = LOG(XO2)
      IS = KT
      IF (X.LE.0.50E0) GO TO 330
      NS = 0
  100 FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      FNP1 = FN + 1.0E0
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 330
  110 ANS = MAX(36.0E0-FNU,0.0E0)
      NS = INT(ANS)
      FNI = FNI + NS
      DFN = FNI + FNF
      FN = DFN
      IS = KT
      IF (N-1+NS.GT.0) IS = 3
      GO TO 130
  120 CONTINUE
      RTX = SQRT(X)
      TAU = RTWO*RTX
      TA = TAU + FNULIM(KT)
      IF (FNU.LE.TA) GO TO 480
      FN = FNU
      IS = KT
C
C     UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY
C
  130 CONTINUE
      I1 = ABS(3-IS)
      I1 = MAX(I1,1)
      FLGJY = 1.0E0
      CALL ASYJY(JAIRY,X,FN,FLGJY,I1,TEMP(IS),WK,IFLW)
      IF(IFLW.NE.0) GO TO 380
      GO TO (320, 450, 620), IS
  310 TEMP(1) = TEMP(3)
      KT = 1
  320 IS = 2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF(I1.EQ.2) GO TO 450
      GO TO 130
C
C     SERIES FOR (X/2)**2.LE.NU+1
C
  330 CONTINUE
      GLN = ALNGAM(FNP1)
      ARG = FN*XO2L - GLN
      IF (ARG.LT.(-ELIM1)) GO TO 400
      EARG = EXP(ARG)
  340 CONTINUE
      S = 1.0E0
      IF (X.LT.TOL) GO TO 360
      AK = 3.0E0
      T2 = 1.0E0
      T = 1.0E0
      S1 = FN
      DO 350 K=1,17
        S2 = T2 + S1
        T = -T*SXO2/S2
        S = S + T
        IF (ABS(T).LT.TOL) GO TO 360
        T2 = T2 + AK
        AK = AK + 2.0E0
        S1 = S1 + FN
  350 CONTINUE
  360 CONTINUE
      TEMP(IS) = S*EARG
      GO TO (370, 450, 610), IS
  370 EARG = EARG*FN/XO2
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IS = 2
      GO TO 340
C
C     SET UNDERFLOW VALUE AND UPDATE PARAMETERS
C     UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE
C     LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED.
C
  380 Y(NN) = 0.0E0
      NN = NN - 1
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 440, 390, 130
  390 KT = 2
      IS = 2
      GO TO 130
  400 Y(NN) = 0.0E0
      NN = NN - 1
      FNP1 = FN
      FNI = FNI - 1.0E0
      DFN = FNI + FNF
      FN = DFN
      IF (NN-1) 440, 410, 420
  410 KT = 2
      IS = 2
  420 IF (SXO2.LE.FNP1) GO TO 430
      GO TO 130
  430 ARG = ARG - XO2L + LOG(FNP1)
      IF (ARG.LT.(-ELIM1)) GO TO 400
      GO TO 330
  440 NZ = N - NN
      RETURN
C
C     BACKWARD RECURSION SECTION
C
  450 CONTINUE
      IF(NS.NE.0) GO TO 451
      NZ = N - NN
      IF (KT.EQ.2) GO TO 470
C     BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA
      Y(NN) = TEMP(1)
      Y(NN-1) = TEMP(2)
      IF (NN.EQ.2) RETURN
  451 CONTINUE
      TRX = 2.0E0/X
      DTM = FNI
      TM = (DTM+FNF)*TRX
      AK=1.0E0
      TA=TEMP(1)
      TB=TEMP(2)
      IF(ABS(TA).GT.SLIM) GO TO 455
      TA=TA*RTOL
      TB=TB*RTOL
      AK=TOL
  455 CONTINUE
      KK=2
      IN=NS-1
      IF(IN.EQ.0) GO TO 690
      IF(NS.NE.0) GO TO 670
      K=NN-2
      DO 460 I=3,NN
        S=TB
        TB=TM*TB-TA
        TA=S
        Y(K)=TB*AK
        K=K-1
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  460 CONTINUE
      RETURN
  470 Y(1) = TEMP(2)
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN
C     OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER
C     OF THE SEQUENCE IS ALSO IN THE REGION.
C
  480 CONTINUE
      IN = INT(ALPHA-TAU+2.0E0)
      IF (IN.LE.0) GO TO 490
      IDALP = IALP - IN - 1
      KT = 1
      GO TO 500
  490 CONTINUE
      IDALP = IALP
      IN = 0
  500 IS = KT
      FIDAL = IDALP
      DALPHA = FIDAL + FNF
      ARG = X - PIDT*DALPHA - PDF
      SA = SIN(ARG)
      SB = COS(ARG)
      COEF = RTTP/RTX
      ETX = 8.0E0*X
  510 CONTINUE
      DTM = FIDAL + FIDAL
      DTM = DTM*DTM
      TM = 0.0E0
      IF (FIDAL.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 520
      TM = 4.0E0*FNF*(FIDAL+FIDAL+FNF)
  520 CONTINUE
      TRX = DTM - 1.0E0
      T2 = (TRX+TM)/ETX
      S2 = T2
      RELB = TOL*ABS(T2)
      T1 = ETX
      S1 = 1.0E0
      FN = 1.0E0
      AK = 8.0E0
      DO 530 K=1,13
        T1 = T1 + ETX
        FN = FN + AK
        TRX = DTM - FN
        AP = TRX + TM
        T2 = -T2*AP/T1
        S1 = S1 + T2
        T1 = T1 + ETX
        AK = AK + 8.0E0
        FN = FN + AK
        TRX = DTM - FN
        AP = TRX + TM
        T2 = T2*AP/T1
        S2 = S2 + T2
        IF (ABS(T2).LE.RELB) GO TO 540
        AK = AK + 8.0E0
  530 CONTINUE
  540 TEMP(IS) = COEF*(S1*SB-S2*SA)
      IF(IS.EQ.2) GO TO 560
      FIDAL = FIDAL + 1.0E0
      DALPHA = FIDAL + FNF
      IS = 2
      TB = SA
      SA = -SB
      SB = TB
      GO TO 510
C
C     FORWARD RECURSION SECTION
C
  560 IF (KT.EQ.2) GO TO 470
      S1 = TEMP(1)
      S2 = TEMP(2)
      TX = 2.0E0/X
      TM = DALPHA*TX
      IF (IN.EQ.0) GO TO 580
C
C     FORWARD RECUR TO INDEX ALPHA
C
      DO 570 I=1,IN
        S = S2
        S2 = TM*S2 - S1
        TM = TM + TX
        S1 = S
  570 CONTINUE
      IF (NN.EQ.1) GO TO 600
      S = S2
      S2 = TM*S2 - S1
      TM = TM + TX
      S1 = S
  580 CONTINUE
C
C     FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1
C
      Y(1) = S1
      Y(2) = S2
      IF (NN.EQ.2) RETURN
      DO 590 I=3,NN
        Y(I) = TM*Y(I-1) - Y(I-2)
        TM = TM + TX
  590 CONTINUE
      RETURN
  600 Y(1) = S2
      RETURN
C
C     BACKWARD RECURSION WITH NORMALIZATION BY
C     ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES.
C
  610 CONTINUE
C     COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION
      AKM = MAX(3.0E0-FN,0.0E0)
      KM = INT(AKM)
      TFN = FN + KM
      TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0)
      TA = XO2L - TA
      TB = -(1.0E0-1.5E0/TFN)/TFN
      AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0
      IN = KM + INT(AKM)
      GO TO 660
  620 CONTINUE
C     COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION
      GLN = WK(3) + WK(2)
      IF (WK(6).GT.30.0E0) GO TO 640
      RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0E0
      RZDEN = PP(1) + PP(2)*WK(6)
      TA = RZDEN/RDEN
      IF (WK(1).LT.0.10E0) GO TO 630
      TB = GLN/WK(5)
      GO TO 650
  630 TB=(1.259921049E0+(0.1679894730E0+0.0887944358E0*WK(1))*WK(1))
     1 /WK(7)
      GO TO 650
  640 CONTINUE
      TA = 0.5E0*TOLLN/WK(4)
      TA=((0.0493827160E0*TA-0.1111111111E0)*TA+0.6666666667E0)*TA*WK(6)
      IF (WK(1).LT.0.10E0) GO TO 630
      TB = GLN/WK(5)
  650 IN = INT(TA/TB+1.5E0)
      IF (IN.GT.INLIM) GO TO 310
  660 CONTINUE
      DTM = FNI + IN
      TRX = 2.0E0/X
      TM = (DTM+FNF)*TRX
      TA = 0.0E0
      TB = TOL
      KK = 1
      AK=1.0E0
  670 CONTINUE
C
C     BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO
C     UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL)
C
      DO 680 I=1,IN
        S = TB
        TB = TM*TB - TA
        TA = S
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
  680 CONTINUE
C     NORMALIZATION
      IF (KK.NE.1) GO TO 690
      S=TEMP(3)
      SA=TA/TB
      TA=S
      TB=S
      IF(ABS(S).GT.SLIM) GO TO 685
      TA=TA*RTOL
      TB=TB*RTOL
      AK=TOL
  685 CONTINUE
      TA=TA*SA
      KK = 2
      IN = NS
      IF (NS.NE.0) GO TO 670
  690 Y(NN) = TB*AK
      NZ = N - NN
      IF (NN.EQ.1) RETURN
      K = NN - 1
      S=TB
      TB = TM*TB - TA
      TA=S
      Y(K)=TB*AK
      IF (NN.EQ.2) RETURN
      DTM = DTM - 1.0E0
      TM = (DTM+FNF)*TRX
      K=NN-2
C
C     BACKWARD RECUR INDEXED
C
      DO 700 I=3,NN
        S=TB
        TB = TM*TB - TA
        TA=S
        Y(K)=TB*AK
        DTM = DTM - 1.0E0
        TM = (DTM+FNF)*TRX
        K = K - 1
  700 CONTINUE
      RETURN
C
C
C
  710 CONTINUE
      CALL XERMSG ('SLATEC', 'BESJ', 'ORDER, ALPHA, LESS THAN ZERO.',
     +   2, 1)
      RETURN
  720 CONTINUE
      CALL XERMSG ('SLATEC', 'BESJ', 'N LESS THAN ONE.', 2, 1)
      RETURN
  730 CONTINUE
      CALL XERMSG ('SLATEC', 'BESJ', 'X LESS THAN ZERO.', 2, 1)
      RETURN
      END
*DECK BESJ0
      FUNCTION BESJ0 (X)
C***BEGIN PROLOGUE  BESJ0
C***PURPOSE  Compute the Bessel function of the first kind of order
C            zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10A1
C***TYPE      SINGLE PRECISION (BESJ0-S, DBESJ0-D)
C***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ZERO,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESJ0(X) calculates the Bessel function of the first kind of
C order zero for real argument X.
C
C Series for BJ0        on the interval  0.          to  1.60000D+01
C                                        with weighted error   7.47E-18
C                                         log weighted error  17.13
C                               significant figures required  16.98
C                                    decimal places required  17.68
C
C Series for BM0        on the interval  0.          to  6.25000D-02
C                                        with weighted error   4.98E-17
C                                         log weighted error  16.30
C                               significant figures required  14.97
C                                    decimal places required  16.96
C
C Series for BTH0       on the interval  0.          to  6.25000D-02
C                                        with weighted error   3.67E-17
C                                         log weighted error  16.44
C                               significant figures required  15.53
C                                    decimal places required  17.13
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890210  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***END PROLOGUE  BESJ0
      DIMENSION BJ0CS(13), BM0CS(21), BTH0CS(24)
      LOGICAL FIRST
      SAVE BJ0CS, BM0CS, BTH0CS, PI4, NTJ0, NTM0, NTTH0, XSML, XMAX,
     1   FIRST
      DATA BJ0CS( 1) /    .1002541619 68939137E0 /
      DATA BJ0CS( 2) /   -.6652230077 64405132E0 /
      DATA BJ0CS( 3) /    .2489837034 98281314E0 /
      DATA BJ0CS( 4) /   -.0332527231 700357697E0 /
      DATA BJ0CS( 5) /    .0023114179 304694015E0 /
      DATA BJ0CS( 6) /   -.0000991127 741995080E0 /
      DATA BJ0CS( 7) /    .0000028916 708643998E0 /
      DATA BJ0CS( 8) /   -.0000000612 108586630E0 /
      DATA BJ0CS( 9) /    .0000000009 838650793E0 /
      DATA BJ0CS(10) /   -.0000000000 124235515E0 /
      DATA BJ0CS(11) /    .0000000000 001265433E0 /
      DATA BJ0CS(12) /   -.0000000000 000010619E0 /
      DATA BJ0CS(13) /    .0000000000 000000074E0 /
      DATA BM0CS( 1) /    .0928496163 7381644E0 /
      DATA BM0CS( 2) /   -.0014298770 7403484E0 /
      DATA BM0CS( 3) /    .0000283057 9271257E0 /
      DATA BM0CS( 4) /   -.0000014330 0611424E0 /
      DATA BM0CS( 5) /    .0000001202 8628046E0 /
      DATA BM0CS( 6) /   -.0000000139 7113013E0 /
      DATA BM0CS( 7) /    .0000000020 4076188E0 /
      DATA BM0CS( 8) /   -.0000000003 5399669E0 /
      DATA BM0CS( 9) /    .0000000000 7024759E0 /
      DATA BM0CS(10) /   -.0000000000 1554107E0 /
      DATA BM0CS(11) /    .0000000000 0376226E0 /
      DATA BM0CS(12) /   -.0000000000 0098282E0 /
      DATA BM0CS(13) /    .0000000000 0027408E0 /
      DATA BM0CS(14) /   -.0000000000 0008091E0 /
      DATA BM0CS(15) /    .0000000000 0002511E0 /
      DATA BM0CS(16) /   -.0000000000 0000814E0 /
      DATA BM0CS(17) /    .0000000000 0000275E0 /
      DATA BM0CS(18) /   -.0000000000 0000096E0 /
      DATA BM0CS(19) /    .0000000000 0000034E0 /
      DATA BM0CS(20) /   -.0000000000 0000012E0 /
      DATA BM0CS(21) /    .0000000000 0000004E0 /
      DATA BTH0CS( 1) /   -.2463916377 4300119E0 /
      DATA BTH0CS( 2) /    .0017370983 07508963E0 /
      DATA BTH0CS( 3) /   -.0000621836 33402968E0 /
      DATA BTH0CS( 4) /    .0000043680 50165742E0 /
      DATA BTH0CS( 5) /   -.0000004560 93019869E0 /
      DATA BTH0CS( 6) /    .0000000621 97400101E0 /
      DATA BTH0CS( 7) /   -.0000000103 00442889E0 /
      DATA BTH0CS( 8) /    .0000000019 79526776E0 /
      DATA BTH0CS( 9) /   -.0000000004 28198396E0 /
      DATA BTH0CS(10) /    .0000000001 02035840E0 /
      DATA BTH0CS(11) /   -.0000000000 26363898E0 /
      DATA BTH0CS(12) /    .0000000000 07297935E0 /
      DATA BTH0CS(13) /   -.0000000000 02144188E0 /
      DATA BTH0CS(14) /    .0000000000 00663693E0 /
      DATA BTH0CS(15) /   -.0000000000 00215126E0 /
      DATA BTH0CS(16) /    .0000000000 00072659E0 /
      DATA BTH0CS(17) /   -.0000000000 00025465E0 /
      DATA BTH0CS(18) /    .0000000000 00009229E0 /
      DATA BTH0CS(19) /   -.0000000000 00003448E0 /
      DATA BTH0CS(20) /    .0000000000 00001325E0 /
      DATA BTH0CS(21) /   -.0000000000 00000522E0 /
      DATA BTH0CS(22) /    .0000000000 00000210E0 /
      DATA BTH0CS(23) /   -.0000000000 00000087E0 /
      DATA BTH0CS(24) /    .0000000000 00000036E0 /
      DATA PI4 / 0.7853981633 9744831E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESJ0
      IF (FIRST) THEN
         NTJ0 = INITS (BJ0CS, 13, 0.1*R1MACH(3))
         NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3))
         NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3))
C
         XSML = SQRT (8.0*R1MACH(3))
         XMAX = 1.0/R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.4.0) GO TO 20
C
      BESJ0 = 1.0
      IF (Y.GT.XSML) BESJ0 = CSEVL (.125*Y*Y-1., BJ0CS, NTJ0)
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESJ0',
     +   'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 1, 2)
C
      Z = 32.0/Y**2 - 1.0
      AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(Y)
      THETA = Y - PI4 + CSEVL (Z, BTH0CS, NTTH0) / Y
      BESJ0 = AMPL * COS (THETA)
C
      RETURN
      END
*DECK BESJ1
      FUNCTION BESJ1 (X)
C***BEGIN PROLOGUE  BESJ1
C***PURPOSE  Compute the Bessel function of the first kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10A1
C***TYPE      SINGLE PRECISION (BESJ1-S, DBESJ1-D)
C***KEYWORDS  BESSEL FUNCTION, FIRST KIND, FNLIB, ORDER ONE,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESJ1(X) calculates the Bessel function of the first kind of
C order one for real argument X.
C
C Series for BJ1        on the interval  0.          to  1.60000D+01
C                                        with weighted error   4.48E-17
C                                         log weighted error  16.35
C                               significant figures required  15.77
C                                    decimal places required  16.89
C
C Series for BM1        on the interval  0.          to  6.25000D-02
C                                        with weighted error   5.61E-17
C                                         log weighted error  16.25
C                               significant figures required  14.97
C                                    decimal places required  16.91
C
C Series for BTH1       on the interval  0.          to  6.25000D-02
C                                        with weighted error   4.10E-17
C                                         log weighted error  16.39
C                               significant figures required  15.96
C                                    decimal places required  17.08
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   780601  DATE WRITTEN
C   890210  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***END PROLOGUE  BESJ1
      DIMENSION BJ1CS(12), BM1CS(21), BTH1CS(24)
      LOGICAL FIRST
      SAVE BJ1CS, BM1CS, BTH1CS, PI4, NTJ1, NTM1, NTTH1,
     1 XSML, XMIN, XMAX, FIRST
      DATA BJ1CS( 1) /   -.1172614151 3332787E0 /
      DATA BJ1CS( 2) /   -.2536152183 0790640E0 /
      DATA BJ1CS( 3) /    .0501270809 84469569E0 /
      DATA BJ1CS( 4) /   -.0046315148 09625081E0 /
      DATA BJ1CS( 5) /    .0002479962 29415914E0 /
      DATA BJ1CS( 6) /   -.0000086789 48686278E0 /
      DATA BJ1CS( 7) /    .0000002142 93917143E0 /
      DATA BJ1CS( 8) /   -.0000000039 36093079E0 /
      DATA BJ1CS( 9) /    .0000000000 55911823E0 /
      DATA BJ1CS(10) /   -.0000000000 00632761E0 /
      DATA BJ1CS(11) /    .0000000000 00005840E0 /
      DATA BJ1CS(12) /   -.0000000000 00000044E0 /
      DATA BM1CS( 1) /    .1047362510 931285E0 /
      DATA BM1CS( 2) /    .0044244389 3702345E0 /
      DATA BM1CS( 3) /   -.0000566163 9504035E0 /
      DATA BM1CS( 4) /    .0000023134 9417339E0 /
      DATA BM1CS( 5) /   -.0000001737 7182007E0 /
      DATA BM1CS( 6) /    .0000000189 3209930E0 /
      DATA BM1CS( 7) /   -.0000000026 5416023E0 /
      DATA BM1CS( 8) /    .0000000004 4740209E0 /
      DATA BM1CS( 9) /   -.0000000000 8691795E0 /
      DATA BM1CS(10) /    .0000000000 1891492E0 /
      DATA BM1CS(11) /   -.0000000000 0451884E0 /
      DATA BM1CS(12) /    .0000000000 0116765E0 /
      DATA BM1CS(13) /   -.0000000000 0032265E0 /
      DATA BM1CS(14) /    .0000000000 0009450E0 /
      DATA BM1CS(15) /   -.0000000000 0002913E0 /
      DATA BM1CS(16) /    .0000000000 0000939E0 /
      DATA BM1CS(17) /   -.0000000000 0000315E0 /
      DATA BM1CS(18) /    .0000000000 0000109E0 /
      DATA BM1CS(19) /   -.0000000000 0000039E0 /
      DATA BM1CS(20) /    .0000000000 0000014E0 /
      DATA BM1CS(21) /   -.0000000000 0000005E0 /
      DATA BTH1CS( 1) /    .7406014102 6313850E0 /
      DATA BTH1CS( 2) /   -.0045717556 59637690E0 /
      DATA BTH1CS( 3) /    .0001198185 10964326E0 /
      DATA BTH1CS( 4) /   -.0000069645 61891648E0 /
      DATA BTH1CS( 5) /    .0000006554 95621447E0 /
      DATA BTH1CS( 6) /   -.0000000840 66228945E0 /
      DATA BTH1CS( 7) /    .0000000133 76886564E0 /
      DATA BTH1CS( 8) /   -.0000000024 99565654E0 /
      DATA BTH1CS( 9) /    .0000000005 29495100E0 /
      DATA BTH1CS(10) /   -.0000000001 24135944E0 /
      DATA BTH1CS(11) /    .0000000000 31656485E0 /
      DATA BTH1CS(12) /   -.0000000000 08668640E0 /
      DATA BTH1CS(13) /    .0000000000 02523758E0 /
      DATA BTH1CS(14) /   -.0000000000 00775085E0 /
      DATA BTH1CS(15) /    .0000000000 00249527E0 /
      DATA BTH1CS(16) /   -.0000000000 00083773E0 /
      DATA BTH1CS(17) /    .0000000000 00029205E0 /
      DATA BTH1CS(18) /   -.0000000000 00010534E0 /
      DATA BTH1CS(19) /    .0000000000 00003919E0 /
      DATA BTH1CS(20) /   -.0000000000 00001500E0 /
      DATA BTH1CS(21) /    .0000000000 00000589E0 /
      DATA BTH1CS(22) /   -.0000000000 00000237E0 /
      DATA BTH1CS(23) /    .0000000000 00000097E0 /
      DATA BTH1CS(24) /   -.0000000000 00000040E0 /
      DATA PI4 / 0.7853981633 9744831E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESJ1
      IF (FIRST) THEN
         NTJ1 = INITS (BJ1CS, 12, 0.1*R1MACH(3))
         NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3))
         NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3))
C
         XSML = SQRT (8.0*R1MACH(3))
         XMIN = 2.0*R1MACH(1)
         XMAX = 1.0/R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.4.0) GO TO 20
C
      BESJ1 = 0.
      IF (Y.EQ.0.0) RETURN
      IF (Y .LE. XMIN) CALL XERMSG ('SLATEC', 'BESJ1',
     +   'ABS(X) SO SMALL J1 UNDERFLOWS', 1, 1)
      IF (Y.GT.XMIN) BESJ1 = 0.5*X
      IF (Y.GT.XSML) BESJ1 = X * (.25 + CSEVL(.125*Y*Y-1., BJ1CS, NTJ1))
      RETURN
C
 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'BESJ1',
     +   'NO PRECISION BECAUSE ABS(X) IS TOO BIG', 2, 2)
      Z = 32.0/Y**2 - 1.0
      AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(Y)
      THETA = Y - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / Y
      BESJ1 = SIGN (AMPL, X) * COS (THETA)
C
      RETURN
      END
*DECK BESK
      SUBROUTINE BESK (X, FNU, KODE, N, Y, NZ)
C***BEGIN PROLOGUE  BESK
C***PURPOSE  Implement forward recursion on the three term recursion
C            relation for a sequence of non-negative order Bessel
C            functions K/SUB(FNU+I-1)/(X), or scaled Bessel functions
C            EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N for real, positive
C            X and non-negative orders FNU.
C***LIBRARY   SLATEC
C***CATEGORY  C10B3
C***TYPE      SINGLE PRECISION (BESK-S, DBESK-D)
C***KEYWORDS  K BESSEL FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESK implements forward recursion on the three term
C         recursion relation for a sequence of non-negative order Bessel
C         functions K/sub(FNU+I-1)/(X), or scaled Bessel functions
C         EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N for real X .GT. 0.0E0 and
C         non-negative orders FNU.  If FNU .LT. NULIM, orders FNU and
C         FNU+1 are obtained from BESKNU to start the recursion.  If
C         FNU .GE. NULIM, the uniform asymptotic expansion is used for
C         orders FNU and FNU+1 to start the recursion.  NULIM is 35 or
C         70 depending on whether N=1 or N .GE. 2.  Under and overflow
C         tests are made on the leading term of the asymptotic expansion
C         before any extensive computation is done.
C
C     Description of Arguments
C
C         Input
C           X      - X .GT. 0.0E0
C           FNU    - order of the initial K function, FNU .GE. 0.0E0
C           KODE   - a parameter to indicate the scaling option
C                    KODE=1 returns Y(I)=       K/sub(FNU+I-1)/(X),
C                                        I=1,...,N
C                    KODE=2 returns Y(I)=EXP(X)*K/sub(FNU+I-1)/(X),
C                                        I=1,...,N
C           N      - number of members in the sequence, N .GE. 1
C
C         Output
C           y      - a vector whose first n components contain values
C                    for the sequence
C                    Y(I)=       K/sub(FNU+I-1)/(X), I=1,...,N  or
C                    Y(I)=EXP(X)*K/sub(FNU+I-1)/(X), I=1,...,N
C                    depending on KODE
C           NZ     - number of components of Y set to zero due to
C                    underflow with KODE=1,
C                    NZ=0   , normal return, computation completed
C                    NZ .NE. 0, first NZ components of Y set to zero
C                             due to underflow, Y(I)=0.0E0, I=1,...,NZ
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow - a fatal error
C         Underflow with KODE=1 -  a non-fatal error (NZ .NE. 0)
C
C***REFERENCES  F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C               N. M. Temme, On the numerical evaluation of the modified
C                 Bessel function of the third kind, Journal of
C                 Computational Physics 19, (1975), pp. 324-337.
C***ROUTINES CALLED  ASYIK, BESK0, BESK0E, BESK1, BESK1E, BESKNU,
C                    I1MACH, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790201  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  BESK
C
      INTEGER I, J, K, KODE, MZ, N, NB, ND, NN, NUD, NULIM, NZ
      INTEGER I1MACH
      REAL CN, DNU, ELIM, ETX, FLGIK,FN, FNN, FNU,GLN,GNU,RTZ,S,S1,S2,
     1 T, TM, TRX, W, X, XLIM, Y, ZN
      REAL BESK0, BESK1, BESK1E, BESK0E, R1MACH
      DIMENSION W(2), NULIM(2), Y(*)
      SAVE NULIM
      DATA NULIM(1),NULIM(2) / 35 , 70 /
C***FIRST EXECUTABLE STATEMENT  BESK
      NN = -I1MACH(12)
      ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0)
      XLIM = R1MACH(1)*1.0E+3
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 280
      IF (FNU.LT.0.0E0) GO TO 290
      IF (X.LE.0.0E0) GO TO 300
      IF (X.LT.XLIM) GO TO 320
      IF (N.LT.1) GO TO 310
      ETX = KODE - 1
C
C     ND IS A DUMMY VARIABLE FOR N
C     GNU IS A DUMMY VARIABLE FOR FNU
C     NZ = NUMBER OF UNDERFLOWS ON KODE=1
C
      ND = N
      NZ = 0
      NUD = INT(FNU)
      DNU = FNU - NUD
      GNU = FNU
      NN = MIN(2,ND)
      FN = FNU + N - 1
      FNN = FN
      IF (FN.LT.2.0E0) GO TO 150
C
C     OVERFLOW TEST  (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
C     FOR THE LAST ORDER, FNU+N-1.GE.NULIM
C
      ZN = X/FN
      IF (ZN.EQ.0.0E0) GO TO 320
      RTZ = SQRT(1.0E0+ZN*ZN)
      GLN = LOG((1.0E0+RTZ)/ZN)
      T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ)
      CN = -FN*(T-GLN)
      IF (CN.GT.ELIM) GO TO 320
      IF (NUD.LT.NULIM(NN)) GO TO 30
      IF (NN.EQ.1) GO TO 20
   10 CONTINUE
C
C     UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
C     FOR THE FIRST ORDER, FNU.GE.NULIM
C
      FN = GNU
      ZN = X/FN
      RTZ = SQRT(1.0E0+ZN*ZN)
      GLN = LOG((1.0E0+RTZ)/ZN)
      T = RTZ*(1.0E0-ETX) + ETX/(ZN+RTZ)
      CN = -FN*(T-GLN)
   20 CONTINUE
      IF (CN.LT.-ELIM) GO TO 230
C
C     ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM
C
      FLGIK = -1.0E0
      CALL ASYIK(X,GNU,KODE,FLGIK,RTZ,CN,NN,Y)
      IF (NN.EQ.1) GO TO 240
      TRX = 2.0E0/X
      TM = (GNU+GNU+2.0E0)/X
      GO TO 130
C
   30 CONTINUE
      IF (KODE.EQ.2) GO TO 40
C
C     UNDERFLOW TEST (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION IN X)
C     FOR ORDER DNU
C
      IF (X.GT.ELIM) GO TO 230
   40 CONTINUE
      IF (DNU.NE.0.0E0) GO TO 80
      IF (KODE.EQ.2) GO TO 50
      S1 = BESK0(X)
      GO TO 60
   50 S1 = BESK0E(X)
   60 CONTINUE
      IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 120
      IF (KODE.EQ.2) GO TO 70
      S2 = BESK1(X)
      GO TO 90
   70 S2 = BESK1E(X)
      GO TO 90
   80 CONTINUE
      NB = 2
      IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1
      CALL BESKNU(X, DNU, KODE, NB, W, NZ)
      S1 = W(1)
      IF (NB.EQ.1) GO TO 120
      S2 = W(2)
   90 CONTINUE
      TRX = 2.0E0/X
      TM = (DNU+DNU+2.0E0)/X
C     FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2)
      IF (ND.EQ.1) NUD = NUD - 1
      IF (NUD.GT.0) GO TO 100
      IF (ND.GT.1) GO TO 120
      S1 = S2
      GO TO 120
  100 CONTINUE
      DO 110 I=1,NUD
        S = S2
        S2 = TM*S2 + S1
        S1 = S
        TM = TM + TRX
  110 CONTINUE
      IF (ND.EQ.1) S1 = S2
  120 CONTINUE
      Y(1) = S1
      IF (ND.EQ.1) GO TO 240
      Y(2) = S2
  130 CONTINUE
      IF (ND.EQ.2) GO TO 240
C     FORWARD RECUR FROM FNU+2 TO FNU+N-1
      DO 140 I=3,ND
        Y(I) = TM*Y(I-1) + Y(I-2)
        TM = TM + TRX
  140 CONTINUE
      GO TO 240
C
  150 CONTINUE
C     UNDERFLOW TEST FOR KODE=1
      IF (KODE.EQ.2) GO TO 160
      IF (X.GT.ELIM) GO TO 230
  160 CONTINUE
C     OVERFLOW TEST
      IF (FN.LE.1.0E0) GO TO 170
      IF (-FN*(LOG(X)-0.693E0).GT.ELIM) GO TO 320
  170 CONTINUE
      IF (DNU.EQ.0.0E0) GO TO 180
      CALL BESKNU(X, FNU, KODE, ND, Y, MZ)
      GO TO 240
  180 CONTINUE
      J = NUD
      IF (J.EQ.1) GO TO 210
      J = J + 1
      IF (KODE.EQ.2) GO TO 190
      Y(J) = BESK0(X)
      GO TO 200
  190 Y(J) = BESK0E(X)
  200 IF (ND.EQ.1) GO TO 240
      J = J + 1
  210 IF (KODE.EQ.2) GO TO 220
      Y(J) = BESK1(X)
      GO TO 240
  220 Y(J) = BESK1E(X)
      GO TO 240
C
C     UPDATE PARAMETERS ON UNDERFLOW
C
  230 CONTINUE
      NUD = NUD + 1
      ND = ND - 1
      IF (ND.EQ.0) GO TO 240
      NN = MIN(2,ND)
      GNU = GNU + 1.0E0
      IF (FNN.LT.2.0E0) GO TO 230
      IF (NUD.LT.NULIM(NN)) GO TO 230
      GO TO 10
  240 CONTINUE
      NZ = N - ND
      IF (NZ.EQ.0) RETURN
      IF (ND.EQ.0) GO TO 260
      DO 250 I=1,ND
        J = N - I + 1
        K = ND - I + 1
        Y(J) = Y(K)
  250 CONTINUE
  260 CONTINUE
      DO 270 I=1,NZ
        Y(I) = 0.0E0
  270 CONTINUE
      RETURN
C
C
C
  280 CONTINUE
      CALL XERMSG ('SLATEC', 'BESK', 'SCALING OPTION, KODE, NOT 1 OR 2'
     +   , 2, 1)
      RETURN
  290 CONTINUE
      CALL XERMSG ('SLATEC', 'BESK', 'ORDER, FNU, LESS THAN ZERO', 2,
     +   1)
      RETURN
  300 CONTINUE
      CALL XERMSG ('SLATEC', 'BESK', 'X LESS THAN OR EQUAL TO ZERO', 2,
     +   1)
      RETURN
  310 CONTINUE
      CALL XERMSG ('SLATEC', 'BESK', 'N LESS THAN ONE', 2, 1)
      RETURN
  320 CONTINUE
      CALL XERMSG ('SLATEC', 'BESK',
     +   'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1)
      RETURN
      END
*DECK BESK0
      FUNCTION BESK0 (X)
C***BEGIN PROLOGUE  BESK0
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            third kind of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK0-S, DBESK0-D)
C***KEYWORDS  FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK0(X) calculates the modified (hyperbolic) Bessel function
C of the third kind of order zero for real argument X .GT. 0.0.
C
C Series for BK0        on the interval  0.          to  4.00000D+00
C                                        with weighted error   3.57E-19
C                                         log weighted error  18.45
C                               significant figures required  17.99
C                                    decimal places required  18.97
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI0, BESK0E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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***END PROLOGUE  BESK0
      DIMENSION BK0CS(11)
      LOGICAL FIRST
      SAVE BK0CS, NTK0, XSML, XMAX, FIRST
      DATA BK0CS( 1) /   -.0353273932 3390276872E0 /
      DATA BK0CS( 2) /    .3442898999 246284869E0 /
      DATA BK0CS( 3) /    .0359799365 1536150163E0 /
      DATA BK0CS( 4) /    .0012646154 1144692592E0 /
      DATA BK0CS( 5) /    .0000228621 2103119451E0 /
      DATA BK0CS( 6) /    .0000002534 7910790261E0 /
      DATA BK0CS( 7) /    .0000000019 0451637722E0 /
      DATA BK0CS( 8) /    .0000000000 1034969525E0 /
      DATA BK0CS( 9) /    .0000000000 0004259816E0 /
      DATA BK0CS(10) /    .0000000000 0000013744E0 /
      DATA BK0CS(11) /    .0000000000 0000000035E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK0
      IF (FIRST) THEN
         NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3))
         XSML = SQRT (4.0*R1MACH(3))
         XMAXT = -LOG(R1MACH(1))
         XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5) - 0.01
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK0',
     +   'X IS ZERO OR NEGATIVE', 2, 2)
      IF (X.GT.2.) GO TO 20
C
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK0 = -LOG(0.5*X)*BESI0(X) - .25 + CSEVL (.5*Y-1., BK0CS, NTK0)
      RETURN
C
 20   BESK0 = 0.
      IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESK0',
     +   'X SO BIG K0 UNDERFLOWS', 1, 1)
      IF (X.GT.XMAX) RETURN
C
      BESK0 = EXP(-X) * BESK0E(X)
C
      RETURN
      END
*DECK BESK0E
      FUNCTION BESK0E (X)
C***BEGIN PROLOGUE  BESK0E
C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
C            Bessel function of the third kind of order zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK0E-S, DBSK0E-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ZERO, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK0E(X) computes the exponentially scaled modified (hyperbolic)
C Bessel function of third kind of order zero for real argument
C X .GT. 0.0, i.e., EXP(X)*K0(X).
C
C Series for BK0        on the interval  0.          to  4.00000D+00
C                                        with weighted error   3.57E-19
C                                         log weighted error  18.45
C                               significant figures required  17.99
C                                    decimal places required  18.97
C
C Series for AK0        on the interval  1.25000D-01 to  5.00000D-01
C                                        with weighted error   5.34E-17
C                                         log weighted error  16.27
C                               significant figures required  14.92
C                                    decimal places required  16.89
C
C Series for AK02       on the interval  0.          to  1.25000D-01
C                                        with weighted error   2.34E-17
C                                         log weighted error  16.63
C                               significant figures required  14.67
C                                    decimal places required  17.20
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI0, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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***END PROLOGUE  BESK0E
      DIMENSION BK0CS(11), AK0CS(17), AK02CS(14)
      LOGICAL FIRST
      SAVE BK0CS, AK0CS, AK02CS, NTK0, NTAK0, NTAK02, XSML, FIRST
      DATA BK0CS( 1) /   -.0353273932 3390276872E0 /
      DATA BK0CS( 2) /    .3442898999 246284869E0 /
      DATA BK0CS( 3) /    .0359799365 1536150163E0 /
      DATA BK0CS( 4) /    .0012646154 1144692592E0 /
      DATA BK0CS( 5) /    .0000228621 2103119451E0 /
      DATA BK0CS( 6) /    .0000002534 7910790261E0 /
      DATA BK0CS( 7) /    .0000000019 0451637722E0 /
      DATA BK0CS( 8) /    .0000000000 1034969525E0 /
      DATA BK0CS( 9) /    .0000000000 0004259816E0 /
      DATA BK0CS(10) /    .0000000000 0000013744E0 /
      DATA BK0CS(11) /    .0000000000 0000000035E0 /
      DATA AK0CS( 1) /   -.0764394790 3327941E0 /
      DATA AK0CS( 2) /   -.0223565260 5699819E0 /
      DATA AK0CS( 3) /    .0007734181 1546938E0 /
      DATA AK0CS( 4) /   -.0000428100 6688886E0 /
      DATA AK0CS( 5) /    .0000030817 0017386E0 /
      DATA AK0CS( 6) /   -.0000002639 3672220E0 /
      DATA AK0CS( 7) /    .0000000256 3713036E0 /
      DATA AK0CS( 8) /   -.0000000027 4270554E0 /
      DATA AK0CS( 9) /    .0000000003 1694296E0 /
      DATA AK0CS(10) /   -.0000000000 3902353E0 /
      DATA AK0CS(11) /    .0000000000 0506804E0 /
      DATA AK0CS(12) /   -.0000000000 0068895E0 /
      DATA AK0CS(13) /    .0000000000 0009744E0 /
      DATA AK0CS(14) /   -.0000000000 0001427E0 /
      DATA AK0CS(15) /    .0000000000 0000215E0 /
      DATA AK0CS(16) /   -.0000000000 0000033E0 /
      DATA AK0CS(17) /    .0000000000 0000005E0 /
      DATA AK02CS( 1) /   -.0120186982 6307592E0 /
      DATA AK02CS( 2) /   -.0091748526 9102569E0 /
      DATA AK02CS( 3) /    .0001444550 9317750E0 /
      DATA AK02CS( 4) /   -.0000040136 1417543E0 /
      DATA AK02CS( 5) /    .0000001567 8318108E0 /
      DATA AK02CS( 6) /   -.0000000077 7011043E0 /
      DATA AK02CS( 7) /    .0000000004 6111825E0 /
      DATA AK02CS( 8) /   -.0000000000 3158592E0 /
      DATA AK02CS( 9) /    .0000000000 0243501E0 /
      DATA AK02CS(10) /   -.0000000000 0020743E0 /
      DATA AK02CS(11) /    .0000000000 0001925E0 /
      DATA AK02CS(12) /   -.0000000000 0000192E0 /
      DATA AK02CS(13) /    .0000000000 0000020E0 /
      DATA AK02CS(14) /   -.0000000000 0000002E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK0E
      IF (FIRST) THEN
         NTK0 = INITS (BK0CS, 11, 0.1*R1MACH(3))
         NTAK0 = INITS (AK0CS, 17, 0.1*R1MACH(3))
         NTAK02 = INITS (AK02CS, 14, 0.1*R1MACH(3))
         XSML = SQRT (4.0*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK0E',
     +   'X IS ZERO OR NEGATIVE', 2, 2)
      IF (X.GT.2.) GO TO 20
C
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK0E = EXP(X) * (-LOG(0.5*X)*BESI0(X)
     1  - .25 + CSEVL (.5*Y-1., BK0CS, NTK0) )
      RETURN
C
 20   IF (X.LE.8.) BESK0E = (1.25 + CSEVL ((16./X-5.)/3., AK0CS, NTAK0))
     1  / SQRT(X)
      IF (X.GT.8.) BESK0E = (1.25 + CSEVL (16./X-1., AK02CS, NTAK02))
     1  / SQRT(X)
C
      RETURN
      END
*DECK BESK1
      FUNCTION BESK1 (X)
C***BEGIN PROLOGUE  BESK1
C***PURPOSE  Compute the modified (hyperbolic) Bessel function of the
C            third kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK1-S, DBESK1-D)
C***KEYWORDS  FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK1(X) computes the modified (hyperbolic) Bessel function of third
C kind of order one for real argument X, where X .GT. 0.
C
C Series for BK1        on the interval  0.          to  4.00000D+00
C                                        with weighted error   7.02E-18
C                                         log weighted error  17.15
C                               significant figures required  16.73
C                                    decimal places required  17.67
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI1, BESK1E, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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***END PROLOGUE  BESK1
      DIMENSION BK1CS(11)
      LOGICAL FIRST
      SAVE BK1CS, NTK1, XMIN, XSML, XMAX, FIRST
      DATA BK1CS( 1) /    .0253002273 389477705E0 /
      DATA BK1CS( 2) /   -.3531559607 76544876E0 /
      DATA BK1CS( 3) /   -.1226111808 22657148E0 /
      DATA BK1CS( 4) /   -.0069757238 596398643E0 /
      DATA BK1CS( 5) /   -.0001730288 957513052E0 /
      DATA BK1CS( 6) /   -.0000024334 061415659E0 /
      DATA BK1CS( 7) /   -.0000000221 338763073E0 /
      DATA BK1CS( 8) /   -.0000000001 411488392E0 /
      DATA BK1CS( 9) /   -.0000000000 006666901E0 /
      DATA BK1CS(10) /   -.0000000000 000024274E0 /
      DATA BK1CS(11) /   -.0000000000 000000070E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK1
      IF (FIRST) THEN
         NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3))
         XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01)
         XSML = SQRT (4.0*R1MACH(3))
         XMAXT = -LOG(R1MACH(1))
         XMAX = XMAXT - 0.5*XMAXT*LOG(XMAXT)/(XMAXT+0.5)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK1',
     +   'X IS ZERO OR NEGATIVE', 2, 2)
      IF (X.GT.2.0) GO TO 20
C
      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESK1',
     +   'X SO SMALL K1 OVERFLOWS', 3, 2)
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK1 = LOG(0.5*X)*BESI1(X) +
     1  (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X
      RETURN
C
 20   BESK1 = 0.
      IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESK1',
     +   'X SO BIG K1 UNDERFLOWS', 1, 1)
      IF (X.GT.XMAX) RETURN
C
      BESK1 = EXP(-X) * BESK1E(X)
C
      RETURN
      END
*DECK BESK1E
      FUNCTION BESK1E (X)
C***BEGIN PROLOGUE  BESK1E
C***PURPOSE  Compute the exponentially scaled modified (hyperbolic)
C            Bessel function of the third kind of order one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B1
C***TYPE      SINGLE PRECISION (BESK1E-S, DBSK1E-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, HYPERBOLIC BESSEL FUNCTION,
C             MODIFIED BESSEL FUNCTION, ORDER ONE, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESK1E(X) computes the exponentially scaled modified (hyperbolic)
C Bessel function of third kind of order one for real argument
C X .GT. 0.0, i.e., EXP(X)*K1(X).
C
C Series for BK1        on the interval  0.          to  4.00000D+00
C                                        with weighted error   7.02E-18
C                                         log weighted error  17.15
C                               significant figures required  16.73
C                                    decimal places required  17.67
C
C Series for AK1        on the interval  1.25000D-01 to  5.00000D-01
C                                        with weighted error   6.06E-17
C                                         log weighted error  16.22
C                               significant figures required  15.41
C                                    decimal places required  16.83
C
C Series for AK12       on the interval  0.          to  1.25000D-01
C                                        with weighted error   2.58E-17
C                                         log weighted error  16.59
C                               significant figures required  15.22
C                                    decimal places required  17.16
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESI1, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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***END PROLOGUE  BESK1E
      DIMENSION BK1CS(11), AK1CS(17), AK12CS(14)
      LOGICAL FIRST
      SAVE BK1CS, AK1CS, AK12CS, NTK1, NTAK1, NTAK12, XMIN, XSML,
     1 FIRST
      DATA BK1CS( 1) /    .0253002273 389477705E0 /
      DATA BK1CS( 2) /   -.3531559607 76544876E0 /
      DATA BK1CS( 3) /   -.1226111808 22657148E0 /
      DATA BK1CS( 4) /   -.0069757238 596398643E0 /
      DATA BK1CS( 5) /   -.0001730288 957513052E0 /
      DATA BK1CS( 6) /   -.0000024334 061415659E0 /
      DATA BK1CS( 7) /   -.0000000221 338763073E0 /
      DATA BK1CS( 8) /   -.0000000001 411488392E0 /
      DATA BK1CS( 9) /   -.0000000000 006666901E0 /
      DATA BK1CS(10) /   -.0000000000 000024274E0 /
      DATA BK1CS(11) /   -.0000000000 000000070E0 /
      DATA AK1CS( 1) /    .2744313406 973883E0 /
      DATA AK1CS( 2) /    .0757198995 3199368E0 /
      DATA AK1CS( 3) /   -.0014410515 5647540E0 /
      DATA AK1CS( 4) /    .0000665011 6955125E0 /
      DATA AK1CS( 5) /   -.0000043699 8470952E0 /
      DATA AK1CS( 6) /    .0000003540 2774997E0 /
      DATA AK1CS( 7) /   -.0000000331 1163779E0 /
      DATA AK1CS( 8) /    .0000000034 4597758E0 /
      DATA AK1CS( 9) /   -.0000000003 8989323E0 /
      DATA AK1CS(10) /    .0000000000 4720819E0 /
      DATA AK1CS(11) /   -.0000000000 0604783E0 /
      DATA AK1CS(12) /    .0000000000 0081284E0 /
      DATA AK1CS(13) /   -.0000000000 0011386E0 /
      DATA AK1CS(14) /    .0000000000 0001654E0 /
      DATA AK1CS(15) /   -.0000000000 0000248E0 /
      DATA AK1CS(16) /    .0000000000 0000038E0 /
      DATA AK1CS(17) /   -.0000000000 0000006E0 /
      DATA AK12CS( 1) /    .0637930834 3739001E0 /
      DATA AK12CS( 2) /    .0283288781 3049721E0 /
      DATA AK12CS( 3) /   -.0002475370 6739052E0 /
      DATA AK12CS( 4) /    .0000057719 7245160E0 /
      DATA AK12CS( 5) /   -.0000002068 9392195E0 /
      DATA AK12CS( 6) /    .0000000097 3998344E0 /
      DATA AK12CS( 7) /   -.0000000005 5853361E0 /
      DATA AK12CS( 8) /    .0000000000 3732996E0 /
      DATA AK12CS( 9) /   -.0000000000 0282505E0 /
      DATA AK12CS(10) /    .0000000000 0023720E0 /
      DATA AK12CS(11) /   -.0000000000 0002176E0 /
      DATA AK12CS(12) /    .0000000000 0000215E0 /
      DATA AK12CS(13) /   -.0000000000 0000022E0 /
      DATA AK12CS(14) /    .0000000000 0000002E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESK1E
      IF (FIRST) THEN
         NTK1 = INITS (BK1CS, 11, 0.1*R1MACH(3))
         NTAK1 = INITS (AK1CS, 17, 0.1*R1MACH(3))
         NTAK12 = INITS (AK12CS, 14, 0.1*R1MACH(3))
C
         XMIN = EXP (MAX(LOG(R1MACH(1)), -LOG(R1MACH(2))) + .01)
         XSML = SQRT (4.0*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESK1E',
     +   'X IS ZERO OR NEGATIVE', 2, 2)
      IF (X.GT.2.0) GO TO 20
C
      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESK1E',
     +   'X SO SMALL K1 OVERFLOWS', 3, 2)
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESK1E = EXP(X) * (LOG(0.5*X)*BESI1(X) +
     1  (0.75 + CSEVL (.5*Y-1., BK1CS, NTK1))/X )
      RETURN
C
 20   IF (X.LE.8.) BESK1E = (1.25 + CSEVL ((16./X-5.)/3., AK1CS, NTAK1))
     1  / SQRT(X)
      IF (X.GT.8.) BESK1E = (1.25 + CSEVL (16./X-1., AK12CS, NTAK12))
     1  / SQRT(X)
C
      RETURN
      END
*DECK BESKES
      SUBROUTINE BESKES (XNU, X, NIN, BKE)
C***BEGIN PROLOGUE  BESKES
C***PURPOSE  Compute a sequence of exponentially scaled modified Bessel
C            functions of the third kind of fractional order.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B3
C***TYPE      SINGLE PRECISION (BESKES-S, DBSKES-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, FRACTIONAL ORDER,
C             MODIFIED BESSEL FUNCTION, SEQUENCE OF BESSEL FUNCTIONS,
C             SPECIAL FUNCTIONS, THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESKES computes a sequence of exponentially scaled
C (i.e., multipled by EXP(X)) modified Bessel
C functions of the third kind of order XNU + I at X, where X .GT. 0,
C XNU lies in (-1,1), and I = 0, 1, ... , NIN - 1, if NIN is positive
C and I = 0, -1, ... , NIN + 1, if NIN is negative.  On return, the
C vector BKE(.) contains the results at X for order starting at XNU.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, R9KNUS, 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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  BESKES
      DIMENSION BKE(*)
      SAVE ALNBIG
      DATA ALNBIG / 0. /
C***FIRST EXECUTABLE STATEMENT  BESKES
      IF (ALNBIG.EQ.0.) ALNBIG = LOG (R1MACH(2))
C
      V = ABS(XNU)
      N = ABS(NIN)
C
      IF (V .GE. 1.) CALL XERMSG ('SLATEC', 'BESKES',
     +   'ABS(XNU) MUST BE LT 1', 2, 2)
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESKES', 'X IS LE 0', 3,
     +   2)
      IF (N .EQ. 0) CALL XERMSG ('SLATEC', 'BESKES',
     +   'N THE NUMBER IN THE SEQUENCE IS 0', 4, 2)
C
      CALL R9KNUS (V, X, BKE(1), BKNU1, ISWTCH)
      IF (N.EQ.1) RETURN
C
      VINCR = SIGN (1.0, REAL(NIN))
      DIRECT = VINCR
      IF (XNU.NE.0.) DIRECT = VINCR*SIGN(1.0,XNU)
      IF (ISWTCH .EQ. 1 .AND. DIRECT .GT. 0.) CALL XERMSG ('SLATEC',
     +   'BESKES', 'X SO SMALL BESSEL K-SUB-XNU+1 OVERFLOWS', 5, 2)
      BKE(2) = BKNU1
C
      IF (DIRECT.LT.0.) CALL R9KNUS (ABS(XNU+VINCR), X, BKE(2), BKNU1,
     1  ISWTCH)
      IF (N.EQ.2) RETURN
C
      VEND = ABS(XNU+NIN) - 1.0
      IF ((VEND-0.5)*LOG(VEND)+0.27-VEND*(LOG(X)-.694) .GT. ALNBIG)
     1CALL XERMSG ( 'SLATEC', 'BESKES',
     2'X SO SMALL OR ABS(NU) SO BIG THAT BESSEL K-SUB-NU OVERFLOWS',
     35, 2)
C
      V = XNU
      DO 10 I=3,N
        V = V + VINCR
        BKE(I) = 2.0*V*BKE(I-1)/X + BKE(I-2)
 10   CONTINUE
C
      RETURN
      END
*DECK BESKNU
      SUBROUTINE BESKNU (X, FNU, KODE, N, Y, NZ)
C***BEGIN PROLOGUE  BESKNU
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BESK
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BESKNU-S, DBSKNU-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESKNU computes N member sequences of K Bessel functions
C         K/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and
C         positive X. Equations of the references are implemented on
C         small orders DNU for K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X).
C         Forward recursion with the three term recursion relation
C         generates higher orders FNU+I-1, I=1,...,N. The parameter
C         KODE permits K/SUB(FNU+I-1)/(X) values or scaled values
C         EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned.
C
C         To start the recursion FNU is normalized to the interval
C         -0.5.LE.DNU.LT.0.5. A special form of the power series is
C         implemented on 0.LT.X.LE.X1 while the Miller algorithm for the
C         K Bessel function in terms of the confluent hypergeometric
C         function U(FNU+0.5,2*FNU+1,X) is implemented on X1.LT.X.LE.X2.
C         For X.GT.X2, the asymptotic expansion for large X is used.
C         When FNU is a half odd integer, a special formula for
C         DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion.
C
C         BESKNU assumes that a significant digit SINH(X) function is
C         available.
C
C     Description of Arguments
C
C         Input
C           X      - X.GT.0.0E0
C           FNU    - Order of initial K function, FNU.GE.0.0E0
C           N      - Number of members of the sequence, N.GE.1
C           KODE   - A parameter to indicate the scaling option
C                    KODE= 1  returns
C                             Y(I)=       K/SUB(FNU+I-1)/(X)
C                                  I=1,...,N
C                        = 2  returns
C                             Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X)
C                                  I=1,...,N
C
C         Output
C           Y      - A vector whose first N components contain values
C                    for the sequence
C                    Y(I)=       K/SUB(FNU+I-1)/(X), I=1,...,N or
C                    Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N
C                    depending on KODE
C           NZ     - Number of components set to zero due to
C                    underflow,
C                    NZ= 0   , Normal return
C                    NZ.NE.0 , First NZ components of Y set to zero
C                              due to underflow, Y(I)=0.0E0,I=1,...,NZ
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow - a fatal error
C         Underflow with KODE=1 - a non-fatal error (NZ.NE.0)
C
C***SEE ALSO  BESK
C***REFERENCES  N. M. Temme, On the numerical evaluation of the modified
C                 Bessel function of the third kind, Journal of
C                 Computational Physics 19, (1975), pp. 324-337.
C***ROUTINES CALLED  GAMMA, I1MACH, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790201  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (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   900727  Added EXTERNAL statement.  (WRB)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BESKNU
C
      INTEGER I, IFLAG, INU, J, K, KK, KODE, KODED, N, NN, NZ
      INTEGER I1MACH
      REAL A, AK, A1, A2, B, BK, CC, CK, COEF, CX, DK, DNU, DNU2, ELIM,
     1 ETEST, EX, F, FC, FHS, FK, FKS, FLRX, FMU, FNU, G1, G2, P, PI,
     2 PT, P1, P2, Q, RTHPI, RX, S, SMU, SQK, ST, S1, S2, TM, TOL, T1,
     3 T2, X, X1, X2, Y
      REAL GAMMA, R1MACH
      DIMENSION A(160), B(160), Y(*), CC(8)
      EXTERNAL GAMMA
      SAVE X1, X2, PI, RTHPI, CC
      DATA X1, X2 / 2.0E0, 17.0E0 /
      DATA PI,RTHPI        / 3.14159265358979E+00, 1.25331413731550E+00/
      DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)
     1                     / 5.77215664901533E-01,-4.20026350340952E-02,
     2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04,
     3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/
C***FIRST EXECUTABLE STATEMENT  BESKNU
      KK = -I1MACH(12)
      ELIM = 2.303E0*(KK*R1MACH(5)-3.0E0)
      AK = R1MACH(3)
      TOL = MAX(AK,1.0E-15)
      IF (X.LE.0.0E0) GO TO 350
      IF (FNU.LT.0.0E0) GO TO 360
      IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 370
      IF (N.LT.1) GO TO 380
      NZ = 0
      IFLAG = 0
      KODED = KODE
      RX = 2.0E0/X
      INU = INT(FNU+0.5E0)
      DNU = FNU - INU
      IF (ABS(DNU).EQ.0.5E0) GO TO 120
      DNU2 = 0.0E0
      IF (ABS(DNU).LT.TOL) GO TO 10
      DNU2 = DNU*DNU
   10 CONTINUE
      IF (X.GT.X1) GO TO 120
C
C     SERIES FOR X.LE.X1
C
      A1 = 1.0E0 - DNU
      A2 = 1.0E0 + DNU
      T1 = 1.0E0/GAMMA(A1)
      T2 = 1.0E0/GAMMA(A2)
      IF (ABS(DNU).GT.0.1E0) GO TO 40
C     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
      S = CC(1)
      AK = 1.0E0
      DO 20 K=2,8
        AK = AK*DNU2
        TM = CC(K)*AK
        S = S + TM
        IF (ABS(TM).LT.TOL) GO TO 30
   20 CONTINUE
   30 G1 = -S
      GO TO 50
   40 CONTINUE
      G1 = (T1-T2)/(DNU+DNU)
   50 CONTINUE
      G2 = (T1+T2)*0.5E0
      SMU = 1.0E0
      FC = 1.0E0
      FLRX = LOG(RX)
      FMU = DNU*FLRX
      IF (DNU.EQ.0.0E0) GO TO 60
      FC = DNU*PI
      FC = FC/SIN(FC)
      IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU
   60 CONTINUE
      F = FC*(G1*COSH(FMU)+G2*FLRX*SMU)
      FC = EXP(FMU)
      P = 0.5E0*FC/T2
      Q = 0.5E0/(FC*T1)
      AK = 1.0E0
      CK = 1.0E0
      BK = 1.0E0
      S1 = F
      S2 = P
      IF (INU.GT.0 .OR. N.GT.1) GO TO 90
      IF (X.LT.TOL) GO TO 80
      CX = X*X*0.25E0
   70 CONTINUE
      F = (AK*F+P+Q)/(BK-DNU2)
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      CK = CK*CX/AK
      T1 = CK*F
      S1 = S1 + T1
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      S = ABS(T1)/(1.0E0+ABS(S1))
      IF (S.GT.TOL) GO TO 70
   80 CONTINUE
      Y(1) = S1
      IF (KODED.EQ.1) RETURN
      Y(1) = S1*EXP(X)
      RETURN
   90 CONTINUE
      IF (X.LT.TOL) GO TO 110
      CX = X*X*0.25E0
  100 CONTINUE
      F = (AK*F+P+Q)/(BK-DNU2)
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      CK = CK*CX/AK
      T1 = CK*F
      S1 = S1 + T1
      T2 = CK*(P-AK*F)
      S2 = S2 + T2
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2))
      IF (S.GT.TOL) GO TO 100
  110 CONTINUE
      S2 = S2*RX
      IF (KODED.EQ.1) GO TO 170
      F = EXP(X)
      S1 = S1*F
      S2 = S2*F
      GO TO 170
  120 CONTINUE
      COEF = RTHPI/SQRT(X)
      IF (KODED.EQ.2) GO TO 130
      IF (X.GT.ELIM) GO TO 330
      COEF = COEF*EXP(-X)
  130 CONTINUE
      IF (ABS(DNU).EQ.0.5E0) GO TO 340
      IF (X.GT.X2) GO TO 280
C
C     MILLER ALGORITHM FOR X1.LT.X.LE.X2
C
      ETEST = COS(PI*DNU)/(PI*X*TOL)
      FKS = 1.0E0
      FHS = 0.25E0
      FK = 0.0E0
      CK = X + X + 2.0E0
      P1 = 0.0E0
      P2 = 1.0E0
      K = 0
  140 CONTINUE
      K = K + 1
      FK = FK + 1.0E0
      AK = (FHS-DNU2)/(FKS+FK)
      BK = CK/(FK+1.0E0)
      PT = P2
      P2 = BK*P2 - AK*P1
      P1 = PT
      A(K) = AK
      B(K) = BK
      CK = CK + 2.0E0
      FKS = FKS + FK + FK + 1.0E0
      FHS = FHS + FK + FK
      IF (ETEST.GT.FK*P1) GO TO 140
      KK = K
      S = 1.0E0
      P1 = 0.0E0
      P2 = 1.0E0
      DO 150 I=1,K
        PT = P2
        P2 = (B(KK)*P2-P1)/A(KK)
        P1 = PT
        S = S + P2
        KK = KK - 1
  150 CONTINUE
      S1 = COEF*(P2/S)
      IF (INU.GT.0 .OR. N.GT.1) GO TO 160
      GO TO 200
  160 CONTINUE
      S2 = S1*(X+DNU+0.5E0-P1/P2)/X
C
C     FORWARD RECURSION ON THE THREE TERM RECURSION RELATION
C
  170 CONTINUE
      CK = (DNU+DNU+2.0E0)/X
      IF (N.EQ.1) INU = INU - 1
      IF (INU.GT.0) GO TO 180
      IF (N.GT.1) GO TO 200
      S1 = S2
      GO TO 200
  180 CONTINUE
      DO 190 I=1,INU
        ST = S2
        S2 = CK*S2 + S1
        S1 = ST
        CK = CK + RX
  190 CONTINUE
      IF (N.EQ.1) S1 = S2
  200 CONTINUE
      IF (IFLAG.EQ.1) GO TO 220
      Y(1) = S1
      IF (N.EQ.1) RETURN
      Y(2) = S2
      IF (N.EQ.2) RETURN
      DO 210 I=3,N
        Y(I) = CK*Y(I-1) + Y(I-2)
        CK = CK + RX
  210 CONTINUE
      RETURN
C     IFLAG=1 CASES
  220 CONTINUE
      S = -X + LOG(S1)
      Y(1) = 0.0E0
      NZ = 1
      IF (S.LT.-ELIM) GO TO 230
      Y(1) = EXP(S)
      NZ = 0
  230 CONTINUE
      IF (N.EQ.1) RETURN
      S = -X + LOG(S2)
      Y(2) = 0.0E0
      NZ = NZ + 1
      IF (S.LT.-ELIM) GO TO 240
      NZ = NZ - 1
      Y(2) = EXP(S)
  240 CONTINUE
      IF (N.EQ.2) RETURN
      KK = 2
      IF (NZ.LT.2) GO TO 260
      DO 250 I=3,N
        KK = I
        ST = S2
        S2 = CK*S2 + S1
        S1 = ST
        CK = CK + RX
        S = -X + LOG(S2)
        NZ = NZ + 1
        Y(I) = 0.0E0
        IF (S.LT.-ELIM) GO TO 250
        Y(I) = EXP(S)
        NZ = NZ - 1
        GO TO 260
  250 CONTINUE
      RETURN
  260 CONTINUE
      IF (KK.EQ.N) RETURN
      S2 = S2*CK + S1
      CK = CK + RX
      KK = KK + 1
      Y(KK) = EXP(-X+LOG(S2))
      IF (KK.EQ.N) RETURN
      KK = KK + 1
      DO 270 I=KK,N
        Y(I) = CK*Y(I-1) + Y(I-2)
        CK = CK + RX
  270 CONTINUE
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2
C
C     IFLAG=0 MEANS NO UNDERFLOW OCCURRED
C     IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH
C     KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD
C     RECURSION
  280 CONTINUE
      NN = 2
      IF (INU.EQ.0 .AND. N.EQ.1) NN = 1
      DNU2 = DNU + DNU
      FMU = 0.0E0
      IF (ABS(DNU2).LT.TOL) GO TO 290
      FMU = DNU2*DNU2
  290 CONTINUE
      EX = X*8.0E0
      S2 = 0.0E0
      DO 320 K=1,NN
        S1 = S2
        S = 1.0E0
        AK = 0.0E0
        CK = 1.0E0
        SQK = 1.0E0
        DK = EX
        DO 300 J=1,30
          CK = CK*(FMU-SQK)/DK
          S = S + CK
          DK = DK + EX
          AK = AK + 8.0E0
          SQK = SQK + AK
          IF (ABS(CK).LT.TOL) GO TO 310
  300   CONTINUE
  310   S2 = S*COEF
        FMU = FMU + 8.0E0*DNU + 4.0E0
  320 CONTINUE
      IF (NN.GT.1) GO TO 170
      S1 = S2
      GO TO 200
  330 CONTINUE
      KODED = 2
      IFLAG = 1
      GO TO 120
C
C     FNU=HALF ODD INTEGER CASE
C
  340 CONTINUE
      S1 = COEF
      S2 = COEF
      GO TO 170
C
C
  350 CALL XERMSG ('SLATEC', 'BESKNU', 'X NOT GREATER THAN ZERO', 2, 1)
      RETURN
  360 CALL XERMSG ('SLATEC', 'BESKNU', 'FNU NOT ZERO OR POSITIVE', 2,
     +   1)
      RETURN
  370 CALL XERMSG ('SLATEC', 'BESKNU', 'KODE NOT 1 OR 2', 2, 1)
      RETURN
  380 CALL XERMSG ('SLATEC', 'BESKNU', 'N NOT GREATER THAN 0', 2, 1)
      RETURN
      END
*DECK BESKS
      SUBROUTINE BESKS (XNU, X, NIN, BK)
C***BEGIN PROLOGUE  BESKS
C***PURPOSE  Compute a sequence of modified Bessel functions of the
C            third kind of fractional order.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B3
C***TYPE      SINGLE PRECISION (BESKS-S, DBESKS-D)
C***KEYWORDS  FNLIB, FRACTIONAL ORDER, MODIFIED BESSEL FUNCTION,
C             SEQUENCE OF BESSEL FUNCTIONS, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESKS computes a sequence of modified Bessel functions of the third
C kind of order XNU + I at X, where X .GT. 0, XNU lies in (-1,1),
C and I = 0, 1, ... , NIN - 1, if NIN is positive and I = 0, 1, ... ,
C NIN + 1, if NIN is negative.  On return, the vector BK(.) Contains
C the results at X for order starting at XNU.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESKES, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  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***END PROLOGUE  BESKS
      DIMENSION BK(*)
      SAVE XMAX
      DATA XMAX / 0.0 /
C***FIRST EXECUTABLE STATEMENT  BESKS
      IF (XMAX.EQ.0.0) XMAX = -LOG (R1MACH(1))
C
      IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESKS',
     +   'X SO BIG BESSEL K UNDERFLOWS', 1, 2)
C
      CALL BESKES (XNU, X, NIN, BK)
C
      EXPXI = EXP (-X)
      N = ABS (NIN)
      DO 20 I=1,N
        BK(I) = EXPXI * BK(I)
 20   CONTINUE
C
      RETURN
      END
*DECK BESY
      SUBROUTINE BESY (X, FNU, N, Y)
C***BEGIN PROLOGUE  BESY
C***PURPOSE  Implement forward recursion on the three term recursion
C            relation for a sequence of non-negative order Bessel
C            functions Y/SUB(FNU+I-1)/(X), I=1,...,N for real, positive
C            X and non-negative orders FNU.
C***LIBRARY   SLATEC
C***CATEGORY  C10A3
C***TYPE      SINGLE PRECISION (BESY-S, DBESY-D)
C***KEYWORDS  SPECIAL FUNCTIONS, Y BESSEL FUNCTION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESY implements forward recursion on the three term
C         recursion relation for a sequence of non-negative order Bessel
C         functions Y/sub(FNU+I-1)/(X), I=1,N for real X .GT. 0.0E0 and
C         non-negative orders FNU.  If FNU .LT. NULIM, orders FNU and
C         FNU+1 are obtained from BESYNU which computes by a power
C         series for X .LE. 2, the K Bessel function of an imaginary
C         argument for 2 .LT. X .LE. 20 and the asymptotic expansion for
C         X .GT. 20.
C
C         If FNU .GE. NULIM, the uniform asymptotic expansion is coded
C         in ASYJY for orders FNU and FNU+1 to start the recursion.
C         NULIM is 70 or 100 depending on whether N=1 or N .GE. 2.  An
C         overflow test is made on the leading term of the asymptotic
C         expansion before any extensive computation is done.
C
C     Description of Arguments
C
C         Input
C           X      - X .GT. 0.0E0
C           FNU    - order of the initial Y function, FNU .GE. 0.0E0
C           N      - number of members in the sequence, N .GE. 1
C
C         Output
C           Y      - a vector whose first N components contain values
C                    for the sequence Y(I)=Y/sub(FNU+I-1)/(X), I=1,N.
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow - a fatal error
C
C***REFERENCES  F. W. J. Olver, Tables of Bessel Functions of Moderate
C                 or Large Orders, NPL Mathematical Tables 6, Her
C                 Majesty's Stationery Office, London, 1962.
C               N. M. Temme, On the numerical evaluation of the modified
C                 Bessel function of the third kind, Journal of
C                 Computational Physics 19, (1975), pp. 324-337.
C               N. M. Temme, On the numerical evaluation of the ordinary
C                 Bessel function of the second kind, Journal of
C                 Computational Physics 21, (1976), pp. 343-350.
C***ROUTINES CALLED  ASYJY, BESY0, BESY1, BESYNU, I1MACH, R1MACH,
C                    XERMSG, YAIRY
C***REVISION HISTORY  (YYMMDD)
C   800501  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  BESY
C
      EXTERNAL YAIRY
      INTEGER I, IFLW, J, N, NB, ND, NN, NUD, NULIM
      INTEGER I1MACH
      REAL       AZN,CN,DNU,ELIM,FLGJY,FN,FNU,RAN,S,S1,S2,TM,TRX,
     1           W,WK,W2N,X,XLIM,XXN,Y
      REAL BESY0, BESY1, R1MACH
	EXTERNAL BESY0, BESY1
      DIMENSION W(2), NULIM(2), Y(*), WK(7)
      SAVE NULIM
      DATA NULIM(1),NULIM(2) / 70 , 100 /
C***FIRST EXECUTABLE STATEMENT  BESY
      NN = -I1MACH(12)
      ELIM = 2.303E0*(NN*R1MACH(5)-3.0E0)
      XLIM = R1MACH(1)*1.0E+3
      IF (FNU.LT.0.0E0) GO TO 140
      IF (X.LE.0.0E0) GO TO 150
      IF (X.LT.XLIM) GO TO 170
      IF (N.LT.1) GO TO 160
C
C     ND IS A DUMMY VARIABLE FOR N
C
      ND = N
      NUD = INT(FNU)
      DNU = FNU - NUD
      NN = MIN(2,ND)
      FN = FNU + N - 1
      IF (FN.LT.2.0E0) GO TO 100
C
C     OVERFLOW TEST  (LEADING EXPONENTIAL OF ASYMPTOTIC EXPANSION)
C     FOR THE LAST ORDER, FNU+N-1.GE.NULIM
C
      XXN = X/FN
      W2N = 1.0E0-XXN*XXN
      IF(W2N.LE.0.0E0) GO TO 10
      RAN = SQRT(W2N)
      AZN = LOG((1.0E0+RAN)/XXN) - RAN
      CN = FN*AZN
      IF(CN.GT.ELIM) GO TO 170
   10 CONTINUE
      IF (NUD.LT.NULIM(NN)) GO TO 20
C
C     ASYMPTOTIC EXPANSION FOR ORDERS FNU AND FNU+1.GE.NULIM
C
      FLGJY = -1.0E0
      CALL ASYJY(YAIRY,X,FNU,FLGJY,NN,Y,WK,IFLW)
      IF(IFLW.NE.0) GO TO 170
      IF (NN.EQ.1) RETURN
      TRX = 2.0E0/X
      TM = (FNU+FNU+2.0E0)/X
      GO TO 80
C
   20 CONTINUE
      IF (DNU.NE.0.0E0) GO TO 30
      S1 = BESY0(X)
      IF (NUD.EQ.0 .AND. ND.EQ.1) GO TO 70
      S2 = BESY1(X)
      GO TO 40
   30 CONTINUE
      NB = 2
      IF (NUD.EQ.0 .AND. ND.EQ.1) NB = 1
      CALL BESYNU(X, DNU, NB, W)
      S1 = W(1)
      IF (NB.EQ.1) GO TO 70
      S2 = W(2)
   40 CONTINUE
      TRX = 2.0E0/X
      TM = (DNU+DNU+2.0E0)/X
C     FORWARD RECUR FROM DNU TO FNU+1 TO GET Y(1) AND Y(2)
      IF (ND.EQ.1) NUD = NUD - 1
      IF (NUD.GT.0) GO TO 50
      IF (ND.GT.1) GO TO 70
      S1 = S2
      GO TO 70
   50 CONTINUE
      DO 60 I=1,NUD
        S = S2
        S2 = TM*S2 - S1
        S1 = S
        TM = TM + TRX
   60 CONTINUE
      IF (ND.EQ.1) S1 = S2
   70 CONTINUE
      Y(1) = S1
      IF (ND.EQ.1) RETURN
      Y(2) = S2
   80 CONTINUE
      IF (ND.EQ.2) RETURN
C     FORWARD RECUR FROM FNU+2 TO FNU+N-1
      DO 90 I=3,ND
        Y(I) = TM*Y(I-1) - Y(I-2)
        TM = TM + TRX
   90 CONTINUE
      RETURN
C
  100 CONTINUE
C     OVERFLOW TEST
      IF (FN.LE.1.0E0) GO TO 110
      IF (-FN*(LOG(X)-0.693E0).GT.ELIM) GO TO 170
  110 CONTINUE
      IF (DNU.EQ.0.0E0) GO TO 120
      CALL BESYNU(X, FNU, ND, Y)
      RETURN
  120 CONTINUE
      J = NUD
      IF (J.EQ.1) GO TO 130
      J = J + 1
      Y(J) = BESY0(X)
      IF (ND.EQ.1) RETURN
      J = J + 1
  130 CONTINUE
      Y(J) = BESY1(X)
      IF (ND.EQ.1) RETURN
      TRX = 2.0E0/X
      TM = TRX
      GO TO 80
C
C
C
  140 CONTINUE
      CALL XERMSG ('SLATEC', 'BESY', 'ORDER, FNU, LESS THAN ZERO', 2,
     +   1)
      RETURN
  150 CONTINUE
      CALL XERMSG ('SLATEC', 'BESY', 'X LESS THAN OR EQUAL TO ZERO', 2,
     +   1)
      RETURN
  160 CONTINUE
      CALL XERMSG ('SLATEC', 'BESY', 'N LESS THAN ONE', 2, 1)
      RETURN
  170 CONTINUE
      CALL XERMSG ('SLATEC', 'BESY',
     +   'OVERFLOW, FNU OR N TOO LARGE OR X TOO SMALL', 6, 1)
      RETURN
      END
*DECK BESY0
      FUNCTION BESY0 (X)
C***BEGIN PROLOGUE  BESY0
C***PURPOSE  Compute the Bessel function of the second kind of order
C            zero.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10A1
C***TYPE      SINGLE PRECISION (BESY0-S, DBESY0-D)
C***KEYWORDS  BESSEL FUNCTION, FNLIB, ORDER ZERO, SECOND KIND,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESY0(X) calculates the Bessel function of the second kind
C of order zero for real argument X.
C
C Series for BY0        on the interval  0.          to  1.60000D+01
C                                        with weighted error   1.20E-17
C                                         log weighted error  16.92
C                               significant figures required  16.15
C                                    decimal places required  17.48
C
C Series for BM0        on the interval  0.          to  6.25000D-02
C                                        with weighted error   4.98E-17
C                                         log weighted error  16.30
C                               significant figures required  14.97
C                                    decimal places required  16.96
C
C Series for BTH0       on the interval  0.          to  6.25000D-02
C                                        with weighted error   3.67E-17
C                                         log weighted error  16.44
C                               significant figures required  15.53
C                                    decimal places required  17.13
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESJ0, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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***END PROLOGUE  BESY0
      DIMENSION BY0CS(13), BM0CS(21), BTH0CS(24)
	EXTERNAL BESJ0

      LOGICAL FIRST
      SAVE BY0CS, BM0CS, BTH0CS, TWODPI, PI4,
     1 NTY0, NTM0, NTTH0, XSML, XMAX, FIRST
      DATA BY0CS( 1) /   -.0112778393 92865573E0 /
      DATA BY0CS( 2) /   -.1283452375 6042035E0 /
      DATA BY0CS( 3) /   -.1043788479 9794249E0 /
      DATA BY0CS( 4) /    .0236627491 83969695E0 /
      DATA BY0CS( 5) /   -.0020903916 47700486E0 /
      DATA BY0CS( 6) /    .0001039754 53939057E0 /
      DATA BY0CS( 7) /   -.0000033697 47162423E0 /
      DATA BY0CS( 8) /    .0000000772 93842676E0 /
      DATA BY0CS( 9) /   -.0000000013 24976772E0 /
      DATA BY0CS(10) /    .0000000000 17648232E0 /
      DATA BY0CS(11) /   -.0000000000 00188105E0 /
      DATA BY0CS(12) /    .0000000000 00001641E0 /
      DATA BY0CS(13) /   -.0000000000 00000011E0 /
      DATA BM0CS( 1) /    .0928496163 7381644E0 /
      DATA BM0CS( 2) /   -.0014298770 7403484E0 /
      DATA BM0CS( 3) /    .0000283057 9271257E0 /
      DATA BM0CS( 4) /   -.0000014330 0611424E0 /
      DATA BM0CS( 5) /    .0000001202 8628046E0 /
      DATA BM0CS( 6) /   -.0000000139 7113013E0 /
      DATA BM0CS( 7) /    .0000000020 4076188E0 /
      DATA BM0CS( 8) /   -.0000000003 5399669E0 /
      DATA BM0CS( 9) /    .0000000000 7024759E0 /
      DATA BM0CS(10) /   -.0000000000 1554107E0 /
      DATA BM0CS(11) /    .0000000000 0376226E0 /
      DATA BM0CS(12) /   -.0000000000 0098282E0 /
      DATA BM0CS(13) /    .0000000000 0027408E0 /
      DATA BM0CS(14) /   -.0000000000 0008091E0 /
      DATA BM0CS(15) /    .0000000000 0002511E0 /
      DATA BM0CS(16) /   -.0000000000 0000814E0 /
      DATA BM0CS(17) /    .0000000000 0000275E0 /
      DATA BM0CS(18) /   -.0000000000 0000096E0 /
      DATA BM0CS(19) /    .0000000000 0000034E0 /
      DATA BM0CS(20) /   -.0000000000 0000012E0 /
      DATA BM0CS(21) /    .0000000000 0000004E0 /
      DATA BTH0CS( 1) /   -.2463916377 4300119E0 /
      DATA BTH0CS( 2) /    .0017370983 07508963E0 /
      DATA BTH0CS( 3) /   -.0000621836 33402968E0 /
      DATA BTH0CS( 4) /    .0000043680 50165742E0 /
      DATA BTH0CS( 5) /   -.0000004560 93019869E0 /
      DATA BTH0CS( 6) /    .0000000621 97400101E0 /
      DATA BTH0CS( 7) /   -.0000000103 00442889E0 /
      DATA BTH0CS( 8) /    .0000000019 79526776E0 /
      DATA BTH0CS( 9) /   -.0000000004 28198396E0 /
      DATA BTH0CS(10) /    .0000000001 02035840E0 /
      DATA BTH0CS(11) /   -.0000000000 26363898E0 /
      DATA BTH0CS(12) /    .0000000000 07297935E0 /
      DATA BTH0CS(13) /   -.0000000000 02144188E0 /
      DATA BTH0CS(14) /    .0000000000 00663693E0 /
      DATA BTH0CS(15) /   -.0000000000 00215126E0 /
      DATA BTH0CS(16) /    .0000000000 00072659E0 /
      DATA BTH0CS(17) /   -.0000000000 00025465E0 /
      DATA BTH0CS(18) /    .0000000000 00009229E0 /
      DATA BTH0CS(19) /   -.0000000000 00003448E0 /
      DATA BTH0CS(20) /    .0000000000 00001325E0 /
      DATA BTH0CS(21) /   -.0000000000 00000522E0 /
      DATA BTH0CS(22) /    .0000000000 00000210E0 /
      DATA BTH0CS(23) /   -.0000000000 00000087E0 /
      DATA BTH0CS(24) /    .0000000000 00000036E0 /
      DATA TWODPI / 0.6366197723 6758134E0 /
      DATA PI4 / 0.7853981633 9744831E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESY0
      IF (FIRST) THEN
         NTY0 = INITS (BY0CS, 13, 0.1*R1MACH(3))
         NTM0 = INITS (BM0CS, 21, 0.1*R1MACH(3))
         NTTH0 = INITS (BTH0CS, 24, 0.1*R1MACH(3))
C
         XSML = SQRT (4.0*R1MACH(3))
         XMAX = 1.0/R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESY0',
     +   'X IS ZERO OR NEGATIVE', 1, 2)
      IF (X.GT.4.0) GO TO 20
C
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESY0 = TWODPI*LOG(0.5*X)*BESJ0(X) + .375 + CSEVL (.125*Y-1.,
     1  BY0CS, NTY0)
      RETURN
C
 20   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESY0',
     +   'NO PRECISION BECAUSE X IS BIG', 2, 2)
C
      Z = 32.0/X**2 - 1.0
      AMPL = (0.75 + CSEVL (Z, BM0CS, NTM0)) / SQRT(X)
      THETA = X - PI4 + CSEVL (Z, BTH0CS, NTTH0) / X
      BESY0 = AMPL * SIN (THETA)
C
      RETURN
      END
*DECK BESY1
      FUNCTION BESY1 (X)
C***BEGIN PROLOGUE  BESY1
C***PURPOSE  Compute the Bessel function of the second kind of order
C            one.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10A1
C***TYPE      SINGLE PRECISION (BESY1-S, DBESY1-D)
C***KEYWORDS  BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BESY1(X) calculates the Bessel function of the second kind of
C order one for real argument X.
C
C Series for BY1        on the interval  0.          to  1.60000D+01
C                                        with weighted error   1.87E-18
C                                         log weighted error  17.73
C                               significant figures required  17.83
C                                    decimal places required  18.30
C
C Series for BM1        on the interval  0.          to  6.25000D-02
C                                        with weighted error   5.61E-17
C                                         log weighted error  16.25
C                               significant figures required  14.97
C                                    decimal places required  16.91
C
C Series for BTH1       on the interval  0.          to  6.25000D-02
C                                        with weighted error   4.10E-17
C                                         log weighted error  16.39
C                               significant figures required  15.96
C                                    decimal places required  17.08
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BESJ1, CSEVL, INITS, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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***END PROLOGUE  BESY1
      DIMENSION BY1CS(14), BM1CS(21), BTH1CS(24)
      LOGICAL FIRST
	EXTERNAL BESJ1
      SAVE BY1CS, BM1CS, BTH1CS, TWODPI, PI4,
     1 NTY1, NTM1, NTTH1, XMIN, XSML, XMAX, FIRST
      DATA BY1CS( 1) /    .0320804710 0611908629E0 /
      DATA BY1CS( 2) /   1.2627078974 33500450E0 /
      DATA BY1CS( 3) /    .0064999618 9992317500E0 /
      DATA BY1CS( 4) /   -.0893616452 8860504117E0 /
      DATA BY1CS( 5) /    .0132508812 2175709545E0 /
      DATA BY1CS( 6) /   -.0008979059 1196483523E0 /
      DATA BY1CS( 7) /    .0000364736 1487958306E0 /
      DATA BY1CS( 8) /   -.0000010013 7438166600E0 /
      DATA BY1CS( 9) /    .0000000199 4539657390E0 /
      DATA BY1CS(10) /   -.0000000003 0230656018E0 /
      DATA BY1CS(11) /    .0000000000 0360987815E0 /
      DATA BY1CS(12) /   -.0000000000 0003487488E0 /
      DATA BY1CS(13) /    .0000000000 0000027838E0 /
      DATA BY1CS(14) /   -.0000000000 0000000186E0 /
      DATA BM1CS( 1) /    .1047362510 931285E0 /
      DATA BM1CS( 2) /    .0044244389 3702345E0 /
      DATA BM1CS( 3) /   -.0000566163 9504035E0 /
      DATA BM1CS( 4) /    .0000023134 9417339E0 /
      DATA BM1CS( 5) /   -.0000001737 7182007E0 /
      DATA BM1CS( 6) /    .0000000189 3209930E0 /
      DATA BM1CS( 7) /   -.0000000026 5416023E0 /
      DATA BM1CS( 8) /    .0000000004 4740209E0 /
      DATA BM1CS( 9) /   -.0000000000 8691795E0 /
      DATA BM1CS(10) /    .0000000000 1891492E0 /
      DATA BM1CS(11) /   -.0000000000 0451884E0 /
      DATA BM1CS(12) /    .0000000000 0116765E0 /
      DATA BM1CS(13) /   -.0000000000 0032265E0 /
      DATA BM1CS(14) /    .0000000000 0009450E0 /
      DATA BM1CS(15) /   -.0000000000 0002913E0 /
      DATA BM1CS(16) /    .0000000000 0000939E0 /
      DATA BM1CS(17) /   -.0000000000 0000315E0 /
      DATA BM1CS(18) /    .0000000000 0000109E0 /
      DATA BM1CS(19) /   -.0000000000 0000039E0 /
      DATA BM1CS(20) /    .0000000000 0000014E0 /
      DATA BM1CS(21) /   -.0000000000 0000005E0 /
      DATA BTH1CS( 1) /    .7406014102 6313850E0 /
      DATA BTH1CS( 2) /   -.0045717556 59637690E0 /
      DATA BTH1CS( 3) /    .0001198185 10964326E0 /
      DATA BTH1CS( 4) /   -.0000069645 61891648E0 /
      DATA BTH1CS( 5) /    .0000006554 95621447E0 /
      DATA BTH1CS( 6) /   -.0000000840 66228945E0 /
      DATA BTH1CS( 7) /    .0000000133 76886564E0 /
      DATA BTH1CS( 8) /   -.0000000024 99565654E0 /
      DATA BTH1CS( 9) /    .0000000005 29495100E0 /
      DATA BTH1CS(10) /   -.0000000001 24135944E0 /
      DATA BTH1CS(11) /    .0000000000 31656485E0 /
      DATA BTH1CS(12) /   -.0000000000 08668640E0 /
      DATA BTH1CS(13) /    .0000000000 02523758E0 /
      DATA BTH1CS(14) /   -.0000000000 00775085E0 /
      DATA BTH1CS(15) /    .0000000000 00249527E0 /
      DATA BTH1CS(16) /   -.0000000000 00083773E0 /
      DATA BTH1CS(17) /    .0000000000 00029205E0 /
      DATA BTH1CS(18) /   -.0000000000 00010534E0 /
      DATA BTH1CS(19) /    .0000000000 00003919E0 /
      DATA BTH1CS(20) /   -.0000000000 00001500E0 /
      DATA BTH1CS(21) /    .0000000000 00000589E0 /
      DATA BTH1CS(22) /   -.0000000000 00000237E0 /
      DATA BTH1CS(23) /    .0000000000 00000097E0 /
      DATA BTH1CS(24) /   -.0000000000 00000040E0 /
      DATA TWODPI / 0.6366197723 6758134E0 /
      DATA PI4 / 0.7853981633 9744831E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BESY1
      IF (FIRST) THEN
         NTY1 = INITS (BY1CS, 14, 0.1*R1MACH(3))
         NTM1 = INITS (BM1CS, 21, 0.1*R1MACH(3))
         NTTH1 = INITS (BTH1CS, 24, 0.1*R1MACH(3))
C
         XMIN = 1.571*EXP ( MAX(LOG(R1MACH(1)), -LOG(R1MACH(2)))+.01)
         XSML = SQRT (4.0*R1MACH(3))
         XMAX = 1.0/R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.) CALL XERMSG ('SLATEC', 'BESY1',
     +   'X IS ZERO OR NEGATIVE', 1, 2)
      IF (X.GT.4.0) GO TO 20
C
      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'BESY1',
     +   'X SO SMALL Y1 OVERFLOWS', 3, 2)
      Y = 0.
      IF (X.GT.XSML) Y = X*X
      BESY1 = TWODPI*LOG(0.5*X)*BESJ1(X) +
     1  (0.5 + CSEVL (.125*Y-1., BY1CS, NTY1))/X
      RETURN
C
 20   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BESY1',
     +   'NO PRECISION BECAUSE X IS BIG', 2, 2)
C
      Z = 32.0/X**2 - 1.0
      AMPL = (0.75 + CSEVL (Z, BM1CS, NTM1)) / SQRT(X)
      THETA = X - 3.0*PI4 + CSEVL (Z, BTH1CS, NTTH1) / X
      BESY1 = AMPL * SIN (THETA)
C
      RETURN
      END
*DECK BESYNU
      SUBROUTINE BESYNU (X, FNU, N, Y)
C***BEGIN PROLOGUE  BESYNU
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BESY
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BESYNU-S, DBSYNU-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BESYNU computes N member sequences of Y Bessel functions
C         Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and
C         positive X. Equations of the references are implemented on
C         small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X).
C         Forward recursion with the three term recursion relation
C         generates higher orders FNU+I-1, I=1,...,N.
C
C         To start the recursion FNU is normalized to the interval
C         -0.5.LE.DNU.LT.0.5. A special form of the power series is
C         implemented on 0.LT.X.LE.X1 while the Miller algorithm for the
C         K Bessel function in terms of the confluent hypergeometric
C         function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1.LT.X.LE.X
C         Here I is the complex number SQRT(-1.).
C         For X.GT.X2, the asymptotic expansion for large X is used.
C         When FNU is a half odd integer, a special formula for
C         DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion.
C
C         BESYNU assumes that a significant digit SINH(X) function is
C         available.
C
C     Description of Arguments
C
C         Input
C           X      - X.GT.0.0E0
C           FNU    - Order of initial Y function, FNU.GE.0.0E0
C           N      - Number of members of the sequence, N.GE.1
C
C         Output
C           Y      - A vector whose first N components contain values
C                    for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N.
C
C     Error Conditions
C         Improper input arguments - a fatal error
C         Overflow - a fatal error
C
C***SEE ALSO  BESY
C***REFERENCES  N. M. Temme, On the numerical evaluation of the ordinary
C                 Bessel function of the second kind, Journal of
C                 Computational Physics 21, (1976), pp. 343-350.
C               N. M. Temme, On the numerical evaluation of the modified
C                 Bessel function of the third kind, Journal of
C                 Computational Physics 19, (1975), pp. 324-337.
C***ROUTINES CALLED  GAMMA, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800501  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (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   900727  Added EXTERNAL statement.  (WRB)
C   910408  Updated the AUTHOR and REFERENCES sections.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BESYNU
C
      INTEGER I, INU, J, K, KK, N, NN
      REAL A, AK, ARG, A1, A2, BK, CB, CBK, CC, CCK, CK, COEF, CPT,
     1 CP1, CP2, CS, CS1, CS2, CX, DNU, DNU2, ETEST, ETX, F, FC, FHS,
     2 FK, FKS, FLRX, FMU, FN, FNU, FX, G, G1, G2, HPI, P, PI, PT, Q,
     3 RB, RBK, RCK, RELB, RPT, RP1, RP2, RS, RS1, RS2, RTHPI, RX, S,
     4 SA, SB, SMU, SS, ST, S1, S2, TB, TM, TOL, T1, T2, X, X1, X2, Y
      DIMENSION A(120), RB(120), CB(120), Y(*), CC(8)
      REAL GAMMA, R1MACH
      EXTERNAL GAMMA
      SAVE X1, X2, PI, RTHPI, HPI, CC
      DATA X1, X2 / 3.0E0, 20.0E0 /
      DATA PI,RTHPI        / 3.14159265358979E+00, 7.97884560802865E-01/
      DATA HPI             / 1.57079632679490E+00/
      DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)
     1                     / 5.77215664901533E-01,-4.20026350340952E-02,
     2-4.21977345555443E-02, 7.21894324666300E-03,-2.15241674114900E-04,
     3-2.01348547807000E-05, 1.13302723200000E-06, 6.11609500000000E-09/
C***FIRST EXECUTABLE STATEMENT  BESYNU
      AK = R1MACH(3)
      TOL = MAX(AK,1.0E-15)
      IF (X.LE.0.0E0) GO TO 270
      IF (FNU.LT.0.0E0) GO TO 280
      IF (N.LT.1) GO TO 290
      RX = 2.0E0/X
      INU = INT(FNU+0.5E0)
      DNU = FNU - INU
      IF (ABS(DNU).EQ.0.5E0) GO TO 260
      DNU2 = 0.0E0
      IF (ABS(DNU).LT.TOL) GO TO 10
      DNU2 = DNU*DNU
   10 CONTINUE
      IF (X.GT.X1) GO TO 120
C
C     SERIES FOR X.LE.X1
C
      A1 = 1.0E0 - DNU
      A2 = 1.0E0 + DNU
      T1 = 1.0E0/GAMMA(A1)
      T2 = 1.0E0/GAMMA(A2)
      IF (ABS(DNU).GT.0.1E0) GO TO 40
C     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
      S = CC(1)
      AK = 1.0E0
      DO 20 K=2,8
        AK = AK*DNU2
        TM = CC(K)*AK
        S = S + TM
        IF (ABS(TM).LT.TOL) GO TO 30
   20 CONTINUE
   30 G1 = -(S+S)
      GO TO 50
   40 CONTINUE
      G1 = (T1-T2)/DNU
   50 CONTINUE
      G2 = T1 + T2
      SMU = 1.0E0
      FC = 1.0E0/PI
      FLRX = LOG(RX)
      FMU = DNU*FLRX
      TM = 0.0E0
      IF (DNU.EQ.0.0E0) GO TO 60
      TM = SIN(DNU*HPI)/DNU
      TM = (DNU+DNU)*TM*TM
      FC = DNU/SIN(DNU*PI)
      IF (FMU.NE.0.0E0) SMU = SINH(FMU)/FMU
   60 CONTINUE
      F = FC*(G1*COSH(FMU)+G2*FLRX*SMU)
      FX = EXP(FMU)
      P = FC*T1*FX
      Q = FC*T2/FX
      G = F + TM*Q
      AK = 1.0E0
      CK = 1.0E0
      BK = 1.0E0
      S1 = G
      S2 = P
      IF (INU.GT.0 .OR. N.GT.1) GO TO 90
      IF (X.LT.TOL) GO TO 80
      CX = X*X*0.25E0
   70 CONTINUE
      F = (AK*F+P+Q)/(BK-DNU2)
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      G = F + TM*Q
      CK = -CK*CX/AK
      T1 = CK*G
      S1 = S1 + T1
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      S = ABS(T1)/(1.0E0+ABS(S1))
      IF (S.GT.TOL) GO TO 70
   80 CONTINUE
      Y(1) = -S1
      RETURN
   90 CONTINUE
      IF (X.LT.TOL) GO TO 110
      CX = X*X*0.25E0
  100 CONTINUE
      F = (AK*F+P+Q)/(BK-DNU2)
      P = P/(AK-DNU)
      Q = Q/(AK+DNU)
      G = F + TM*Q
      CK = -CK*CX/AK
      T1 = CK*G
      S1 = S1 + T1
      T2 = CK*(P-AK*G)
      S2 = S2 + T2
      BK = BK + AK + AK + 1.0E0
      AK = AK + 1.0E0
      S = ABS(T1)/(1.0E0+ABS(S1)) + ABS(T2)/(1.0E0+ABS(S2))
      IF (S.GT.TOL) GO TO 100
  110 CONTINUE
      S2 = -S2*RX
      S1 = -S1
      GO TO 160
  120 CONTINUE
      COEF = RTHPI/SQRT(X)
      IF (X.GT.X2) GO TO 210
C
C     MILLER ALGORITHM FOR X1.LT.X.LE.X2
C
      ETEST = COS(PI*DNU)/(PI*X*TOL)
      FKS = 1.0E0
      FHS = 0.25E0
      FK = 0.0E0
      RCK = 2.0E0
      CCK = X + X
      RP1 = 0.0E0
      CP1 = 0.0E0
      RP2 = 1.0E0
      CP2 = 0.0E0
      K = 0
  130 CONTINUE
      K = K + 1
      FK = FK + 1.0E0
      AK = (FHS-DNU2)/(FKS+FK)
      PT = FK + 1.0E0
      RBK = RCK/PT
      CBK = CCK/PT
      RPT = RP2
      CPT = CP2
      RP2 = RBK*RPT - CBK*CPT - AK*RP1
      CP2 = CBK*RPT + RBK*CPT - AK*CP1
      RP1 = RPT
      CP1 = CPT
      RB(K) = RBK
      CB(K) = CBK
      A(K) = AK
      RCK = RCK + 2.0E0
      FKS = FKS + FK + FK + 1.0E0
      FHS = FHS + FK + FK
      PT = MAX(ABS(RP1),ABS(CP1))
      FC = (RP1/PT)**2 + (CP1/PT)**2
      PT = PT*SQRT(FC)*FK
      IF (ETEST.GT.PT) GO TO 130
      KK = K
      RS = 1.0E0
      CS = 0.0E0
      RP1 = 0.0E0
      CP1 = 0.0E0
      RP2 = 1.0E0
      CP2 = 0.0E0
      DO 140 I=1,K
        RPT = RP2
        CPT = CP2
        RP2 = (RB(KK)*RPT-CB(KK)*CPT-RP1)/A(KK)
        CP2 = (CB(KK)*RPT+RB(KK)*CPT-CP1)/A(KK)
        RP1 = RPT
        CP1 = CPT
        RS = RS + RP2
        CS = CS + CP2
        KK = KK - 1
  140 CONTINUE
      PT = MAX(ABS(RS),ABS(CS))
      FC = (RS/PT)**2 + (CS/PT)**2
      PT = PT*SQRT(FC)
      RS1 = (RP2*(RS/PT)+CP2*(CS/PT))/PT
      CS1 = (CP2*(RS/PT)-RP2*(CS/PT))/PT
      FC = HPI*(DNU-0.5E0) - X
      P = COS(FC)
      Q = SIN(FC)
      S1 = (CS1*Q-RS1*P)*COEF
      IF (INU.GT.0 .OR. N.GT.1) GO TO 150
      Y(1) = S1
      RETURN
  150 CONTINUE
      PT = MAX(ABS(RP2),ABS(CP2))
      FC = (RP2/PT)**2 + (CP2/PT)**2
      PT = PT*SQRT(FC)
      RPT = DNU + 0.5E0 - (RP1*(RP2/PT)+CP1*(CP2/PT))/PT
      CPT = X - (CP1*(RP2/PT)-RP1*(CP2/PT))/PT
      CS2 = CS1*CPT - RS1*RPT
      RS2 = RPT*CS1 + RS1*CPT
      S2 = (RS2*Q+CS2*P)*COEF/X
C
C     FORWARD RECURSION ON THE THREE TERM RECURSION RELATION
C
  160 CONTINUE
      CK = (DNU+DNU+2.0E0)/X
      IF (N.EQ.1) INU = INU - 1
      IF (INU.GT.0) GO TO 170
      IF (N.GT.1) GO TO 190
      S1 = S2
      GO TO 190
  170 CONTINUE
      DO 180 I=1,INU
        ST = S2
        S2 = CK*S2 - S1
        S1 = ST
        CK = CK + RX
  180 CONTINUE
      IF (N.EQ.1) S1 = S2
  190 CONTINUE
      Y(1) = S1
      IF (N.EQ.1) RETURN
      Y(2) = S2
      IF (N.EQ.2) RETURN
      DO 200 I=3,N
        Y(I) = CK*Y(I-1) - Y(I-2)
        CK = CK + RX
  200 CONTINUE
      RETURN
C
C     ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2
C
  210 CONTINUE
      NN = 2
      IF (INU.EQ.0 .AND. N.EQ.1) NN = 1
      DNU2 = DNU + DNU
      FMU = 0.0E0
      IF (ABS(DNU2).LT.TOL) GO TO 220
      FMU = DNU2*DNU2
  220 CONTINUE
      ARG = X - HPI*(DNU+0.5E0)
      SA = SIN(ARG)
      SB = COS(ARG)
      ETX = 8.0E0*X
      DO 250 K=1,NN
        S1 = S2
        T2 = (FMU-1.0E0)/ETX
        SS = T2
        RELB = TOL*ABS(T2)
        T1 = ETX
        S = 1.0E0
        FN = 1.0E0
        AK = 0.0E0
        DO 230 J=1,13
          T1 = T1 + ETX
          AK = AK + 8.0E0
          FN = FN + AK
          T2 = -T2*(FMU-FN)/T1
          S = S + T2
          T1 = T1 + ETX
          AK = AK + 8.0E0
          FN = FN + AK
          T2 = T2*(FMU-FN)/T1
          SS = SS + T2
          IF (ABS(T2).LE.RELB) GO TO 240
  230   CONTINUE
  240   S2 = COEF*(S*SA+SS*SB)
        FMU = FMU + 8.0E0*DNU + 4.0E0
        TB = SA
        SA = -SB
        SB = TB
  250 CONTINUE
      IF (NN.GT.1) GO TO 160
      S1 = S2
      GO TO 190
C
C     FNU=HALF ODD INTEGER CASE
C
  260 CONTINUE
      COEF = RTHPI/SQRT(X)
      S1 = COEF*SIN(X)
      S2 = -COEF*COS(X)
      GO TO 160
C
C
  270 CALL XERMSG ('SLATEC', 'BESYNU', 'X NOT GREATER THAN ZERO', 2, 1)
      RETURN
  280 CALL XERMSG ('SLATEC', 'BESYNU', 'FNU NOT ZERO OR POSITIVE', 2,
     +   1)
      RETURN
  290 CALL XERMSG ('SLATEC', 'BESYNU', 'N NOT GREATER THAN 0', 2, 1)
      RETURN
      END
*DECK BETA
      FUNCTION BETA (A, B)
C***BEGIN PROLOGUE  BETA
C***PURPOSE  Compute the complete Beta function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7B
C***TYPE      SINGLE PRECISION (BETA-S, DBETA-D, CBETA-C)
C***KEYWORDS  COMPLETE BETA FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BETA computes the complete beta function.
C
C Input Parameters:
C       A   real and positive
C       B   real and positive
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALBETA, GAMLIM, GAMMA, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  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   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  BETA
      EXTERNAL GAMMA
      SAVE XMAX, ALNSML
      DATA XMAX, ALNSML /0., 0./
C***FIRST EXECUTABLE STATEMENT  BETA
      IF (ALNSML.NE.0.0) GO TO 10
      CALL GAMLIM (XMIN, XMAX)
      ALNSML = LOG(R1MACH(1))
C
 10   IF (A .LE. 0. .OR. B .LE. 0.) CALL XERMSG ('SLATEC', 'BETA',
     +   'BOTH ARGUMENTS MUST BE GT 0', 2, 2)
C
      IF (A+B.LT.XMAX) BETA = GAMMA(A) * GAMMA(B) / GAMMA(A+B)
      IF (A+B.LT.XMAX) RETURN
C
      BETA = ALBETA (A, B)
      IF (BETA .LT. ALNSML) CALL XERMSG ('SLATEC', 'BETA',
     +   'A AND/OR B SO BIG BETA UNDERFLOWS', 1, 2)
C
      BETA = EXP (BETA)
C
      RETURN
      END
*DECK BETAI
      REAL FUNCTION BETAI (X, PIN, QIN)
C***BEGIN PROLOGUE  BETAI
C***PURPOSE  Calculate the incomplete Beta function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7F
C***TYPE      SINGLE PRECISION (BETAI-S, DBETAI-D)
C***KEYWORDS  FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C   BETAI calculates the REAL incomplete beta function.
C
C   The incomplete beta function ratio is the probability that a
C   random variable from a beta distribution having parameters PIN and
C   QIN will be less than or equal to X.
C
C     -- Input Arguments -- All arguments are REAL.
C   X      upper limit of integration.  X must be in (0,1) inclusive.
C   PIN    first beta distribution parameter.  PIN must be .GT. 0.0.
C   QIN    second beta distribution parameter.  QIN must be .GT. 0.0.
C
C***REFERENCES  Nancy E. Bosten and E. L. Battiste, Remark on Algorithm
C                 179, Communications of the ACM 17, 3 (March 1974),
C                 pp. 156.
C***ROUTINES CALLED  ALBETA, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  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   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  BETAI
      LOGICAL FIRST
      SAVE EPS, ALNEPS, SML, ALNSML, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BETAI
      IF (FIRST) THEN
         EPS = R1MACH(3)
         ALNEPS = LOG(EPS)
         SML = R1MACH(1)
         ALNSML = LOG(SML)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 0. .OR. X .GT. 1.0) CALL XERMSG ('SLATEC', 'BETAI',
     +   'X IS NOT IN THE RANGE (0,1)', 1, 2)
      IF (PIN .LE. 0. .OR. QIN .LE. 0.) CALL XERMSG ('SLATEC', 'BETAI',
     +   'P AND/OR Q IS LE ZERO', 2, 2)
C
      Y = X
      P = PIN
      Q = QIN
      IF (Q.LE.P .AND. X.LT.0.8) GO TO 20
      IF (X.LT.0.2) GO TO 20
      Y = 1.0 - Y
      P = QIN
      Q = PIN
C
 20   IF ((P+Q)*Y/(P+1.).LT.EPS) GO TO 80
C
C EVALUATE THE INFINITE SUM FIRST.
C TERM WILL EQUAL Y**P/BETA(PS,P) * (1.-PS)I * Y**I / FAC(I)
C
      PS = Q - AINT(Q)
      IF (PS.EQ.0.) PS = 1.0
      XB = P*LOG(Y) -  ALBETA(PS, P) - LOG(P)
      BETAI = 0.0
      IF (XB.LT.ALNSML) GO TO 40
C
      BETAI = EXP (XB)
      TERM = BETAI*P
      IF (PS.EQ.1.0) GO TO 40
C
      N = MAX (ALNEPS/LOG(Y), 4.0E0)
      DO 30 I=1,N
        TERM = TERM*(I-PS)*Y/I
        BETAI = BETAI + TERM/(P+I)
 30   CONTINUE
C
C NOW EVALUATE THE FINITE SUM, MAYBE.
C
 40   IF (Q.LE.1.0) GO TO 70
C
      XB = P*LOG(Y) + Q*LOG(1.0-Y) - ALBETA(P,Q) - LOG(Q)
      IB = MAX (XB/ALNSML, 0.0E0)
      TERM = EXP (XB - IB*ALNSML)
      C = 1.0/(1.0-Y)
      P1 = Q*C/(P+Q-1.)
C
      FINSUM = 0.0
      N = Q
      IF (Q.EQ.REAL(N)) N = N - 1
      DO 50 I=1,N
        IF (P1.LE.1.0 .AND. TERM/EPS.LE.FINSUM) GO TO 60
        TERM = (Q-I+1)*C*TERM/(P+Q-I)
C
        IF (TERM.GT.1.0) IB = IB - 1
        IF (TERM.GT.1.0) TERM = TERM*SML
C
        IF (IB.EQ.0) FINSUM = FINSUM + TERM
 50   CONTINUE
C
 60   BETAI = BETAI + FINSUM
 70   IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI
      BETAI = MAX (MIN (BETAI, 1.0), 0.0)
      RETURN
C
 80   BETAI = 0.0
      XB = P*LOG(MAX(Y,SML)) - LOG(P) - ALBETA(P,Q)
      IF (XB.GT.ALNSML .AND. Y.NE.0.) BETAI = EXP (XB)
      IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI
      RETURN
C
      END
*DECK BFQAD
      SUBROUTINE BFQAD (F, T, BCOEF, N, K, ID, X1, X2, TOL, QUAD, IERR,
     +   WORK)
C***BEGIN PROLOGUE  BFQAD
C***PURPOSE  Compute the integral of a product of a function and a
C            derivative of a B-spline.
C***LIBRARY   SLATEC
C***CATEGORY  H2A2A1, E3, K6
C***TYPE      SINGLE PRECISION (BFQAD-S, DBFQAD-D)
C***KEYWORDS  INTEGRAL OF B-SPLINE, QUADRATURE
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BFQAD computes the integral on (X1,X2) of a product of a
C         function F and the ID-th derivative of a K-th order B-spline,
C         using the B-representation (T,BCOEF,N,K).  (X1,X2) must be
C         a subinterval of T(K) .LE. X .le. T(N+1).  An integration
C         routine BSGQ8 (a modification
C         of GAUS8), integrates the product on sub-
C         intervals of (X1,X2) formed by included (distinct) knots.
C
C     Description of Arguments
C         Input
C           F      - external function of one argument for the
C                    integrand BF(X)=F(X)*BVALU(T,BCOEF,N,K,ID,X,INBV,
C                    WORK)
C           T      - knot array of length N+K
C           BCOEF  - coefficient array of length N
C           N      - length of coefficient array
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 in
C                    T(K) .LE. X .LE. T(N+1)
C           TOL    - desired accuracy for the quadrature, suggest
C                    10.*STOL .LT. TOL .LE. 0.1 where STOL is the single
C                    precision unit roundoff for the machine = R1MACH(4)
C
C         Output
C           QUAD   - integral of BF(X) on (X1,X2)
C           IERR   - a status code
C                    IERR=1  normal return
C                         2  some quadrature on (X1,X2) does not meet
C                            the requested tolerance.
C           WORK   - work vector of length 3*K
C
C     Error Conditions
C         X1 or X2 not in T(K) .LE. X .LE. T(N+1) is a fatal error.
C         TOL not greater than the single precision unit roundoff or
C         less than 0.1 is a fatal error.
C         Some quadrature fails to 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  BSGQ8, INTRV, R1MACH, 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  BFQAD
C
C
      INTEGER ID, IERR, IFLG, ILO, IL1, IL2, K, LEFT, MFLAG, N, NPK, NP1
      REAL A,AA,ANS,B,BB,BCOEF,Q,QUAD,T,TA,TB,TOL,WORK,WTOL, X1,
     1 X2
      REAL R1MACH, F
      DIMENSION T(*), BCOEF(*), WORK(*)
      EXTERNAL F
C***FIRST EXECUTABLE STATEMENT  BFQAD
      IERR = 1
      QUAD = 0.0E0
      IF(K.LT.1) GO TO 100
      IF(N.LT.K) GO TO 105
      IF(ID.LT.0 .OR. ID.GE.K) GO TO 110
      WTOL = R1MACH(4)
      IF (TOL.LT.WTOL .OR. TOL.GT.0.1E0) GO TO 30
      AA = MIN(X1,X2)
      BB = MAX(X1,X2)
      IF (AA.LT.T(K)) GO TO 20
      NP1 = N + 1
      IF (BB.GT.T(NP1)) GO TO 20
      IF (AA.EQ.BB) RETURN
      NPK = N + K
C
      ILO = 1
      CALL INTRV(T, NPK, AA, ILO, IL1, MFLAG)
      CALL INTRV(T, NPK, BB, ILO, IL2, MFLAG)
      IF (IL2.GE.NP1) IL2 = N
      INBV = 1
      Q = 0.0E0
      DO 10 LEFT=IL1,IL2
        TA = T(LEFT)
        TB = T(LEFT+1)
        IF (TA.EQ.TB) GO TO 10
        A = MAX(AA,TA)
        B = MIN(BB,TB)
        CALL BSGQ8(F,T,BCOEF,N,K,ID,A,B,INBV,TOL,ANS,IFLG,WORK)
        IF (IFLG.GT.1) IERR = 2
        Q = Q + ANS
   10 CONTINUE
      IF (X1.GT.X2) Q = -Q
      QUAD = Q
      RETURN
C
C
   20 CONTINUE
      CALL XERMSG ('SLATEC', 'BFQAD',
     +   'X1 OR X2 OR BOTH DO NOT SATISFY T(K).LE.X.LE.T(N+1)', 2, 1)
      RETURN
   30 CONTINUE
      CALL XERMSG ('SLATEC', 'BFQAD',
     +   'TOL IS LESS THAN THE SINGLE PRECISION TOLERANCE OR ' //
     +   'GREATER THAN 0.1', 2, 1)
      RETURN
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'BFQAD', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'BFQAD', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'BFQAD',
     +   'ID DOES NOT SATISFY 0 .LE. ID .LT. K', 2, 1)
      RETURN
      END
*DECK BI
      FUNCTION BI (X)
C***BEGIN PROLOGUE  BI
C***PURPOSE  Evaluate the Bairy function (the Airy function of the
C            second kind).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      SINGLE PRECISION (BI-S, DBI-D)
C***KEYWORDS  BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BI(X) calculates the Airy function of the second kind for real
C argument X.
C
C Series for BIF        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   1.88E-19
C                                         log weighted error  18.72
C                               significant figures required  17.74
C                                    decimal places required  19.20
C
C Series for BIG        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   2.61E-17
C                                         log weighted error  16.58
C                               significant figures required  15.17
C                                    decimal places required  17.03
C
C Series for BIF2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.11E-17
C                                         log weighted error  16.95
C                        approx significant figures required  16.5
C                                    decimal places required  17.45
C
C Series for BIG2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.19E-18
C                                         log weighted error  17.92
C                        approx significant figures required  17.2
C                                    decimal places required  18.42
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  BIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  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***END PROLOGUE  BI
      DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10)
      LOGICAL FIRST
      SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, NBIF, NBIG, NBIF2,
     1 NBIG2, X3SML, XMAX, FIRST
      DATA BIFCS( 1) /   -.0167302164 7198664948E0 /
      DATA BIFCS( 2) /    .1025233583 424944561E0 /
      DATA BIFCS( 3) /    .0017083092 5073815165E0 /
      DATA BIFCS( 4) /    .0000118625 4546774468E0 /
      DATA BIFCS( 5) /    .0000000449 3290701779E0 /
      DATA BIFCS( 6) /    .0000000001 0698207143E0 /
      DATA BIFCS( 7) /    .0000000000 0017480643E0 /
      DATA BIFCS( 8) /    .0000000000 0000020810E0 /
      DATA BIFCS( 9) /    .0000000000 0000000018E0 /
      DATA BIGCS( 1) /    .0224662232 4857452E0 /
      DATA BIGCS( 2) /    .0373647754 5301955E0 /
      DATA BIGCS( 3) /    .0004447621 8957212E0 /
      DATA BIGCS( 4) /    .0000024708 0756363E0 /
      DATA BIGCS( 5) /    .0000000079 1913533E0 /
      DATA BIGCS( 6) /    .0000000000 1649807E0 /
      DATA BIGCS( 7) /    .0000000000 0002411E0 /
      DATA BIGCS( 8) /    .0000000000 0000002E0 /
      DATA BIF2CS( 1) /   0.0998457269 3816041E0 /
      DATA BIF2CS( 2) /    .4786249778 63005538E0 /
      DATA BIF2CS( 3) /    .0251552119 604330118E0 /
      DATA BIF2CS( 4) /    .0005820693 885232645E0 /
      DATA BIF2CS( 5) /    .0000074997 659644377E0 /
      DATA BIF2CS( 6) /    .0000000613 460287034E0 /
      DATA BIF2CS( 7) /    .0000000003 462753885E0 /
      DATA BIF2CS( 8) /    .0000000000 014288910E0 /
      DATA BIF2CS( 9) /    .0000000000 000044962E0 /
      DATA BIF2CS(10) /    .0000000000 000000111E0 /
      DATA BIG2CS( 1) /    .0333056621 45514340E0 /
      DATA BIG2CS( 2) /    .1613092151 23197068E0 /
      DATA BIG2CS( 3) /    .0063190073 096134286E0 /
      DATA BIG2CS( 4) /    .0001187904 568162517E0 /
      DATA BIG2CS( 5) /    .0000013045 345886200E0 /
      DATA BIG2CS( 6) /    .0000000093 741259955E0 /
      DATA BIG2CS( 7) /    .0000000000 474580188E0 /
      DATA BIG2CS( 8) /    .0000000000 001783107E0 /
      DATA BIG2CS( 9) /    .0000000000 000005167E0 /
      DATA BIG2CS(10) /    .0000000000 000000011E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BI
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NBIF  = INITS (BIFCS , 9, ETA)
         NBIG  = INITS (BIGCS , 8, ETA)
         NBIF2 = INITS (BIF2CS, 10, ETA)
         NBIG2 = INITS (BIG2CS, 10, ETA)
C
         X3SML = ETA**0.3333
         XMAX = (1.5*LOG(R1MACH(2)))**0.6666
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-1.0)) GO TO 20
      CALL R9AIMP (X, XM, THETA)
      BI = XM * SIN(THETA)
      RETURN
C
 20   IF (X.GT.1.0) GO TO 30
      Z = 0.0
      IF (ABS(X).GT.X3SML) Z = X**3
      BI = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 +
     1  CSEVL (Z, BIGCS, NBIG))
      RETURN
C
 30   IF (X.GT.2.0) GO TO 40
      Z = (2.0*X**3 - 9.0) / 7.0
      BI = 1.125 + CSEVL (Z, BIF2CS, NBIF2) + X*(0.625 +
     1  CSEVL (Z, BIG2CS, NBIG2))
      RETURN
C
 40   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'BI',
     +   'X SO BIG THAT BI OVERFLOWS', 1, 2)
C
      BI = BIE(X) * EXP(2.0*X*SQRT(X)/3.0)
      RETURN
C
      END
*DECK BIE
      FUNCTION BIE (X)
C***BEGIN PROLOGUE  BIE
C***PURPOSE  Calculate the Bairy function for a negative argument and an
C            exponentially scaled Bairy function for a non-negative
C            argument.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      SINGLE PRECISION (BIE-S, DBIE-D)
C***KEYWORDS  BAIRY FUNCTION, EXPONENTIALLY SCALED, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate BI(X) for X .LE. 0  and  BI(X)*EXP(ZETA)  where
C ZETA = 2/3 * X**(3/2)  for X .GE. 0.0
C
C Series for BIF        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   1.88E-19
C                                         log weighted error  18.72
C                               significant figures required  17.74
C                                    decimal places required  19.20
C
C Series for BIG        on the interval -1.00000D+00 to  1.00000D+00
C                                        with weighted error   2.61E-17
C                                         log weighted error  16.58
C                               significant figures required  15.17
C                                    decimal places required  17.03
C
C Series for BIF2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.11E-17
C                                         log weighted error  16.95
C                        approx significant figures required  16.5
C                                    decimal places required  17.45
C
C Series for BIG2       on the interval  1.00000D+00 to  8.00000D+00
C                                        with weighted error   1.19E-18
C                                         log weighted error  17.92
C                        approx significant figures required  17.2
C                                    decimal places required  18.42
C
C Series for BIP        on the interval  1.25000D-01 to  3.53553D-01
C                                        with weighted error   1.91E-17
C                                         log weighted error  16.72
C                               significant figures required  15.35
C                                    decimal places required  17.41
C
C Series for BIP2       on the interval  0.          to  1.25000D-01
C                                        with weighted error   1.05E-18
C                                         log weighted error  17.98
C                               significant figures required  16.74
C                                    decimal places required  18.71
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH, R9AIMP
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890206  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  BIE
      LOGICAL FIRST
      DIMENSION BIFCS(9), BIGCS(8), BIF2CS(10), BIG2CS(10), BIPCS(24),
     1  BIP2CS(29)
      SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, BIPCS, BIP2CS, ATR, BTR,
     1 NBIF, NBIG, NBIF2, NBIG2, NBIP, NBIP2, X3SML, X32SML, XBIG, FIRST
      DATA BIFCS( 1) /   -.0167302164 7198664948E0 /
      DATA BIFCS( 2) /    .1025233583 424944561E0 /
      DATA BIFCS( 3) /    .0017083092 5073815165E0 /
      DATA BIFCS( 4) /    .0000118625 4546774468E0 /
      DATA BIFCS( 5) /    .0000000449 3290701779E0 /
      DATA BIFCS( 6) /    .0000000001 0698207143E0 /
      DATA BIFCS( 7) /    .0000000000 0017480643E0 /
      DATA BIFCS( 8) /    .0000000000 0000020810E0 /
      DATA BIFCS( 9) /    .0000000000 0000000018E0 /
      DATA BIGCS( 1) /    .0224662232 4857452E0 /
      DATA BIGCS( 2) /    .0373647754 5301955E0 /
      DATA BIGCS( 3) /    .0004447621 8957212E0 /
      DATA BIGCS( 4) /    .0000024708 0756363E0 /
      DATA BIGCS( 5) /    .0000000079 1913533E0 /
      DATA BIGCS( 6) /    .0000000000 1649807E0 /
      DATA BIGCS( 7) /    .0000000000 0002411E0 /
      DATA BIGCS( 8) /    .0000000000 0000002E0 /
      DATA BIF2CS( 1) /   0.0998457269 3816041E0 /
      DATA BIF2CS( 2) /    .4786249778 63005538E0 /
      DATA BIF2CS( 3) /    .0251552119 604330118E0 /
      DATA BIF2CS( 4) /    .0005820693 885232645E0 /
      DATA BIF2CS( 5) /    .0000074997 659644377E0 /
      DATA BIF2CS( 6) /    .0000000613 460287034E0 /
      DATA BIF2CS( 7) /    .0000000003 462753885E0 /
      DATA BIF2CS( 8) /    .0000000000 014288910E0 /
      DATA BIF2CS( 9) /    .0000000000 000044962E0 /
      DATA BIF2CS(10) /    .0000000000 000000111E0 /
      DATA BIG2CS( 1) /    .0333056621 45514340E0 /
      DATA BIG2CS( 2) /    .1613092151 23197068E0 /
      DATA BIG2CS( 3) /    .0063190073 096134286E0 /
      DATA BIG2CS( 4) /    .0001187904 568162517E0 /
      DATA BIG2CS( 5) /    .0000013045 345886200E0 /
      DATA BIG2CS( 6) /    .0000000093 741259955E0 /
      DATA BIG2CS( 7) /    .0000000000 474580188E0 /
      DATA BIG2CS( 8) /    .0000000000 001783107E0 /
      DATA BIG2CS( 9) /    .0000000000 000005167E0 /
      DATA BIG2CS(10) /    .0000000000 000000011E0 /
      DATA BIPCS( 1) /   -.0832204747 7943447E0 /
      DATA BIPCS( 2) /    .0114611892 7371174E0 /
      DATA BIPCS( 3) /    .0004289644 0718911E0 /
      DATA BIPCS( 4) /   -.0001490663 9379950E0 /
      DATA BIPCS( 5) /   -.0000130765 9726787E0 /
      DATA BIPCS( 6) /    .0000063275 9839610E0 /
      DATA BIPCS( 7) /   -.0000004222 6696982E0 /
      DATA BIPCS( 8) /   -.0000001914 7186298E0 /
      DATA BIPCS( 9) /    .0000000645 3106284E0 /
      DATA BIPCS(10) /   -.0000000078 4485467E0 /
      DATA BIPCS(11) /   -.0000000009 6077216E0 /
      DATA BIPCS(12) /    .0000000007 0004713E0 /
      DATA BIPCS(13) /   -.0000000001 7731789E0 /
      DATA BIPCS(14) /    .0000000000 2272089E0 /
      DATA BIPCS(15) /    .0000000000 0165404E0 /
      DATA BIPCS(16) /   -.0000000000 0185171E0 /
      DATA BIPCS(17) /    .0000000000 0059576E0 /
      DATA BIPCS(18) /   -.0000000000 0012194E0 /
      DATA BIPCS(19) /    .0000000000 0001334E0 /
      DATA BIPCS(20) /    .0000000000 0000172E0 /
      DATA BIPCS(21) /   -.0000000000 0000145E0 /
      DATA BIPCS(22) /    .0000000000 0000049E0 /
      DATA BIPCS(23) /   -.0000000000 0000011E0 /
      DATA BIPCS(24) /    .0000000000 0000001E0 /
      DATA BIP2CS( 1) /   -.1135967375 85988679E0 /
      DATA BIP2CS( 2) /    .0041381473 947881595E0 /
      DATA BIP2CS( 3) /    .0001353470 622119332E0 /
      DATA BIP2CS( 4) /    .0000104273 166530153E0 /
      DATA BIP2CS( 5) /    .0000013474 954767849E0 /
      DATA BIP2CS( 6) /    .0000001696 537405438E0 /
      DATA BIP2CS( 7) /   -.0000000100 965008656E0 /
      DATA BIP2CS( 8) /   -.0000000167 291194937E0 /
      DATA BIP2CS( 9) /   -.0000000045 815364485E0 /
      DATA BIP2CS(10) /    .0000000003 736681366E0 /
      DATA BIP2CS(11) /    .0000000005 766930320E0 /
      DATA BIP2CS(12) /    .0000000000 621812650E0 /
      DATA BIP2CS(13) /   -.0000000000 632941202E0 /
      DATA BIP2CS(14) /   -.0000000000 149150479E0 /
      DATA BIP2CS(15) /    .0000000000 078896213E0 /
      DATA BIP2CS(16) /    .0000000000 024960513E0 /
      DATA BIP2CS(17) /   -.0000000000 012130075E0 /
      DATA BIP2CS(18) /   -.0000000000 003740493E0 /
      DATA BIP2CS(19) /    .0000000000 002237727E0 /
      DATA BIP2CS(20) /    .0000000000 000474902E0 /
      DATA BIP2CS(21) /   -.0000000000 000452616E0 /
      DATA BIP2CS(22) /   -.0000000000 000030172E0 /
      DATA BIP2CS(23) /    .0000000000 000091058E0 /
      DATA BIP2CS(24) /   -.0000000000 000009814E0 /
      DATA BIP2CS(25) /   -.0000000000 000016429E0 /
      DATA BIP2CS(26) /    .0000000000 000005533E0 /
      DATA BIP2CS(27) /    .0000000000 000002175E0 /
      DATA BIP2CS(28) /   -.0000000000 000001737E0 /
      DATA BIP2CS(29) /   -.0000000000 000000010E0 /
      DATA ATR / 8.750690570 8484345 E0 /
      DATA BTR / -2.093836321 356054 E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BIE
      IF (FIRST) THEN
         ETA = 0.1*R1MACH(3)
         NBIF = INITS (BIFCS, 9, ETA)
         NBIG = INITS (BIGCS, 8, ETA)
         NBIF2 = INITS (BIF2CS, 10, ETA)
         NBIG2 = INITS (BIG2CS, 10, ETA)
         NBIP  = INITS (BIPCS , 24, ETA)
         NBIP2 = INITS (BIP2CS, 29, ETA)
C
         X3SML = ETA**0.3333
         X32SML = 1.3104*X3SML**2
         XBIG = R1MACH(2)**0.6666
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-1.0)) GO TO 20
      CALL R9AIMP (X, XM, THETA)
      BIE = XM * SIN(THETA)
      RETURN
C
 20   IF (X.GT.1.0) GO TO 30
      Z = 0.0
      IF (ABS(X).GT.X3SML) Z = X**3
      BIE = 0.625 + CSEVL (Z, BIFCS, NBIF) + X*(0.4375 +
     1  CSEVL (Z, BIGCS, NBIG))
      IF (X.GT.X32SML) BIE = BIE * EXP(-2.0*X*SQRT(X)/3.0)
      RETURN
C
 30   IF (X.GT.2.0) GO TO 40
      Z = (2.0*X**3 - 9.0) / 7.0
      BIE = EXP(-2.0*X*SQRT(X)/3.0) * (1.125 + CSEVL (Z, BIF2CS, NBIF2)
     1  + X*(0.625 + CSEVL (Z, BIG2CS, NBIG2)) )
      RETURN
C
 40   IF (X.GT.4.0) GO TO 50
      SQRTX = SQRT(X)
      Z = ATR/(X*SQRTX) + BTR
      BIE = (0.625 + CSEVL (Z, BIPCS, NBIP)) / SQRT(SQRTX)
      RETURN
C
 50   SQRTX = SQRT(X)
      Z = -1.0
      IF (X.LT.XBIG) Z = 16.0/(X*SQRTX) - 1.0
      BIE = (0.625 + CSEVL (Z, BIP2CS, NBIP2))/SQRT(SQRTX)
      RETURN
C
      END
*DECK BINOM
      FUNCTION BINOM (N, M)
C***BEGIN PROLOGUE  BINOM
C***PURPOSE  Compute the binomial coefficients.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C1
C***TYPE      SINGLE PRECISION (BINOM-S, DBINOM-D)
C***KEYWORDS  BINOMIAL COEFFICIENTS, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C BINOM(N,M) calculates the binomial coefficient (N!)/((M!)*(N-M)!).
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  ALNREL, R1MACH, R9LGMC, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  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***END PROLOGUE  BINOM
      LOGICAL FIRST
      SAVE SQ2PIL, BILNMX, FINTMX, FIRST
      DATA SQ2PIL / 0.9189385332 0467274E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BINOM
      IF (FIRST) THEN
         BILNMX = LOG (R1MACH(2))
         FINTMX = 0.9/R1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      IF (N .LT. 0 .OR. M .LT. 0) CALL XERMSG ('SLATEC', 'BINOM',
     +   'N OR M LT ZERO', 1, 2)
      IF (N .LT. M) CALL XERMSG ('SLATEC', 'BINOM', 'N LT M', 2, 2)
C
      K = MIN (M, N-M)
      IF (K.GT.20) GO TO 30
      IF (K*LOG(AMAX0(N,1)).GT.BILNMX) GO TO 30
C
      BINOM = 1.
      IF (K.EQ.0) RETURN
C
      DO 20 I=1,K
        BINOM = BINOM * REAL(N-I+1)/I
 20   CONTINUE
C
      IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5)
      RETURN
C
C IF K.LT.9, APPROX IS NOT VALID AND ANSWER IS CLOSE TO THE OVERFLOW LIM
 30   IF (K .LT. 9) CALL XERMSG ('SLATEC', 'BINOM',
     +   'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2)
C
      XN = N + 1
      XK = K + 1
      XNK = N - K + 1
C
      CORR = R9LGMC(XN) - R9LGMC(XK) - R9LGMC(XNK)
      BINOM = XK*LOG(XNK/XK) - XN*ALNREL(-(XK-1.)/XN)
     1  - 0.5*LOG(XN*XNK/XK) + 1.0 - SQ2PIL + CORR
C
      IF (BINOM .GT. BILNMX) CALL XERMSG ('SLATEC', 'BINOM',
     +   'RESULT OVERFLOWS BECAUSE N AND/OR M TOO BIG', 3, 2)
C
      BINOM = EXP (BINOM)
      IF (BINOM.LT.FINTMX) BINOM = AINT (BINOM+0.5)
C
      RETURN
      END
*DECK BINT4
      SUBROUTINE BINT4 (X, Y, NDATA, IBCL, IBCR, FBCL, FBCR, KNTOPT, T,
     +   BCOEF, N, K, W)
C***BEGIN PROLOGUE  BINT4
C***PURPOSE  Compute the B-representation of a cubic spline
C            which interpolates given data.
C***LIBRARY   SLATEC
C***CATEGORY  E1A
C***TYPE      SINGLE PRECISION (BINT4-S, DBINT4-D)
C***KEYWORDS  B-SPLINE, CUBIC SPLINES, DATA FITTING, INTERPOLATION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BINT4 computes the B representation (T,BCOEF,N,K) of a
C         cubic spline (K=4) which interpolates data (X(I)),Y(I))),
C         I=1,NDATA.  Parameters IBCL, IBCR, FBCL, FBCR allow the
C         specification of the spline first or second derivative at
C         both X(1) and X(NDATA).  When this data is not specified
C         by the problem, it is common practice to use a natural
C         spline by setting second derivatives at X(1) and X(NDATA)
C         to zero (IBCL=IBCR=2,FBCL=FBCR=0.0).  The spline is defined on
C         T(4) .LE. X .LE. T(N+1) with (ordered) interior knots at X(I))
C         values where N=NDATA+2.  The knots T(1), T(2), T(3) lie to
C         the left of T(4)=X(1) and the knots T(N+2), T(N+3), T(N+4)
C         lie to the right of T(N+1)=X(NDATA) in increasing order.  If
C         no extrapolation outside (X(1),X(NDATA)) is anticipated, the
C         knots T(1)=T(2)=T(3)=T(4)=X(1) and T(N+2)=T(N+3)=T(N+4)=
C         T(N+1)=X(NDATA) can be specified by KNTOPT=1.  KNTOPT=2
C         selects a knot placement for T(1), T(2), T(3) to make the
C         first 7 knots symmetric about T(4)=X(1) and similarly for
C         T(N+2), T(N+3), T(N+4) about T(N+1)=X(NDATA).  KNTOPT=3
C         allows the user to make his own selection, in increasing
C         order, for T(1), T(2), T(3) to the left of X(1) and T(N+2),
C         T(N+3), T(N+4) to the right of X(NDATA) in the work array
C         W(1) through W(6).  In any case, the interpolation on
C         T(4) .LE. X .LE. T(N+1) by using function BVALU is unique
C         for given boundary conditions.
C
C     Description of Arguments
C         Input
C           X      - X vector of abscissae of length NDATA, distinct
C                    and in increasing order
C           Y      - Y vector of ordinates of length NDATA
C           NDATA  - number of data points, NDATA .GE. 2
C           IBCL   - selection parameter for left boundary condition
C                    IBCL = 1 constrain the first derivative at
C                             X(1) to FBCL
C                         = 2 constrain the second derivative at
C                             X(1) to FBCL
C           IBCR   - selection parameter for right boundary condition
C                    IBCR = 1 constrain first derivative at
C                             X(NDATA) to FBCR
C                    IBCR = 2 constrain second derivative at
C                             X(NDATA) to FBCR
C           FBCL   - left boundary values governed by IBCL
C           FBCR   - right boundary values governed by IBCR
C           KNTOPT - knot selection parameter
C                    KNTOPT = 1 sets knot multiplicity at T(4) and
C                               T(N+1) to 4
C                           = 2 sets a symmetric placement of knots
C                               about T(4) and T(N+1)
C                           = 3 sets TNP)=WNP) and T(N+1+I)=w(3+I),I=1,3
C                               where WNP),I=1,6 is supplied by the user
C           W      - work array of dimension at least 5*(NDATA+2)
C                    if KNTOPT=3, then W(1),W(2),W(3) are knot values to
C                    the left of X(1) and W(4),W(5),W(6) are knot
C                    values to the right of X(NDATA) in increasing
C                    order to be supplied by the user
C
C         Output
C           T      - knot array of length N+4
C           BCOEF  - B-spline coefficient array of length N
C           N      - number of coefficients, N=NDATA+2
C           K      - order of spline, K=4
C
C     Error Conditions
C         Improper  input is a fatal error
C         Singular system of equations is a fatal error
C
C***REFERENCES  D. E. Amos, Computation with splines and B-splines,
C                 Report SAND78-1968, Sandia Laboratories, March 1979.
C               Carl de Boor, Package for calculating with B-splines,
C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
C                 pp. 441-472.
C               Carl de Boor, A Practical Guide to Splines, Applied
C                 Mathematics Series 27, Springer-Verlag, New York,
C                 1978.
C***ROUTINES CALLED  BNFAC, BNSLV, BSPVD, R1MACH, 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  BINT4
C
      INTEGER I, IBCL, IBCR, IFLAG, ILB, ILEFT, IT, IUB, IW, IWP, J,
     1 JW, K, KNTOPT, N, NDATA, NDM, NP, NWROW
      REAL BCOEF,FBCL,FBCR,T, TOL,TXN,TX1,VNIKX,W,WDTOL,WORK,X, XL,
     1 Y
      REAL R1MACH
      DIMENSION X(*), Y(*), T(*), BCOEF(*), W(5,*), VNIKX(4,4), WORK(15)
C***FIRST EXECUTABLE STATEMENT  BINT4
      WDTOL = R1MACH(4)
      TOL = SQRT(WDTOL)
      IF (NDATA.LT.2) GO TO 200
      NDM = NDATA - 1
      DO 10 I=1,NDM
        IF (X(I).GE.X(I+1)) GO TO 210
   10 CONTINUE
      IF (IBCL.LT.1 .OR. IBCL.GT.2) GO TO 220
      IF (IBCR.LT.1 .OR. IBCR.GT.2) GO TO 230
      IF (KNTOPT.LT.1 .OR. KNTOPT.GT.3) GO TO 240
      K = 4
      N = NDATA + 2
      NP = N + 1
      DO 20 I=1,NDATA
        T(I+3) = X(I)
   20 CONTINUE
      GO TO (30, 50, 90), KNTOPT
C     SET UP KNOT ARRAY WITH MULTIPLICITY 4 AT X(1) AND X(NDATA)
   30 CONTINUE
      DO 40 I=1,3
        T(4-I) = X(1)
        T(NP+I) = X(NDATA)
   40 CONTINUE
      GO TO 110
C     SET UP KNOT ARRAY WITH SYMMETRIC PLACEMENT ABOUT END POINTS
   50 CONTINUE
      IF (NDATA.GT.3) GO TO 70
      XL = (X(NDATA)-X(1))/3.0E0
      DO 60 I=1,3
        T(4-I) = T(5-I) - XL
        T(NP+I) = T(NP+I-1) + XL
   60 CONTINUE
      GO TO 110
   70 CONTINUE
      TX1 = X(1) + X(1)
      TXN = X(NDATA) + X(NDATA)
      DO 80 I=1,3
        T(4-I) = TX1 - X(I+1)
        T(NP+I) = TXN - X(NDATA-I)
   80 CONTINUE
      GO TO 110
C     SET UP KNOT ARRAY LESS THAN X(1) AND GREATER THAN X(NDATA) TO BE
C     SUPPLIED BY USER IN WORK LOCATIONS W(1) THROUGH W(6) WHEN KNTOPT=3
   90 CONTINUE
      DO 100 I=1,3
        T(4-I) = W(4-I,1)
        JW = MAX(1,I-1)
        IW = MOD(I+2,5)+1
        T(NP+I) = W(IW,JW)
        IF (T(4-I).GT.T(5-I)) GO TO 250
        IF (T(NP+I).LT.T(NP+I-1)) GO TO 250
  100 CONTINUE
  110 CONTINUE
C
      DO 130 I=1,5
        DO 120 J=1,N
          W(I,J) = 0.0E0
  120   CONTINUE
  130 CONTINUE
C     SET UP LEFT INTERPOLATION POINT AND LEFT BOUNDARY CONDITION FOR
C     RIGHT LIMITS
      IT = IBCL + 1
      CALL BSPVD(T, K, IT, X(1), K, 4, VNIKX, WORK)
      IW = 0
      IF (ABS(VNIKX(3,1)).LT.TOL) IW = 1
      DO 140 J=1,3
        W(J+1,4-J) = VNIKX(4-J,IT)
        W(J,4-J) = VNIKX(4-J,1)
  140 CONTINUE
      BCOEF(1) = Y(1)
      BCOEF(2) = FBCL
C     SET UP INTERPOLATION EQUATIONS FOR POINTS I=2 TO I=NDATA-1
      ILEFT = 4
      IF (NDM.LT.2) GO TO 170
      DO 160 I=2,NDM
        ILEFT = ILEFT + 1
        CALL BSPVD(T, K, 1, X(I), ILEFT, 4, VNIKX, WORK)
        DO 150 J=1,3
          W(J+1,3+I-J) = VNIKX(4-J,1)
  150   CONTINUE
        BCOEF(I+1) = Y(I)
  160 CONTINUE
C     SET UP RIGHT INTERPOLATION POINT AND RIGHT BOUNDARY CONDITION FOR
C     LEFT LIMITS(ILEFT IS ASSOCIATED WITH T(N)=X(NDATA-1))
  170 CONTINUE
      IT = IBCR + 1
      CALL BSPVD(T, K, IT, X(NDATA), ILEFT, 4, VNIKX, WORK)
      JW = 0
      IF (ABS(VNIKX(2,1)).LT.TOL) JW = 1
      DO 180 J=1,3
        W(J+1,3+NDATA-J) = VNIKX(5-J,IT)
        W(J+2,3+NDATA-J) = VNIKX(5-J,1)
  180 CONTINUE
      BCOEF(N-1) = FBCR
      BCOEF(N) = Y(NDATA)
C     SOLVE SYSTEM OF EQUATIONS
      ILB = 2 - JW
      IUB = 2 - IW
      NWROW = 5
      IWP = IW + 1
      CALL BNFAC(W(IWP,1), NWROW, N, ILB, IUB, IFLAG)
      IF (IFLAG.EQ.2) GO TO 190
      CALL BNSLV(W(IWP,1), NWROW, N, ILB, IUB, BCOEF)
      RETURN
C
C
  190 CONTINUE
      CALL XERMSG ('SLATEC', 'BINT4',
     +   'THE SYSTEM OF EQUATIONS IS SINGULAR', 2, 1)
      RETURN
  200 CONTINUE
      CALL XERMSG ('SLATEC', 'BINT4', 'NDATA IS LESS THAN 2', 2, 1)
      RETURN
  210 CONTINUE
      CALL XERMSG ('SLATEC', 'BINT4',
     +   'X VALUES ARE NOT DISTINCT OR NOT ORDERED', 2, 1)
      RETURN
  220 CONTINUE
      CALL XERMSG ('SLATEC', 'BINT4', 'IBCL IS NOT 1 OR 2', 2, 1)
      RETURN
  230 CONTINUE
      CALL XERMSG ('SLATEC', 'BINT4', 'IBCR IS NOT 1 OR 2', 2, 1)
      RETURN
  240 CONTINUE
      CALL XERMSG ('SLATEC', 'BINT4', 'KNTOPT IS NOT 1, 2, OR 3', 2, 1)
      RETURN
  250 CONTINUE
      CALL XERMSG ('SLATEC', 'BINT4',
     +   'KNOT INPUT THROUGH W ARRAY IS NOT ORDERED PROPERLY', 2, 1)
      RETURN
      END
*DECK BINTK
      SUBROUTINE BINTK (X, Y, T, N, K, BCOEF, Q, WORK)
C***BEGIN PROLOGUE  BINTK
C***PURPOSE  Compute the B-representation of a spline which interpolates
C            given data.
C***LIBRARY   SLATEC
C***CATEGORY  E1A
C***TYPE      SINGLE PRECISION (BINTK-S, DBINTK-D)
C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract
C
C         BINTK is the SPLINT routine of the reference.
C
C         BINTK produces the B-spline coefficients, BCOEF, of the
C         B-spline of order K with knots T(I), I=1,...,N+K, which
C         takes on the value Y(I) at X(I), I=1,...,N.  The spline or
C         any of its derivatives can be evaluated by calls to BVALU.
C         The I-th equation of the linear system A*BCOEF = B for the
C         coefficients of the interpolant enforces interpolation at
C         X(I)), I=1,...,N.  Hence, B(I) = Y(I), all I, and A is
C         a band matrix with 2K-1 bands if A is invertible. The matrix
C         A is generated row by row and stored, diagonal by diagonal,
C         in the rows of Q, with the main diagonal going into row K.
C         The banded system is then solved by a call to BNFAC (which
C         constructs the triangular factorization for A and stores it
C         again in Q), followed by a call to BNSLV (which then
C         obtains the solution BCOEF by substitution). BNFAC does no
C         pivoting, since the total positivity of the matrix A makes
C         this unnecessary.  The linear system to be solved is
C         (theoretically) invertible if and only if
C                 T(I) .LT. X(I)) .LT. T(I+K),        all I.
C         Equality is permitted on the left for I=1 and on the right
C         for I=N when K knots are used at X(1) or X(N).  Otherwise,
C         violation of this condition is certain to lead to an error.
C
C     Description of Arguments
C         Input
C           X       - vector of length N containing data point abscissa
C                     in strictly increasing order.
C           Y       - corresponding vector of length N containing data
C                     point ordinates.
C           T       - knot vector of length N+K
C                     since T(1),..,T(K) .LE. X(1) and T(N+1),..,T(N+K)
C                     .GE. X(N), this leaves only N-K knots (not nec-
C                     essarily X(I)) values) interior to (X(1),X(N))
C           N       - number of data points, N .GE. K
C           K       - order of the spline, K .GE. 1
C
C         Output
C           BCOEF   - a vector of length N containing the B-spline
C                     coefficients
C           Q       - a work vector of length (2*K-1)*N, containing
C                     the triangular factorization of the coefficient
C                     matrix of the linear system being solved.  The
C                     coefficients for the interpolant of an
C                     additional data set (X(I)),YY(I)), I=1,...,N
C                     with the same abscissa can be obtained by loading
C                     YY into BCOEF and then executing
C                         CALL BNSLV (Q,2K-1,N,K-1,K-1,BCOEF)
C           WORK    - work vector of length 2*K
C
C     Error Conditions
C         Improper  input is a fatal error
C         Singular system of equations is a fatal error
C
C***REFERENCES  D. E. Amos, Computation with splines and B-splines,
C                 Report SAND78-1968, Sandia Laboratories, March 1979.
C               Carl de Boor, Package for calculating with B-splines,
C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
C                 pp. 441-472.
C               Carl de Boor, A Practical Guide to Splines, Applied
C                 Mathematics Series 27, Springer-Verlag, New York,
C                 1978.
C***ROUTINES CALLED  BNFAC, BNSLV, BSPVN, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BINTK
C
      INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT,
     1 LENQ, NP1
      REAL BCOEF(*), Y(*), Q(*), T(*), X(*), XI, WORK(*)
C     DIMENSION Q(2*K-1,N), T(N+K)
C***FIRST EXECUTABLE STATEMENT  BINTK
      IF(K.LT.1) GO TO 100
      IF(N.LT.K) GO TO 105
      JJ = N - 1
      IF(JJ.EQ.0) GO TO 6
      DO 5 I=1,JJ
      IF(X(I).GE.X(I+1)) GO TO 110
    5 CONTINUE
    6 CONTINUE
      NP1 = N + 1
      KM1 = K - 1
      KPKM2 = 2*KM1
      LEFT = K
C                ZERO OUT ALL ENTRIES OF Q
      LENQ = N*(K+KM1)
      DO 10 I=1,LENQ
        Q(I) = 0.0E0
   10 CONTINUE
C
C  ***   LOOP OVER I TO CONSTRUCT THE  N  INTERPOLATION EQUATIONS
      DO 50 I=1,N
        XI = X(I)
        ILP1MX = MIN(I+K,NP1)
C        *** FIND  LEFT  IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT
C                T(LEFT) .LE. X(I) .LT. T(LEFT+1)
C        MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE
        LEFT = MAX(LEFT,I)
        IF (XI.LT.T(LEFT)) GO TO 80
   20   IF (XI.LT.T(LEFT+1)) GO TO 30
        LEFT = LEFT + 1
        IF (LEFT.LT.ILP1MX) GO TO 20
        LEFT = LEFT - 1
        IF (XI.GT.T(LEFT+1)) GO TO 80
C        *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE
C        A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE  K  ENTRIES WITH  J =
C        LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE  K  NUMBERS
C        ARE RETURNED, IN  BCOEF (USED FOR TEMP. STORAGE HERE), BY THE
C        FOLLOWING
   30   CALL BSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK)
C        WE THEREFORE WANT  BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO
C        A(I,LEFT-K+J), I.E., INTO  Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE
C        A(I+J,J)  IS TO GO INTO  Q(I+K,J), ALL I,J,  IF WE CONSIDER  Q
C        AS A TWO-DIM. ARRAY , WITH  2*K-1  ROWS (SEE COMMENTS IN
C        BNFAC). IN THE PRESENT PROGRAM, WE TREAT  Q  AS AN EQUIVALENT
C        ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON
C        DIMENSION STATEMENTS) . WE THEREFORE WANT  BCOEF(J) TO GO INTO
C        ENTRY
C            I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1)
C                   =  I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J
C        OF  Q .
        JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1)
        DO 40 J=1,K
          JJ = JJ + KPKM2
          Q(JJ) = BCOEF(J)
   40   CONTINUE
   50 CONTINUE
C
C     ***OBTAIN FACTORIZATION OF  A  , STORED AGAIN IN  Q.
      CALL BNFAC(Q, K+KM1, N, KM1, KM1, IFLAG)
      GO TO (60, 90), IFLAG
C     *** SOLVE  A*BCOEF = Y  BY BACKSUBSTITUTION
   60 DO 70 I=1,N
        BCOEF(I) = Y(I)
   70 CONTINUE
      CALL BNSLV(Q, K+KM1, N, KM1, KM1, BCOEF)
      RETURN
C
C
   80 CONTINUE
      CALL XERMSG ('SLATEC', 'BINTK',
     +   'SOME ABSCISSA WAS NOT IN THE SUPPORT OF THE CORRESPONDING ' //
     +   'BASIS FUNCTION AND THE SYSTEM IS SINGULAR.', 2, 1)
      RETURN
   90 CONTINUE
      CALL XERMSG ('SLATEC', 'BINTK',
     +   'THE SYSTEM OF SOLVER DETECTS A SINGULAR SYSTEM ALTHOUGH ' //
     +   'THE THEORETICAL CONDITIONS FOR A SOLUTION WERE SATISFIED.',
     +   8, 1)
      RETURN
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'BINTK', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'BINTK', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'BINTK',
     +   'X(I) DOES NOT SATISFY X(I).LT.X(I+1) FOR SOME I', 2, 1)
      RETURN
      END
*DECK BISECT
      SUBROUTINE BISECT (N, EPS1, D, E, E2, LB, UB, MM, M, W, IND, IERR,
     +   RV4, RV5)
C***BEGIN PROLOGUE  BISECT
C***PURPOSE  Compute the eigenvalues of a symmetric tridiagonal matrix
C            in a given interval using Sturm sequencing.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5, D4C2A
C***TYPE      SINGLE PRECISION (BISECT-S)
C***KEYWORDS  EIGENVALUES, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the bisection technique
C     in the ALGOL procedure TRISTURM by Peters and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971).
C
C     This subroutine finds those eigenvalues of a TRIDIAGONAL
C     SYMMETRIC matrix which lie in a specified interval,
C     using bisection.
C
C     On INPUT
C
C        N is the order of the matrix.  N is an INTEGER variable.
C
C        EPS1 is an absolute error tolerance for the computed
C          eigenvalues.  If the input EPS1 is non-positive,
C          it is reset for each submatrix to a default value,
C          namely, minus the product of the relative machine
C          precision and the 1-norm of the submatrix.
C          EPS1 is a REAL variable.
C
C        D contains the diagonal elements of the input matrix.
C          D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the input matrix
C          in its last N-1 positions.  E(1) is arbitrary.
C          E is a one-dimensional REAL array, dimensioned E(N).
C
C        E2 contains the squares of the corresponding elements of E.
C          E2(1) is arbitrary.  E2 is a one-dimensional REAL array,
C          dimensioned E2(N).
C
C        LB and UB define the interval to be searched for eigenvalues.
C          If LB is not less than UB, no eigenvalues will be found.
C          LB and UB are REAL variables.
C
C        MM should be set to an upper bound for the number of
C          eigenvalues in the interval.  WARNING - If more than
C          MM eigenvalues are determined to lie in the interval,
C          an error return is made with no eigenvalues found.
C          MM is an INTEGER variable.
C
C     On OUTPUT
C
C        EPS1 is unaltered unless it has been reset to its
C          (last) default value.
C
C        D and E are unaltered.
C
C        Elements of E2, corresponding to elements of E regarded
C          as negligible, have been replaced by zero causing the
C          matrix to split into a direct sum of submatrices.
C          E2(1) is also set to zero.
C
C        M is the number of eigenvalues determined to lie in (LB,UB).
C          M is an INTEGER variable.
C
C        W contains the M eigenvalues in ascending order.
C          W is a one-dimensional REAL array, dimensioned W(MM).
C
C        IND contains in its first M positions the submatrix indices
C          associated with the corresponding eigenvalues in W --
C          1 for eigenvalues belonging to the first submatrix from
C          the top, 2 for those belonging to the second submatrix, etc.
C          IND is an one-dimensional INTEGER array, dimensioned IND(MM).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          3*N+1      if M exceeds MM.  In this case, M contains the
C                     number of eigenvalues determined to lie in
C                     (LB,UB).
C
C        RV4 and RV5 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned RV4(N) and RV5(N).
C
C     The ALGOL procedure STURMCNT contained in TRISTURM
C     appears in BISECT in-line.
C
C     Note that subroutine TQL1 or IMTQL1 is generally faster than
C     BISECT, if more than N/4 eigenvalues are to be found.
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   760101  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BISECT
C
      INTEGER I,J,K,L,M,N,P,Q,R,S,II,MM,M1,M2,TAG,IERR,ISTURM
      REAL D(*),E(*),E2(*),W(*),RV4(*),RV5(*)
      REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP,S1,S2
      INTEGER IND(*)
      LOGICAL FIRST
C
      SAVE FIRST, MACHEP
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BISECT
      IF (FIRST) THEN
         MACHEP = R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IERR = 0
      TAG = 0
      T1 = LB
      T2 = UB
C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES ..........
      DO 40 I = 1, N
         IF (I .EQ. 1) GO TO 20
         S1 = ABS(D(I)) + ABS(D(I-1))
         S2 = S1 + ABS(E(I))
         IF (S2 .GT. S1) GO TO 40
   20    E2(I) = 0.0E0
   40 CONTINUE
C     .......... DETERMINE THE NUMBER OF EIGENVALUES
C                IN THE INTERVAL ..........
      P = 1
      Q = N
      X1 = UB
      ISTURM = 1
      GO TO 320
   60 M = S
      X1 = LB
      ISTURM = 2
      GO TO 320
   80 M = M - S
      IF (M .GT. MM) GO TO 980
      Q = 0
      R = 0
C     .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
C                INTERVAL BY THE GERSCHGORIN BOUNDS ..........
  100 IF (R .EQ. M) GO TO 1001
      TAG = TAG + 1
      P = Q + 1
      XU = D(P)
      X0 = D(P)
      U = 0.0E0
C
      DO 120 Q = P, N
         X1 = U
         U = 0.0E0
         V = 0.0E0
         IF (Q .EQ. N) GO TO 110
         U = ABS(E(Q+1))
         V = E2(Q+1)
  110    XU = MIN(D(Q)-(X1+U),XU)
         X0 = MAX(D(Q)+(X1+U),X0)
         IF (V .EQ. 0.0E0) GO TO 140
  120 CONTINUE
C
  140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP
      IF (EPS1 .LE. 0.0E0) EPS1 = -X1
      IF (P .NE. Q) GO TO 180
C     .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
      IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
      M1 = P
      M2 = P
      RV5(P) = D(P)
      GO TO 900
  180 X1 = X1 * (Q-P+1)
      LB = MAX(T1,XU-X1)
      UB = MIN(T2,X0+X1)
      X1 = LB
      ISTURM = 3
      GO TO 320
  200 M1 = S + 1
      X1 = UB
      ISTURM = 4
      GO TO 320
  220 M2 = S
      IF (M1 .GT. M2) GO TO 940
C     .......... FIND ROOTS BY BISECTION ..........
      X0 = UB
      ISTURM = 5
C
      DO 240 I = M1, M2
         RV5(I) = UB
         RV4(I) = LB
  240 CONTINUE
C     .......... LOOP FOR K-TH EIGENVALUE
C                FOR K=M2 STEP -1 UNTIL M1 DO --
C                (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
      K = M2
  250    XU = LB
C     .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
         DO 260 II = M1, K
            I = M1 + K - II
            IF (XU .GE. RV4(I)) GO TO 260
            XU = RV4(I)
            GO TO 280
  260    CONTINUE
C
  280    IF (X0 .GT. RV5(K)) X0 = RV5(K)
C     .......... NEXT BISECTION STEP ..........
  300    X1 = (XU + X0) * 0.5E0
         S1 = 2.0E0*(ABS(XU) + ABS(X0) + ABS(EPS1))
         S2 = S1 + ABS(X0 - XU)
         IF (S2 .EQ. S1) GO TO 420
C     .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
  320    S = P - 1
         U = 1.0E0
C
         DO 340 I = P, Q
            IF (U .NE. 0.0E0) GO TO 325
            V = ABS(E(I)) / MACHEP
            IF (E2(I) .EQ. 0.0E0) V = 0.0E0
            GO TO 330
  325       V = E2(I) / U
  330       U = D(I) - X1 - V
            IF (U .LT. 0.0E0) S = S + 1
  340    CONTINUE
C
         GO TO (60,80,200,220,360), ISTURM
C     .......... REFINE INTERVALS ..........
  360    IF (S .GE. K) GO TO 400
         XU = X1
         IF (S .GE. M1) GO TO 380
         RV4(M1) = X1
         GO TO 300
  380    RV4(S+1) = X1
         IF (RV5(S) .GT. X1) RV5(S) = X1
         GO TO 300
  400    X0 = X1
         GO TO 300
C     .......... K-TH EIGENVALUE FOUND ..........
  420    RV5(K) = X1
      K = K - 1
      IF (K .GE. M1) GO TO 250
C     .......... ORDER EIGENVALUES TAGGED WITH THEIR
C                SUBMATRIX ASSOCIATIONS ..........
  900 S = R
      R = R + M2 - M1 + 1
      J = 1
      K = M1
C
      DO 920 L = 1, R
         IF (J .GT. S) GO TO 910
         IF (K .GT. M2) GO TO 940
         IF (RV5(K) .GE. W(L)) GO TO 915
C
         DO 905 II = J, S
            I = L + S - II
            W(I+1) = W(I)
            IND(I+1) = IND(I)
  905    CONTINUE
C
  910    W(L) = RV5(K)
         IND(L) = TAG
         K = K + 1
         GO TO 920
  915    J = J + 1
  920 CONTINUE
C
  940 IF (Q .LT. N) GO TO 100
      GO TO 1001
C     .......... SET ERROR -- UNDERESTIMATE OF NUMBER OF
C                EIGENVALUES IN INTERVAL ..........
  980 IERR = 3 * N + 1
 1001 LB = T1
      UB = T2
      RETURN
      END
*DECK BKIAS
      SUBROUTINE BKIAS (X, N, KTRMS, T, ANS, IND, MS, GMRN, H, IERR)
C***BEGIN PROLOGUE  BKIAS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BSKIN
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BKIAS-S, DBKIAS-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     BKIAS computes repeated integrals of the K0 Bessel function
C     by the asymptotic expansion
C
C***SEE ALSO  BSKIN
C***ROUTINES CALLED  BDIFF, GAMRN, HKSEQ, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (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  BKIAS
      INTEGER I, II, IND, J, JMI, JN, K, KK, KM, KTRMS, MM, MP, MS, N,
     * IERR
      REAL ANS, B, BND, DEN1, DEN2, DEN3, ER, ERR, FJ, FK, FLN, FM1,
     * GMRN, G1, GS, H, HN, HRTPI, RAT, RG1, RXP, RZ, RZX, S, SS, SUMI,
     * SUMJ, T, TOL, V, W, X, XP, Z
      REAL GAMRN, R1MACH
      DIMENSION B(120), XP(16), S(31), H(*), V(52), W(52), T(50),
     * BND(15)
      SAVE B, BND, HRTPI
C-----------------------------------------------------------------------
C             COEFFICIENTS OF POLYNOMIAL P(J-1,X), J=1,15
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), B(23), B(24) /1.00000000000000000E+00,
     * 1.00000000000000000E+00,-2.00000000000000000E+00,
     * 1.00000000000000000E+00,-8.00000000000000000E+00,
     * 6.00000000000000000E+00,1.00000000000000000E+00,
     * -2.20000000000000000E+01,5.80000000000000000E+01,
     * -2.40000000000000000E+01,1.00000000000000000E+00,
     * -5.20000000000000000E+01,3.28000000000000000E+02,
     * -4.44000000000000000E+02,1.20000000000000000E+02,
     * 1.00000000000000000E+00,-1.14000000000000000E+02,
     * 1.45200000000000000E+03,-4.40000000000000000E+03,
     * 3.70800000000000000E+03,-7.20000000000000000E+02,
     * 1.00000000000000000E+00,-2.40000000000000000E+02,
     * 5.61000000000000000E+03/
      DATA B(25), B(26), B(27), B(28), B(29), B(30), B(31), B(32),
     * B(33), B(34), B(35), B(36), B(37), B(38), B(39), B(40), B(41),
     * B(42), B(43), B(44), B(45), B(46), B(47), B(48)
     * /-3.21200000000000000E+04,5.81400000000000000E+04,
     * -3.39840000000000000E+04,5.04000000000000000E+03,
     * 1.00000000000000000E+00,-4.94000000000000000E+02,
     * 1.99500000000000000E+04,-1.95800000000000000E+05,
     * 6.44020000000000000E+05,-7.85304000000000000E+05,
     * 3.41136000000000000E+05,-4.03200000000000000E+04,
     * 1.00000000000000000E+00,-1.00400000000000000E+03,
     * 6.72600000000000000E+04,-1.06250000000000000E+06,
     * 5.76550000000000000E+06,-1.24400640000000000E+07,
     * 1.10262960000000000E+07,-3.73392000000000000E+06,
     * 3.62880000000000000E+05,1.00000000000000000E+00,
     * -2.02600000000000000E+03,2.18848000000000000E+05/
      DATA B(49), B(50), B(51), B(52), B(53), B(54), B(55), B(56),
     * B(57), B(58), B(59), B(60), B(61), B(62), B(63), B(64), B(65),
     * B(66), B(67), B(68), B(69), B(70), B(71), B(72)
     * /-5.32616000000000000E+06,4.47650000000000000E+07,
     * -1.55357384000000000E+08,2.38904904000000000E+08,
     * -1.62186912000000000E+08,4.43390400000000000E+07,
     * -3.62880000000000000E+06,1.00000000000000000E+00,
     * -4.07200000000000000E+03,6.95038000000000000E+05,
     * -2.52439040000000000E+07,3.14369720000000000E+08,
     * -1.64838430400000000E+09,4.00269508800000000E+09,
     * -4.64216395200000000E+09,2.50748121600000000E+09,
     * -5.68356480000000000E+08,3.99168000000000000E+07,
     * 1.00000000000000000E+00,-8.16600000000000000E+03,
     * 2.17062600000000000E+06,-1.14876376000000000E+08,
     * 2.05148277600000000E+09,-1.55489607840000000E+10/
      DATA B(73), B(74), B(75), B(76), B(77), B(78), B(79), B(80),
     * B(81), B(82), B(83), B(84), B(85), B(86), B(87), B(88), B(89),
     * B(90), B(91), B(92), B(93), B(94), B(95), B(96)
     * /5.60413987840000000E+10,-1.01180433024000000E+11,
     * 9.21997902240000000E+10,-4.07883018240000000E+10,
     * 7.82771904000000000E+09,-4.79001600000000000E+08,
     * 1.00000000000000000E+00,-1.63560000000000000E+04,
     * 6.69969600000000000E+06,-5.07259276000000000E+08,
     * 1.26698177760000000E+10,-1.34323420224000000E+11,
     * 6.87720046384000000E+11,-1.81818864230400000E+12,
     * 2.54986547342400000E+12,-1.88307966182400000E+12,
     * 6.97929436800000000E+11,-1.15336085760000000E+11,
     * 6.22702080000000000E+09,1.00000000000000000E+00,
     * -3.27380000000000000E+04,2.05079880000000000E+07,
     * -2.18982980800000000E+09,7.50160522280000000E+10/
      DATA B(97), B(98), B(99), B(100), B(101), B(102), B(103), B(104),
     * B(105), B(106), B(107), B(108), B(109), B(110), B(111), B(112),
     * B(113), B(114), B(115), B(116), B(117), B(118)
     * /-1.08467651241600000E+12,7.63483214939200000E+12,
     * -2.82999100661120000E+13,5.74943734645920000E+13,
     * -6.47283751398720000E+13,3.96895780558080000E+13,
     * -1.25509040179200000E+13,1.81099255680000000E+12,
     * -8.71782912000000000E+10,1.00000000000000000E+00,
     * -6.55040000000000000E+04,6.24078900000000000E+07,
     * -9.29252692000000000E+09,4.29826006340000000E+11,
     * -8.30844432796800000E+12,7.83913848313120000E+13,
     * -3.94365587815520000E+14,1.11174747256968000E+15,
     * -1.79717122069056000E+15,1.66642448627145600E+15,
     * -8.65023253219584000E+14,2.36908271543040000E+14/
      DATA B(119), B(120) /-3.01963769856000000E+13,
     * 1.30767436800000000E+12/
C-----------------------------------------------------------------------
C             BOUNDS B(M,K) , K=M-3
C-----------------------------------------------------------------------
      DATA BND(1), BND(2), BND(3), BND(4), BND(5), BND(6), BND(7),
     * BND(8), BND(9), BND(10), BND(11), BND(12), BND(13), BND(14),
     * BND(15) /1.0E0,1.0E0,1.0E0,1.0E0,3.10E0,5.18E0,11.7E0,29.8E0,
     * 90.4E0,297.0E0,1070.0E0,4290.0E0,18100.0E0,84700.0E0,408000.0E0/
      DATA HRTPI /8.86226925452758014E-01/
C
C***FIRST EXECUTABLE STATEMENT  BKIAS
      IERR=0
      TOL = MAX(R1MACH(4),1.0E-18)
      FLN = N
      RZ = 1.0E0/(X+FLN)
      RZX = X*RZ
      Z = 0.5E0*(X+FLN)
      IF (IND.GT.1) GO TO 10
      GMRN = GAMRN(Z)
   10 CONTINUE
      GS = HRTPI*GMRN
      G1 = GS + GS
      RG1 = 1.0E0/G1
      GMRN = (RZ+RZ)/GMRN
      IF (IND.GT.1) GO TO 70
C-----------------------------------------------------------------------
C     EVALUATE ERROR FOR M=MS
C-----------------------------------------------------------------------
      HN = 0.5E0*FLN
      DEN2 = KTRMS + KTRMS + N
      DEN3 = DEN2 - 2.0E0
      DEN1 = X + DEN2
      ERR = RG1*(X+X)/(DEN1-1.0E0)
      IF (N.EQ.0) GO TO 20
      RAT = 1.0E0/(FLN*FLN)
   20 CONTINUE
      IF (KTRMS.EQ.0) GO TO 30
      FJ = KTRMS
      RAT = 0.25E0/(HRTPI*DEN3*SQRT(FJ))
   30 CONTINUE
      ERR = ERR*RAT
      FJ = -3.0E0
      DO 50 J=1,15
        IF (J.LE.5) ERR = ERR/DEN1
        FM1 = MAX(1.0E0,FJ)
        FJ = FJ + 1.0E0
        ER = BND(J)*ERR
        IF (KTRMS.EQ.0) GO TO 40
        ER = ER/FM1
        IF (ER.LT.TOL) GO TO 60
        IF (J.GE.5) ERR = ERR/DEN3
        GO TO 50
   40   CONTINUE
        ER = ER*(1.0E0+HN/FM1)
        IF (ER.LT.TOL) GO TO 60
        IF (J.GE.5) ERR = ERR/FLN
   50 CONTINUE
      GO TO 200
   60 CONTINUE
      MS = J
   70 CONTINUE
      MM = MS + MS
      MP = MM + 1
C-----------------------------------------------------------------------
C     H(K)=(-Z)**(K)*(PSI(K-1,Z)-PSI(K-1,Z+0.5))/GAMMA(K) , K=1,2,...,MM
C-----------------------------------------------------------------------
      IF (IND.GT.1) GO TO 80
      CALL HKSEQ(Z, MM, H, IERR)
      GO TO 100
   80 CONTINUE
      RAT = Z/(Z-0.5E0)
      RXP = RAT
      DO 90 I=1,MM
        H(I) = RXP*(1.0E0-H(I))
        RXP = RXP*RAT
   90 CONTINUE
  100 CONTINUE
C-----------------------------------------------------------------------
C     SCALED S SEQUENCE
C-----------------------------------------------------------------------
      S(1) = 1.0E0
      FK = 1.0E0
      DO 120 K=2,MP
        SS = 0.0E0
        KM = K - 1
        I = KM
        DO 110 J=1,KM
          SS = SS + S(J)*H(I)
          I = I - 1
  110   CONTINUE
        S(K) = SS/FK
        FK = FK + 1.0E0
  120 CONTINUE
C-----------------------------------------------------------------------
C     SCALED S-TILDA SEQUENCE
C-----------------------------------------------------------------------
      IF (KTRMS.EQ.0) GO TO 160
      FK = 0.0E0
      SS = 0.0E0
      RG1 = RG1/Z
      DO 130 K=1,KTRMS
        V(K) = Z/(Z+FK)
        W(K) = T(K)*V(K)
        SS = SS + W(K)
        FK = FK + 1.0E0
  130 CONTINUE
      S(1) = S(1) - SS*RG1
      DO 150 I=2,MP
        SS = 0.0E0
        DO 140 K=1,KTRMS
          W(K) = W(K)*V(K)
          SS = SS + W(K)
  140   CONTINUE
        S(I) = S(I) - SS*RG1
  150 CONTINUE
  160 CONTINUE
C-----------------------------------------------------------------------
C     SUM ON J
C-----------------------------------------------------------------------
      SUMJ = 0.0E0
      JN = 1
      RXP = 1.0E0
      XP(1) = 1.0E0
      DO 190 J=1,MS
        JN = JN + J - 1
        XP(J+1) = XP(J)*RZX
        RXP = RXP*RZ
C-----------------------------------------------------------------------
C     SUM ON I
C-----------------------------------------------------------------------
        SUMI = 0.0E0
        II = JN
        DO 180 I=1,J
          JMI = J - I + 1
          KK = J + I + 1
          DO 170 K=1,JMI
            V(K) = S(KK)*XP(K)
            KK = KK + 1
  170     CONTINUE
          CALL BDIFF(JMI, V)
          SUMI = SUMI + B(II)*V(JMI)*XP(I+1)
          II = II + 1
  180   CONTINUE
        SUMJ = SUMJ + SUMI*RXP
  190 CONTINUE
      ANS = GS*(S(1)-SUMJ)
      RETURN
  200 CONTINUE
      IERR=2
      RETURN
      END
*DECK BKISR
      SUBROUTINE BKISR (X, N, SUM, IERR)
C***BEGIN PROLOGUE  BKISR
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BSKIN
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BKISR-S, DBKISR-D)
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     BKISR computes repeated integrals of the K0 Bessel function
C     by the series for N=0,1, and 2.
C
C***SEE ALSO  BSKIN
C***ROUTINES CALLED  PSIXN, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (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  BKISR
      INTEGER I, IERR, K, KK, KKN, K1, N, NP
      REAL AK, ATOL, BK, C, FK, FN, HX, HXS, POL, PR, SUM, TKP, TOL,
     * TRM, X, XLN
      REAL PSIXN, R1MACH
      DIMENSION C(2)
      SAVE C
C
      DATA C(1), C(2) /1.57079632679489662E+00,1.0E0/
C***FIRST EXECUTABLE STATEMENT  BKISR
      IERR=0
      TOL = MAX(R1MACH(4),1.0E-18)
      IF (X.LT.TOL) GO TO 50
      PR = 1.0E0
      POL = 0.0E0
      IF (N.EQ.0) GO TO 20
      DO 10 I=1,N
        POL = -POL*X + C(I)
        PR = PR*X/I
   10 CONTINUE
   20 CONTINUE
      HX = X*0.5E0
      HXS = HX*HX
      XLN = LOG(HX)
      NP = N + 1
      TKP = 3.0E0
      FK = 2.0E0
      FN = N
      BK = 4.0E0
      AK = 2.0E0/((FN+1.0E0)*(FN+2.0E0))
      SUM = AK*(PSIXN(N+3)-PSIXN(3)+PSIXN(2)-XLN)
      ATOL = SUM*TOL*0.75E0
      DO 30 K=2,20
        AK = AK*(HXS/BK)*((TKP+1.0E0)/(TKP+FN+1.0E0))*(TKP/(TKP+FN))
        K1 = K + 1
        KK = K1 + K
        KKN = KK + N
        TRM = (PSIXN(K1)+PSIXN(KKN)-PSIXN(KK)-XLN)*AK
        SUM = SUM + TRM
        IF (ABS(TRM).LE.ATOL) GO TO 40
        TKP = TKP + 2.0E0
        BK = BK + TKP
        FK = FK + 1.0E0
   30 CONTINUE
      GO TO 80
   40 CONTINUE
      SUM = (SUM*HXS+PSIXN(NP)-XLN)*PR
      IF (N.EQ.1) SUM = -SUM
      SUM = POL + SUM
      RETURN
C-----------------------------------------------------------------------
C     SMALL X CASE, X.LT.WORD TOLERANCE
C-----------------------------------------------------------------------
   50 CONTINUE
      IF (N.GT.0) GO TO 60
      HX = X*0.5E0
      SUM = PSIXN(1) - LOG(HX)
      RETURN
   60 CONTINUE
      SUM = C(N)
      RETURN
   80 CONTINUE
      IERR=2
      RETURN
      END
*DECK BKSOL
      SUBROUTINE BKSOL (N, A, X)
C***BEGIN PROLOGUE  BKSOL
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BKSOL-S, DBKSOL-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C **********************************************************************
C     Solution of an upper triangular linear system by
C     back-substitution
C
C     The matrix A is assumed to be stored in a linear
C     array proceeding in a row-wise manner. The
C     vector X contains the given constant vector on input
C     and contains the solution on return.
C     The actual diagonal of A is unity while a diagonal
C     scaling matrix is stored there.
C **********************************************************************
C
C***SEE ALSO  BVSUP
C***ROUTINES CALLED  SDOT
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
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  BKSOL
C
      DIMENSION A(*),X(*)
C
C***FIRST EXECUTABLE STATEMENT  BKSOL
      M=(N*(N+1))/2
      X(N)=X(N)*A(M)
      IF (N .EQ. 1) GO TO 20
      NM1=N-1
      DO 10 K=1,NM1
      J=N-K
      M=M-K-1
   10 X(J)=X(J)*A(M) - SDOT(K,A(M+1),1,X(J+1),1)
C
   20 RETURN
      END
*DECK BLKTR1
      SUBROUTINE BLKTR1 (N, AN, BN, CN, M, AM, BM, CM, IDIMY, Y, B, W1,
     +   W2, W3, WD, WW, WU, PRDCT, CPRDCT)
C***BEGIN PROLOGUE  BLKTR1
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BLKTRI
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BLKTR1-S, CBLKT1-C)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C BLKTR1 solves the linear system set up by BLKTRI.
C
C B  contains the roots of all the B polynomials.
C W1,W2,W3,WD,WW,WU  are all working arrays.
C PRDCT  is either PRODP or PROD depending on whether the boundary
C conditions in the M direction are periodic or not.
C CPRDCT is either CPRODP or CPROD which are the complex versions
C of PRODP and PROD. These are called in the event that some
C of the roots of the B sub P polynomial are complex.
C
C***SEE ALSO  BLKTRI
C***ROUTINES CALLED  INDXA, INDXB, INDXC
C***COMMON BLOCKS    CBLKT
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  BLKTR1
C
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
     1                BM(*)      ,CM(*)      ,B(*)       ,W1(*)      ,
     2                W2(*)      ,W3(*)      ,WD(*)      ,WW(*)      ,
     3                WU(*)      ,Y(IDIMY,*)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C***FIRST EXECUTABLE STATEMENT  BLKTR1
      KDO = K-1
      DO 109 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I3 = I2+I1
         I4 = I2+I2
         IRM1 = IR-1
         CALL INDXB (I2,IR,IM2,NM2)
         CALL INDXB (I1,IRM1,IM3,NM3)
         CALL INDXB (I3,IRM1,IM1,NM1)
         CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,Y(1,I2),W3,
     1               M,AM,BM,CM,WD,WW,WU)
         IF = 2**K
         DO 108 I=I4,IF,I4
            IF (I-NM) 101,101,108
  101       IPI1 = I+I1
            IPI2 = I+I2
            IPI3 = I+I3
            CALL INDXC (I,IR,IDXC,NC)
            IF (I-IF) 102,108,108
  102       CALL INDXA (I,IR,IDXA,NA)
            CALL INDXB (I-I1,IRM1,IM1,NM1)
            CALL INDXB (IPI2,IR,IP2,NP2)
            CALL INDXB (IPI1,IRM1,IP1,NP1)
            CALL INDXB (IPI3,IRM1,IP3,NP3)
            CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W3,W1,M,AM,
     1                  BM,CM,WD,WW,WU)
            IF (IPI2-NM) 105,105,103
  103       DO 104 J=1,M
               W3(J) = 0.
               W2(J) = 0.
  104       CONTINUE
            GO TO 106
  105       CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,
     1                  Y(1,IPI2),W3,M,AM,BM,CM,WD,WW,WU)
            CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W3,W2,M,AM,
     1                  BM,CM,WD,WW,WU)
  106       DO 107 J=1,M
               Y(J,I) = W1(J)+W2(J)+Y(J,I)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      IF (NPP) 132,110,132
C
C     THE PERIODIC CASE IS TREATED USING THE CAPACITANCE MATRIX METHOD
C
  110 IF = 2**K
      I = IF/2
      I1 = I/2
      CALL INDXB (I-I1,K-2,IM1,NM1)
      CALL INDXB (I+I1,K-2,IP1,NP1)
      CALL INDXB (I,K-1,IZ,NZ)
      CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,Y(1,I),W1,M,AM,
     1            BM,CM,WD,WW,WU)
      IZR = I
      DO 111 J=1,M
         W2(J) = W1(J)
  111 CONTINUE
      DO 113 LL=2,K
         L = K-LL+1
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I = I2
         CALL INDXC (I,IR,IDXC,NC)
         CALL INDXB (I,IR,IZ,NZ)
         CALL INDXB (I-I1,IR-1,IM1,NM1)
         CALL INDXB (I+I1,IR-1,IP1,NP1)
         CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W1,W1,M,AM,BM,
     1               CM,WD,WW,WU)
         DO 112 J=1,M
            W1(J) = Y(J,I)+W1(J)
  112    CONTINUE
         CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,W1,M,AM,
     1               BM,CM,WD,WW,WU)
  113 CONTINUE
      DO 118 LL=2,K
         L = K-LL+1
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I4 = I2+I2
         IFD = IF-I2
         DO 117 I=I2,IFD,I4
            IF (I-I2-IZR) 117,114,117
  114       IF (I-NM) 115,115,118
  115       CALL INDXA (I,IR,IDXA,NA)
            CALL INDXB (I,IR,IZ,NZ)
            CALL INDXB (I-I1,IR-1,IM1,NM1)
            CALL INDXB (I+I1,IR-1,IP1,NP1)
            CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W2,W2,M,AM,
     1                  BM,CM,WD,WW,WU)
            DO 116 J=1,M
               W2(J) = Y(J,I)+W2(J)
  116       CONTINUE
            CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W2,W2,M,
     1                  AM,BM,CM,WD,WW,WU)
            IZR = I
            IF (I-NM) 117,119,117
  117    CONTINUE
  118 CONTINUE
  119 DO 120 J=1,M
         Y(J,NM+1) = Y(J,NM+1)-CN(NM+1)*W1(J)-AN(NM+1)*W2(J)
  120 CONTINUE
      CALL INDXB (IF/2,K-1,IM1,NM1)
      CALL INDXB (IF,K-1,IP,NP)
      IF (NCMPLX) 121,122,121
  121 CALL CPRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1),
     1             Y(1,NM+1),M,AM,BM,CM,W1,W3,WW)
      GO TO 123
  122 CALL PRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1),
     1            Y(1,NM+1),M,AM,BM,CM,WD,WW,WU)
  123 DO 124 J=1,M
         W1(J) = AN(1)*Y(J,NM+1)
         W2(J) = CN(NM)*Y(J,NM+1)
         Y(J,1) = Y(J,1)-W1(J)
         Y(J,NM) = Y(J,NM)-W2(J)
  124 CONTINUE
      DO 126 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I4 = I2+I2
         I1 = I2/2
         I = I4
         CALL INDXA (I,IR,IDXA,NA)
         CALL INDXB (I-I2,IR,IM2,NM2)
         CALL INDXB (I-I2-I1,IR-1,IM3,NM3)
         CALL INDXB (I-I1,IR-1,IM1,NM1)
         CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,W1,W1,M,AM,
     1               BM,CM,WD,WW,WU)
         CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W1,W1,M,AM,BM,
     1               CM,WD,WW,WU)
         DO 125 J=1,M
            Y(J,I) = Y(J,I)-W1(J)
  125    CONTINUE
  126 CONTINUE
C
      IZR = NM
      DO 131 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I3 = I2+I1
         I4 = I2+I2
         IRM1 = IR-1
         DO 130 I=I4,IF,I4
            IPI1 = I+I1
            IPI2 = I+I2
            IPI3 = I+I3
            IF (IPI2-IZR) 127,128,127
  127       IF (I-IZR) 130,131,130
  128       CALL INDXC (I,IR,IDXC,NC)
            CALL INDXB (IPI2,IR,IP2,NP2)
            CALL INDXB (IPI1,IRM1,IP1,NP1)
            CALL INDXB (IPI3,IRM1,IP3,NP3)
            CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,W2,W2,M,
     1                  AM,BM,CM,WD,WW,WU)
            CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W2,W2,M,AM,
     1                  BM,CM,WD,WW,WU)
            DO 129 J=1,M
               Y(J,I) = Y(J,I)-W2(J)
  129       CONTINUE
            IZR = I
            GO TO 131
  130    CONTINUE
  131 CONTINUE
C
C BEGIN BACK SUBSTITUTION PHASE
C
  132 DO 144 LL=1,K
         L = K-LL+1
         IR = L-1
         IRM1 = IR-1
         I2 = 2**IR
         I1 = I2/2
         I4 = I2+I2
         IFD = IF-I2
         DO 143 I=I2,IFD,I4
            IF (I-NM) 133,133,143
  133       IMI1 = I-I1
            IMI2 = I-I2
            IPI1 = I+I1
            IPI2 = I+I2
            CALL INDXA (I,IR,IDXA,NA)
            CALL INDXC (I,IR,IDXC,NC)
            CALL INDXB (I,IR,IZ,NZ)
            CALL INDXB (IMI1,IRM1,IM1,NM1)
            CALL INDXB (IPI1,IRM1,IP1,NP1)
            IF (I-I2) 134,134,136
  134       DO 135 J=1,M
               W1(J) = 0.
  135       CONTINUE
            GO TO 137
  136       CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),Y(1,IMI2),
     1                  W1,M,AM,BM,CM,WD,WW,WU)
  137       IF (IPI2-NM) 140,140,138
  138       DO 139 J=1,M
               W2(J) = 0.
  139       CONTINUE
            GO TO 141
  140       CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),Y(1,IPI2),
     1                  W2,M,AM,BM,CM,WD,WW,WU)
  141       DO 142 J=1,M
               W1(J) = Y(J,I)+W1(J)+W2(J)
  142       CONTINUE
            CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,Y(1,I),
     1                  M,AM,BM,CM,WD,WW,WU)
  143    CONTINUE
  144 CONTINUE
      RETURN
      END
*DECK BLKTRI
      SUBROUTINE BLKTRI (IFLG, NP, N, AN, BN, CN, MP, M, AM, BM, CM,
     +   IDIMY, Y, IERROR, W)
C***BEGIN PROLOGUE  BLKTRI
C***PURPOSE  Solve a block tridiagonal system of linear equations
C            (usually resulting from the discretization of separable
C            two-dimensional elliptic equations).
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B4B
C***TYPE      SINGLE PRECISION (BLKTRI-S, CBLKTR-C)
C***KEYWORDS  ELLIPTIC PDE, FISHPACK, TRIDIAGONAL LINEAR SYSTEM
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     Subroutine BLKTRI Solves a System of Linear Equations of the Form
C
C          AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J)
C
C          + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J)
C
C               for I = 1,2,...,M  and  J = 1,2,...,N.
C
C     I+1 and I-1 are evaluated modulo M and J+1 and J-1 modulo N, i.e.,
C
C          X(I,0) = X(I,N),  X(I,N+1) = X(I,1),
C          X(0,J) = X(M,J),  X(M+1,J) = X(1,J).
C
C     These equations usually result from the discretization of
C     separable elliptic equations.  Boundary conditions may be
C     Dirichlet, Neumann, or Periodic.
C
C
C     * * * * * * * * * *     ON INPUT     * * * * * * * * * *
C
C     IFLG
C       = 0  Initialization only.  Certain quantities that depend on NP,
C            N, AN, BN, and CN are computed and stored in the work
C            array  W.
C       = 1  The quantities that were computed in the initialization are
C            used to obtain the solution X(I,J).
C
C       NOTE   A call with IFLG=0 takes approximately one half the time
C              as a call with IFLG = 1  .  However, the
C              initialization does not have to be repeated unless NP, N,
C              AN, BN, or CN change.
C
C     NP
C       = 0  If AN(1) and CN(N) are not zero, which corresponds to
C            periodic boundary conditions.
C       = 1  If AN(1) and CN(N) are zero.
C
C     N
C       The number of unknowns in the J-direction. N must be greater
C       than 4. The operation count is proportional to MNlog2(N), hence
C       N should be selected less than or equal to M.
C
C     AN,BN,CN
C       One-dimensional arrays of length N that specify the coefficients
C       in the linear equations given above.
C
C     MP
C       = 0  If AM(1) and CM(M) are not zero, which corresponds to
C            periodic boundary conditions.
C       = 1  If AM(1) = CM(M) = 0  .
C
C     M
C       The number of unknowns in the I-direction. M must be greater
C       than 4.
C
C     AM,BM,CM
C       One-dimensional arrays of length M that specify the coefficients
C       in the linear equations given above.
C
C     IDIMY
C       The row (or first) dimension of the two-dimensional array Y as
C       it appears in the program calling BLKTRI.  This parameter is
C       used to specify the variable dimension of Y.  IDIMY must be at
C       least M.
C
C     Y
C       A two-dimensional array that specifies the values of the right
C       side of the linear system of equations given above.  Y must be
C       dimensioned at least M*N.
C
C     W
C       A one-dimensional array that must be provided by the user for
C       work space.
C             If NP=1 define K=INT(log2(N))+1 and set L=2**(K+1) then
C                     W must have dimension (K-2)*L+K+5+MAX(2N,6M)
C
C             If NP=0 define K=INT(log2(N-1))+1 and set L=2**(K+1) then
C                     W must have dimension (K-2)*L+K+5+2N+MAX(2N,6M)
C
C       **IMPORTANT** For purposes of checking, the required dimension
C                     of W is computed by BLKTRI and stored in W(1)
C                     in floating point format.
C
C     * * * * * * * * * *     On Output     * * * * * * * * * *
C
C     Y
C       Contains the solution X.
C
C     IERROR
C       An error flag that indicates invalid input parameters.  Except
C       for number zero, a solution is not attempted.
C
C       = 0  No error.
C       = 1  M is less than 5.
C       = 2  N is less than 5.
C       = 3  IDIMY is less than M.
C       = 4  BLKTRI failed while computing results that depend on the
C            coefficient arrays AN, BN, CN.  Check these arrays.
C       = 5  AN(J)*CN(J-1) is less than 0 for some J. Possible reasons
C            for this condition are
C            1. The arrays AN and CN are not correct.
C            2. Too large a grid spacing was used in the discretization
C               of the elliptic equation.
C            3. The linear equations resulted from a partial
C               differential equation which was not elliptic.
C
C     W
C       Contains intermediate values that must not be destroyed if
C       BLKTRI will be called again with IFLG=1.  W(1) contains the
C       number of locations required by W in floating point format.
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N)
C     Arguments      W(See argument list)
C
C     Latest         June 1979
C     Revision
C
C     Required       BLKTRI,BLKTRI,PROD,PRODP,CPROD,CPRODP,COMPB,INDXA,
C     Subprograms    INDXB,INDXC,PPADD,PSGF,PPSGF,PPSPF,BSRH,TEVLS,
C                    R1MACH
C
C     Special        The Algorithm may fail if ABS(BM(I)+BN(J)) is less
C     Conditions     than ABS(AM(I))+ABS(AN(J))+ABS(CM(I))+ABS(CN(J))
C                    for some I and J. The Algorithm will also fail if
C                    AN(J)*CN(J-1) is less than zero for some J.
C                    See the description of the output parameter IERROR.
C
C     Common         CBLKT
C     Blocks
C
C     I/O            None
C
C     Precision      Single
C
C     Specialist     Paul Swarztrauber
C
C     Language       FORTRAN
C
C     History        Version 1 September 1973
C                    Version 2 April     1976
C                    Version 3 June      1979
C
C     Algorithm      Generalized Cyclic Reduction (See Reference below)
C
C     Space
C     Required       Control Data 7600
C
C     Portability    American National Standards Institute Fortran.
C                    The machine accuracy is set using function R1MACH.
C
C     Required       None
C     Resident
C     Routines
C
C     References     Swarztrauber,P. and R. Sweet, 'Efficient FORTRAN
C                    Subprograms For The Solution Of Elliptic Equations'
C                    NCAR TN/IA-109, July, 1975, 138 PP.
C
C                    Swarztrauber P. ,'A Direct Method For The Discrete
C                    Solution Of Separable Elliptic Equations', S.I.A.M.
C                    J. Numer. Anal.,11(1974) PP. 1136-1150.
C
C***REFERENCES  P. N. Swarztrauber and R. Sweet, Efficient Fortran
C                 subprograms for the solution of elliptic equations,
C                 NCAR TN/IA-109, July 1975, 138 pp.
C               P. N. Swarztrauber, A direct method for the discrete
C                 solution of separable elliptic equations, SIAM Journal
C                 on Numerical Analysis 11, (1974), pp. 1136-1150.
C***ROUTINES CALLED  BLKTR1, COMPB, CPROD, CPRODP, PROD, PRODP
C***COMMON BLOCKS    CBLKT
C***REVISION HISTORY  (YYMMDD)
C   801001  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BLKTRI
C
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
     1                BM(*)      ,CM(*)      ,Y(IDIMY,*) ,W(*)
      EXTERNAL        PROD       ,PRODP      ,CPROD      ,CPRODP
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C***FIRST EXECUTABLE STATEMENT  BLKTRI
      NM = N
      IERROR = 0
      IF (M-5) 101,102,102
  101 IERROR = 1
      GO TO 119
  102 IF (NM-3) 103,104,104
  103 IERROR = 2
      GO TO 119
  104 IF (IDIMY-M) 105,106,106
  105 IERROR = 3
      GO TO 119
  106 NH = N
      NPP = NP
      IF (NPP) 107,108,107
  107 NH = NH+1
  108 IK = 2
      K = 1
  109 IK = IK+IK
      K = K+1
      IF (NH-IK) 110,110,109
  110 NL = IK
      IK = IK+IK
      NL = NL-1
      IWAH = (K-2)*IK+K+6
      IF (NPP) 111,112,111
C
C     DIVIDE W INTO WORKING SUB ARRAYS
C
  111 IW1 = IWAH
      IWBH = IW1+NM
      W(1) = IW1-1+MAX(2*NM,6*M)
      GO TO 113
  112 IWBH = IWAH+NM+NM
      IW1 = IWBH
      W(1) = IW1-1+MAX(2*NM,6*M)
      NM = NM-1
C
C SUBROUTINE COMP B COMPUTES THE ROOTS OF THE B POLYNOMIALS
C
  113 IF (IERROR) 119,114,119
  114 IW2 = IW1+M
      IW3 = IW2+M
      IWD = IW3+M
      IWW = IWD+M
      IWU = IWW+M
      IF (IFLG) 116,115,116
  115 CALL COMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH))
      GO TO 119
  116 IF (MP) 117,118,117
C
C SUBROUTINE BLKTR1 SOLVES THE LINEAR SYSTEM
C
  117 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
     1             W(IW3),W(IWD),W(IWW),W(IWU),PROD,CPROD)
      GO TO 119
  118 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
     1             W(IW3),W(IWD),W(IWW),W(IWU),PRODP,CPRODP)
  119 CONTINUE
      RETURN
      END
*DECK BNDACC
      SUBROUTINE BNDACC (G, MDG, NB, IP, IR, MT, JT)
C***BEGIN PROLOGUE  BNDACC
C***PURPOSE  Compute the LU factorization of a banded matrices using
C            sequential accumulation of rows of the data matrix.
C            Exactly one right-hand side vector is permitted.
C***LIBRARY   SLATEC
C***CATEGORY  D9
C***TYPE      SINGLE PRECISION (BNDACC-S, DBNDAC-D)
C***KEYWORDS  BANDED MATRIX, CURVE FITTING, LEAST SQUARES
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     These subroutines solve the least squares problem Ax = b for
C     banded matrices A using sequential accumulation of rows of the
C     data matrix.  Exactly one right-hand side vector is permitted.
C
C     These subroutines are intended for the type of least squares
C     systems that arise in applications such as curve or surface
C     fitting of data.  The least squares equations are accumulated and
C     processed using only part of the data.  This requires a certain
C     user interaction during the solution of Ax = b.
C
C     Specifically, suppose the data matrix (A B) is row partitioned
C     into Q submatrices.  Let (E F) be the T-th one of these
C     submatrices where E = (0 C 0).  Here the dimension of E is MT by N
C     and the dimension of C is MT by NB.  The value of NB is the
C     bandwidth of A.  The dimensions of the leading block of zeros in E
C     are MT by JT-1.
C
C     The user of the subroutine BNDACC provides MT,JT,C and F for
C     T=1,...,Q.  Not all of this data must be supplied at once.
C
C     Following the processing of the various blocks (E F), the matrix
C     (A B) has been transformed to the form (R D) where R is upper
C     triangular and banded with bandwidth NB.  The least squares
C     system Rx = d is then easily solved using back substitution by
C     executing the statement CALL BNDSOL(1,...). The sequence of
C     values for JT must be nondecreasing.  This may require some
C     preliminary interchanges of rows and columns of the matrix A.
C
C     The primary reason for these subroutines is that the total
C     processing can take place in a working array of dimension MU by
C     NB+1.  An acceptable value for MU is
C
C                       MU = MAX(MT + N + 1),
C
C     where N is the number of unknowns.
C
C     Here the maximum is taken over all values of MT for T=1,...,Q.
C     Notice that MT can be taken to be a small as one, showing that
C     MU can be as small as N+2.  The subprogram BNDACC processes the
C     rows more efficiently if MU is large enough so that each new
C     block (C F) has a distinct value of JT.
C
C     The four principle parts of these algorithms are obtained by the
C     following call statements
C
C     CALL BNDACC(...)  Introduce new blocks of data.
C
C     CALL BNDSOL(1,...)Compute solution vector and length of
C                       residual vector.
C
C     CALL BNDSOL(2,...)Given any row vector H solve YR = H for the
C                       row vector Y.
C
C     CALL BNDSOL(3,...)Given any column vector W solve RZ = W for
C                       the column vector Z.
C
C     The dots in the above call statements indicate additional
C     arguments that will be specified in the following paragraphs.
C
C     The user must dimension the array appearing in the call list..
C     G(MDG,NB+1)
C
C     Description of calling sequence for BNDACC..
C
C     The entire set of parameters for BNDACC are
C
C     Input..
C
C     G(*,*)            The working array into which the user will
C                       place the MT by NB+1 block (C F) in rows IR
C                       through IR+MT-1, columns 1 through NB+1.
C                       See descriptions of IR and MT below.
C
C     MDG               The number of rows in the working array
C                       G(*,*).  The value of MDG should be .GE. MU.
C                       The value of MU is defined in the abstract
C                       of these subprograms.
C
C     NB                The bandwidth of the data matrix A.
C
C     IP                Set by the user to the value 1 before the
C                       first call to BNDACC.  Its subsequent value
C                       is controlled by BNDACC to set up for the
C                       next call to BNDACC.
C
C     IR                Index of the row of G(*,*) where the user is
C                       to place the new block of data (C F).  Set by
C                       the user to the value 1 before the first call
C                       to BNDACC.  Its subsequent value is controlled
C                       by BNDACC. A value of IR .GT. MDG is considered
C                       an error.
C
C     MT,JT             Set by the user to indicate respectively the
C                       number of new rows of data in the block and
C                       the index of the first nonzero column in that
C                       set of rows (E F) = (0 C 0 F) being processed.
C
C     Output..
C
C     G(*,*)            The working array which will contain the
C                       processed rows of that part of the data
C                       matrix which has been passed to BNDACC.
C
C     IP,IR             The values of these arguments are advanced by
C                       BNDACC to be ready for storing and processing
C                       a new block of data in G(*,*).
C
C     Description of calling sequence for BNDSOL..
C
C     The user must dimension the arrays appearing in the call list..
C
C     G(MDG,NB+1), X(N)
C
C     The entire set of parameters for BNDSOL are
C
C     Input..
C
C     MODE              Set by the user to one of the values 1, 2, or
C                       3.  These values respectively indicate that
C                       the solution of AX = B, YR = H or RZ = W is
C                       required.
C
C     G(*,*),MDG,       These arguments all have the same meaning and
C      NB,IP,IR         contents as following the last call to BNDACC.
C
C     X(*)              With mode=2 or 3 this array contains,
C                       respectively, the right-side vectors H or W of
C                       the systems YR = H or RZ = W.
C
C     N                 The number of variables in the solution
C                       vector.  If any of the N diagonal terms are
C                       zero the subroutine BNDSOL prints an
C                       appropriate message.  This condition is
C                       considered an error.
C
C     Output..
C
C     X(*)              This array contains the solution vectors X,
C                       Y or Z of the systems AX = B, YR = H or
C                       RZ = W depending on the value of MODE=1,
C                       2 or 3.
C
C     RNORM             If MODE=1 RNORM is the Euclidean length of the
C                       residual vector AX-B.  When MODE=2 or 3 RNORM
C                       is set to zero.
C
C     Remarks..
C
C     To obtain the upper triangular matrix and transformed right-hand
C     side vector D so that the super diagonals of R form the columns
C     of G(*,*), execute the following Fortran statements.
C
C     NBP1=NB+1
C
C     DO 10 J=1, NBP1
C
C  10 G(IR,J) = 0.E0
C
C     MT=1
C
C     JT=N+1
C
C     CALL BNDACC(G,MDG,NB,IP,IR,MT,JT)
C
C***REFERENCES  C. L. Lawson and R. J. Hanson, Solving Least Squares
C                 Problems, Prentice-Hall, Inc., 1974, Chapter 27.
C***ROUTINES CALLED  H12, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790101  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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BNDACC
      DIMENSION G(MDG,*)
C***FIRST EXECUTABLE STATEMENT  BNDACC
      ZERO=0.
C
C              ALG. STEPS 1-4 ARE PERFORMED EXTERNAL TO THIS SUBROUTINE.
C
      NBP1=NB+1
      IF (MT.LE.0.OR.NB.LE.0) RETURN
C
      IF(.NOT.MDG.LT.IR) GO TO 5
      NERR=1
      IOPT=2
      CALL XERMSG ('SLATEC', 'BNDACC', 'MDG.LT.IR, PROBABLE ERROR.',
     +   NERR, IOPT)
      RETURN
    5 CONTINUE
C
C                                             ALG. STEP 5
      IF (JT.EQ.IP) GO TO 70
C                                             ALG. STEPS 6-7
      IF (JT.LE.IR) GO TO 30
C                                             ALG. STEPS 8-9
      DO 10 I=1,MT
        IG1=JT+MT-I
        IG2=IR+MT-I
        DO 10 J=1,NBP1
        G(IG1,J)=G(IG2,J)
   10 CONTINUE
C                                             ALG. STEP 10
      IE=JT-IR
      DO 20 I=1,IE
        IG=IR+I-1
        DO 20 J=1,NBP1
        G(IG,J)=ZERO
   20 CONTINUE
C                                             ALG. STEP 11
      IR=JT
C                                             ALG. STEP 12
   30 MU=MIN(NB-1,IR-IP-1)
      IF (MU.EQ.0) GO TO 60
C                                             ALG. STEP 13
      DO 50 L=1,MU
C                                             ALG. STEP 14
        K=MIN(L,JT-IP)
C                                             ALG. STEP 15
        LP1=L+1
        IG=IP+L
        DO 40 I=LP1,NB
          JG=I-K
          G(IG,JG)=G(IG,I)
   40 CONTINUE
C                                             ALG. STEP 16
        DO 50 I=1,K
        JG=NBP1-I
        G(IG,JG)=ZERO
   50 CONTINUE
C                                             ALG. STEP 17
   60 IP=JT
C                                             ALG. STEPS 18-19
   70 MH=IR+MT-IP
      KH=MIN(NBP1,MH)
C                                             ALG. STEP 20
      DO 80 I=1,KH
        CALL H12 (1,I,MAX(I+1,IR-IP+1),MH,G(IP,I),1,RHO,
     1            G(IP,I+1),1,MDG,NBP1-I)
   80 CONTINUE
C                                             ALG. STEP 21
      IR=IP+KH
C                                             ALG. STEP 22
      IF (KH.LT.NBP1) GO TO 100
C                                             ALG. STEP 23
      DO 90 I=1,NB
        G(IR-1,I)=ZERO
   90 CONTINUE
C                                             ALG. STEP 24
  100 CONTINUE
C                                             ALG. STEP 25
      RETURN
      END
*DECK BNDSOL
      SUBROUTINE BNDSOL (MODE, G, MDG, NB, IP, IR, X, N, RNORM)
C***BEGIN PROLOGUE  BNDSOL
C***PURPOSE  Solve the least squares problem for a banded matrix using
C            sequential accumulation of rows of the data matrix.
C            Exactly one right-hand side vector is permitted.
C***LIBRARY   SLATEC
C***CATEGORY  D9
C***TYPE      SINGLE PRECISION (BNDSOL-S, DBNDSL-D)
C***KEYWORDS  BANDED MATRIX, CURVE FITTING, LEAST SQUARES
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C***DESCRIPTION
C
C     These subroutines solve the least squares problem Ax = b for
C     banded matrices A using sequential accumulation of rows of the
C     data matrix.  Exactly one right-hand side vector is permitted.
C
C     These subroutines are intended for the type of least squares
C     systems that arise in applications such as curve or surface
C     fitting of data.  The least squares equations are accumulated and
C     processed using only part of the data.  This requires a certain
C     user interaction during the solution of Ax = b.
C
C     Specifically, suppose the data matrix (A B) is row partitioned
C     into Q submatrices.  Let (E F) be the T-th one of these
C     submatrices where E = (0 C 0).  Here the dimension of E is MT by N
C     and the dimension of C is MT by NB.  The value of NB is the
C     bandwidth of A.  The dimensions of the leading block of zeros in E
C     are MT by JT-1.
C
C     The user of the subroutine BNDACC provides MT,JT,C and F for
C     T=1,...,Q.  Not all of this data must be supplied at once.
C
C     Following the processing of the various blocks (E F), the matrix
C     (A B) has been transformed to the form (R D) where R is upper
C     triangular and banded with bandwidth NB.  The least squares
C     system Rx = d is then easily solved using back substitution by
C     executing the statement CALL BNDSOL(1,...). The sequence of
C     values for JT must be nondecreasing.  This may require some
C     preliminary interchanges of rows and columns of the matrix A.
C
C     The primary reason for these subroutines is that the total
C     processing can take place in a working array of dimension MU by
C     NB+1.  An acceptable value for MU is
C
C                       MU = MAX(MT + N + 1),
C
C     where N is the number of unknowns.
C
C     Here the maximum is taken over all values of MT for T=1,...,Q.
C     Notice that MT can be taken to be a small as one, showing that
C     MU can be as small as N+2.  The subprogram BNDACC processes the
C     rows more efficiently if MU is large enough so that each new
C     block (C F) has a distinct value of JT.
C
C     The four principle parts of these algorithms are obtained by the
C     following call statements
C
C     CALL BNDACC(...)  Introduce new blocks of data.
C
C     CALL BNDSOL(1,...)Compute solution vector and length of
C                       residual vector.
C
C     CALL BNDSOL(2,...)Given any row vector H solve YR = H for the
C                       row vector Y.
C
C     CALL BNDSOL(3,...)Given any column vector W solve RZ = W for
C                       the column vector Z.
C
C     The dots in the above call statements indicate additional
C     arguments that will be specified in the following paragraphs.
C
C     The user must dimension the array appearing in the call list..
C     G(MDG,NB+1)
C
C     Description of calling sequence for BNDACC..
C
C     The entire set of parameters for BNDACC are
C
C     Input..
C
C     G(*,*)            The working array into which the user will
C                       place the MT by NB+1 block (C F) in rows IR
C                       through IR+MT-1, columns 1 through NB+1.
C                       See descriptions of IR and MT below.
C
C     MDG               The number of rows in the working array
C                       G(*,*).  The value of MDG should be .GE. MU.
C                       The value of MU is defined in the abstract
C                       of these subprograms.
C
C     NB                The bandwidth of the data matrix A.
C
C     IP                Set by the user to the value 1 before the
C                       first call to BNDACC.  Its subsequent value
C                       is controlled by BNDACC to set up for the
C                       next call to BNDACC.
C
C     IR                Index of the row of G(*,*) where the user is
C                       the user to the value 1 before the first call
C                       to BNDACC.  Its subsequent value is controlled
C                       by BNDACC. A value of IR .GT. MDG is considered
C                       an error.
C
C     MT,JT             Set by the user to indicate respectively the
C                       number of new rows of data in the block and
C                       the index of the first nonzero column in that
C                       set of rows (E F) = (0 C 0 F) being processed.
C     Output..
C
C     G(*,*)            The working array which will contain the
C                       processed rows of that part of the data
C                       matrix which has been passed to BNDACC.
C
C     IP,IR             The values of these arguments are advanced by
C                       BNDACC to be ready for storing and processing
C                       a new block of data in G(*,*).
C
C     Description of calling sequence for BNDSOL..
C
C     The user must dimension the arrays appearing in the call list..
C
C     G(MDG,NB+1), X(N)
C
C     The entire set of parameters for BNDSOL are
C
C     Input..
C
C     MODE              Set by the user to one of the values 1, 2, or
C                       3.  These values respectively indicate that
C                       the solution of AX = B, YR = H or RZ = W is
C                       required.
C
C     G(*,*),MDG,       These arguments all have the same meaning and
C      NB,IP,IR         contents as following the last call to BNDACC.
C
C     X(*)              With mode=2 or 3 this array contains,
C                       respectively, the right-side vectors H or W of
C                       the systems YR = H or RZ = W.
C
C     N                 The number of variables in the solution
C                       vector.  If any of the N diagonal terms are
C                       zero the subroutine BNDSOL prints an
C                       appropriate message.  This condition is
C                       considered an error.
C
C     Output..
C
C     X(*)              This array contains the solution vectors X,
C                       Y or Z of the systems AX = B, YR = H or
C                       RZ = W depending on the value of MODE=1,
C                       2 or 3.
C
C     RNORM             If MODE=1 RNORM is the Euclidean length of the
C                       residual vector AX-B.  When MODE=2 or 3 RNORM
C                       is set to zero.
C
C     Remarks..
C
C     To obtain the upper triangular matrix and transformed right-hand
C     side vector D so that the super diagonals of R form the columns
C     of G(*,*), execute the following Fortran statements.
C
C     NBP1=NB+1
C
C     DO 10 J=1, NBP1
C
C  10 G(IR,J) = 0.E0
C
C     MT=1
C
C     JT=N+1
C
C     CALL BNDACC(G,MDG,NB,IP,IR,MT,JT)
C
C***REFERENCES  C. L. Lawson and R. J. Hanson, Solving Least Squares
C                 Problems, Prentice-Hall, Inc., 1974, Chapter 27.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790101  DATE WRITTEN
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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BNDSOL
      DIMENSION G(MDG,*),X(*)
C***FIRST EXECUTABLE STATEMENT  BNDSOL
      ZERO=0.
C
      RNORM=ZERO
      GO TO (10,90,50), MODE
C                                   ********************* MODE = 1
C                                   ALG. STEP 26
   10      DO 20 J=1,N
           X(J)=G(J,NB+1)
   20 CONTINUE
      RSQ=ZERO
      NP1=N+1
      IRM1=IR-1
      IF (NP1.GT.IRM1) GO TO 40
           DO 30 J=NP1,IRM1
           RSQ=RSQ+G(J,NB+1)**2
   30 CONTINUE
      RNORM=SQRT(RSQ)
   40 CONTINUE
C                                   ********************* MODE = 3
C                                   ALG. STEP 27
   50      DO 80 II=1,N
           I=N+1-II
C                                   ALG. STEP 28
           S=ZERO
           L=MAX(0,I-IP)
C                                   ALG. STEP 29
           IF (I.EQ.N) GO TO 70
C                                   ALG. STEP 30
           IE=MIN(N+1-I,NB)
                DO 60 J=2,IE
                JG=J+L
                IX=I-1+J
                S=S+G(I,JG)*X(IX)
   60 CONTINUE
C                                   ALG. STEP 31
   70      IF (G(I,L+1)) 80,130,80
   80      X(I)=(X(I)-S)/G(I,L+1)
C                                   ALG. STEP 32
      RETURN
C                                   ********************* MODE = 2
   90      DO 120 J=1,N
           S=ZERO
           IF (J.EQ.1) GO TO 110
           I1=MAX(1,J-NB+1)
           I2=J-1
                DO 100 I=I1,I2
                L=J-I+1+MAX(0,I-IP)
                S=S+X(I)*G(I,L)
  100 CONTINUE
  110      L=MAX(0,J-IP)
           IF (G(J,L+1)) 120,130,120
  120      X(J)=(X(J)-S)/G(J,L+1)
      RETURN
C
  130 CONTINUE
      NERR=1
      IOPT=2
      CALL XERMSG ('SLATEC', 'BNDSOL',
     +   'A ZERO DIAGONAL TERM IS IN THE N BY N UPPER TRIANGULAR ' //
     +   'MATRIX.', NERR, IOPT)
      RETURN
      END
*DECK BNFAC
      SUBROUTINE BNFAC (W, NROWW, NROW, NBANDL, NBANDU, IFLAG)
C***BEGIN PROLOGUE  BNFAC
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BINT4 and BINTK
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BNFAC-S, DBNFAC-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C  BNFAC is the BANFAC routine from
C        * A Practical Guide to Splines *  by C. de Boor
C
C  Returns in  W  the lu-factorization (without pivoting) of the banded
C  matrix  A  of order  NROW  with  (NBANDL + 1 + NBANDU) bands or diag-
C  onals in the work array  W .
C
C *****  I N P U T  ******
C  W.....Work array of size  (NROWW,NROW)  containing the interesting
C        part of a banded matrix  A , with the diagonals or bands of  A
C        stored in the rows of  W , while columns of  A  correspond to
C        columns of  W . This is the storage mode used in  LINPACK  and
C        results in efficient innermost loops.
C           Explicitly,  A  has  NBANDL  bands below the diagonal
C                            +     1     (main) diagonal
C                            +   NBANDU  bands above the diagonal
C        and thus, with    MIDDLE = NBANDU + 1,
C          A(I+J,J)  is in  W(I+MIDDLE,J)  for I=-NBANDU,...,NBANDL
C                                              J=1,...,NROW .
C        For example, the interesting entries of A (1,2)-banded matrix
C        of order  9  would appear in the first  1+1+2 = 4  rows of  W
C        as follows.
C                          13 24 35 46 57 68 79
C                       12 23 34 45 56 67 78 89
C                    11 22 33 44 55 66 77 88 99
C                    21 32 43 54 65 76 87 98
C
C        All other entries of  W  not identified in this way with an en-
C        try of  A  are never referenced .
C  NROWW.....Row dimension of the work array  W .
C        must be  .GE.  NBANDL + 1 + NBANDU  .
C  NBANDL.....Number of bands of  A  below the main diagonal
C  NBANDU.....Number of bands of  A  above the main diagonal .
C
C *****  O U T P U T  ******
C  IFLAG.....Integer indicating success( = 1) or failure ( = 2) .
C     If  IFLAG = 1, then
C  W.....contains the LU-factorization of  A  into a unit lower triangu-
C        lar matrix  L  and an upper triangular matrix  U (both banded)
C        and stored in customary fashion over the corresponding entries
C        of  A . This makes it possible to solve any particular linear
C        system  A*X = B  for  X  by A
C              CALL BNSLV ( W, NROWW, NROW, NBANDL, NBANDU, B )
C        with the solution X  contained in  B  on return .
C     If  IFLAG = 2, then
C        one of  NROW-1, NBANDL,NBANDU failed to be nonnegative, or else
C        one of the potential pivots was found to be zero indicating
C        that  A  does not have an LU-factorization. This implies that
C        A  is singular in case it is totally positive .
C
C *****  M E T H O D  ******
C     Gauss elimination  W I T H O U T  pivoting is used. The routine is
C  intended for use with matrices  A  which do not require row inter-
C  changes during factorization, especially for the  T O T A L L Y
C  P O S I T I V E  matrices which occur in spline calculations.
C     The routine should not be used for an arbitrary banded matrix.
C
C***SEE ALSO  BINT4, BINTK
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  BNFAC
C
      INTEGER IFLAG, NBANDL, NBANDU, NROW, NROWW, I, IPK, J, JMAX, K,
     1 KMAX, MIDDLE, MIDMK, NROWM1
      REAL W(NROWW,*), FACTOR, PIVOT
C
C***FIRST EXECUTABLE STATEMENT  BNFAC
      IFLAG = 1
      MIDDLE = NBANDU + 1
C                         W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF  A .
      NROWM1 = NROW - 1
      IF (NROWM1) 120, 110, 10
   10 IF (NBANDL.GT.0) GO TO 30
C                A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO .
      DO 20 I=1,NROWM1
        IF (W(MIDDLE,I).EQ.0.0E0) GO TO 120
   20 CONTINUE
      GO TO 110
   30 IF (NBANDU.GT.0) GO TO 60
C              A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND
C                 DIVIDE EACH COLUMN BY ITS DIAGONAL .
      DO 50 I=1,NROWM1
        PIVOT = W(MIDDLE,I)
        IF (PIVOT.EQ.0.0E0) GO TO 120
        JMAX = MIN(NBANDL,NROW-I)
        DO 40 J=1,JMAX
          W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT
   40   CONTINUE
   50 CONTINUE
      RETURN
C
C        A  IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION
   60 DO 100 I=1,NROWM1
C                                  W(MIDDLE,I)  IS PIVOT FOR I-TH STEP .
        PIVOT = W(MIDDLE,I)
        IF (PIVOT.EQ.0.0E0) GO TO 120
C                 JMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN  I
C                     BELOW THE DIAGONAL .
        JMAX = MIN(NBANDL,NROW-I)
C              DIVIDE EACH ENTRY IN COLUMN  I  BELOW DIAGONAL BY PIVOT .
        DO 70 J=1,JMAX
          W(MIDDLE+J,I) = W(MIDDLE+J,I)/PIVOT
   70   CONTINUE
C                 KMAX  IS THE NUMBER OF (NONZERO) ENTRIES IN ROW  I  TO
C                     THE RIGHT OF THE DIAGONAL .
        KMAX = MIN(NBANDU,NROW-I)
C                  SUBTRACT  A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN
C                  (BELOW ROW  I ) .
        DO 90 K=1,KMAX
          IPK = I + K
          MIDMK = MIDDLE - K
          FACTOR = W(MIDMK,IPK)
          DO 80 J=1,JMAX
            W(MIDMK+J,IPK) = W(MIDMK+J,IPK) - W(MIDDLE+J,I)*FACTOR
   80     CONTINUE
   90   CONTINUE
  100 CONTINUE
C                                       CHECK THE LAST DIAGONAL ENTRY .
  110 IF (W(MIDDLE,NROW).NE.0.0E0) RETURN
  120 IFLAG = 2
      RETURN
      END
*DECK BNSLV
      SUBROUTINE BNSLV (W, NROWW, NROW, NBANDL, NBANDU, B)
C***BEGIN PROLOGUE  BNSLV
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BINT4 and BINTK
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BNSLV-S, DBNSLV-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C  BNSLV is the BANSLV routine from
C        * A Practical Guide to Splines *  by C. de Boor
C
C  Companion routine to  BNFAC . It returns the solution  X  of the
C  linear system  A*X = B  in place of  B , given the LU-factorization
C  for  A  in the work array  W from BNFAC.
C
C *****  I N P U T  ******
C  W, NROWW,NROW,NBANDL,NBANDU.....Describe the LU-factorization of a
C        banded matrix  A  of order  NROW  as constructed in  BNFAC .
C        For details, see  BNFAC .
C  B.....Right side of the system to be solved .
C
C *****  O U T P U T  ******
C  B.....Contains the solution  X , of order  NROW .
C
C *****  M E T H O D  ******
C     (With  A = L*U, as stored in  W,) the unit lower triangular system
C  L(U*X) = B  is solved for  Y = U*X, and  Y  stored in  B . Then the
C  upper triangular system  U*X = Y  is solved for  X  . The calcul-
C  ations are so arranged that the innermost loops stay within columns.
C
C***SEE ALSO  BINT4, BINTK
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  BNSLV
C
      INTEGER NBANDL, NBANDU, NROW, NROWW, I, J, JMAX, MIDDLE, NROWM1
      REAL W(NROWW,*), B(*)
C***FIRST EXECUTABLE STATEMENT  BNSLV
      MIDDLE = NBANDU + 1
      IF (NROW.EQ.1) GO TO 80
      NROWM1 = NROW - 1
      IF (NBANDL.EQ.0) GO TO 30
C                                 FORWARD PASS
C            FOR I=1,2,...,NROW-1, SUBTRACT  RIGHT SIDE(I)*(I-TH COLUMN
C            OF  L )  FROM RIGHT SIDE  (BELOW I-TH ROW) .
      DO 20 I=1,NROWM1
        JMAX = MIN(NBANDL,NROW-I)
        DO 10 J=1,JMAX
          B(I+J) = B(I+J) - B(I)*W(MIDDLE+J,I)
   10   CONTINUE
   20 CONTINUE
C                                 BACKWARD PASS
C            FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG-
C            ONAL ENTRY OF  U, THEN SUBTRACT  RIGHT SIDE(I)*(I-TH COLUMN
C            OF  U)  FROM RIGHT SIDE  (ABOVE I-TH ROW).
   30 IF (NBANDU.GT.0) GO TO 50
C                                A  IS LOWER TRIANGULAR .
      DO 40 I=1,NROW
        B(I) = B(I)/W(1,I)
   40 CONTINUE
      RETURN
   50 I = NROW
   60 B(I) = B(I)/W(MIDDLE,I)
      JMAX = MIN(NBANDU,I-1)
      DO 70 J=1,JMAX
        B(I-J) = B(I-J) - B(I)*W(MIDDLE-J,I)
   70 CONTINUE
      I = I - 1
      IF (I.GT.1) GO TO 60
   80 B(1) = B(1)/W(MIDDLE,1)
      RETURN
      END
*DECK BQR
      SUBROUTINE BQR (NM, N, MB, A, T, R, IERR, NV, RV)
C***BEGIN PROLOGUE  BQR
C***PURPOSE  Compute some of the eigenvalues of a real symmetric
C            matrix using the QR method with shifts of origin.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A6
C***TYPE      SINGLE PRECISION (BQR-S)
C***KEYWORDS  EIGENVALUES, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure BQR,
C     NUM. MATH. 16, 85-92(1970) by Martin, Reinsch, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 266-272(1971).
C
C     This subroutine finds the eigenvalue of smallest (usually)
C     magnitude of a REAL SYMMETRIC BAND matrix using the
C     QR algorithm with shifts of origin.  Consecutive calls
C     can be made to find further eigenvalues.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameter, A, as declared in the calling program
C          dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        MB is the (half) band width of the matrix, defined as the
C          number of adjacent diagonals, including the principal
C          diagonal, required to specify the non-zero portion of the
C          lower triangle of the matrix.  MB is an INTEGER variable.
C          MB must be less than or equal to N on first call.
C
C        A contains the lower triangle of the symmetric band input
C          matrix stored as an N by MB array.  Its lowest subdiagonal
C          is stored in the last N+1-MB positions of the first column,
C          its next subdiagonal in the last N+2-MB positions of the
C          second column, further subdiagonals similarly, and finally
C          its principal diagonal in the N positions of the last column.
C          Contents of storages not part of the matrix are arbitrary.
C          On a subsequent call, its output contents from the previous
C          call should be passed.  A is a two-dimensional REAL array,
C          dimensioned A(NM,MB).
C
C        T specifies the shift (of eigenvalues) applied to the diagonal
C          of A in forming the input matrix. What is actually determined
C          is the eigenvalue of A+TI (I is the identity matrix) nearest
C          to T.  On a subsequent call, the output value of T from the
C          previous call should be passed if the next nearest eigenvalue
C          is sought.  T is a REAL variable.
C
C        R should be specified as zero on the first call, and as its
C          output value from the previous call on a subsequent call.
C          It is used to determine when the last row and column of
C          the transformed band matrix can be regarded as negligible.
C          R is a REAL variable.
C
C        NV must be set to the dimension of the array parameter RV
C          as declared in the calling program dimension statement.
C          NV is an INTEGER variable.
C
C     On OUTPUT
C
C        A contains the transformed band matrix.  The matrix A+TI
C          derived from the output parameters is similar to the
C          input A+TI to within rounding errors.  Its last row and
C          column are null (if IERR is zero).
C
C        T contains the computed eigenvalue of A+TI (if IERR is zero),
C          where I is the identity matrix.
C
C        R contains the maximum of its input value and the norm of the
C          last column of the input matrix A.
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          J          if the J-th eigenvalue has not been
C                     determined after a total of 30 iterations.
C
C        RV is a one-dimensional REAL array of dimension NV which is
C          at least (2*MB**2+4*MB-3), used for temporary storage.  The
C          first (3*MB-2) locations correspond to the ALGOL array B,
C          the next (2*MB-1) locations correspond to the ALGOL array H,
C          and the final (2*MB**2-MB) locations correspond to the MB
C          by (2*MB-1) ALGOL array U.
C
C     NOTE. For a subsequent call, N should be replaced by N-1, but
C     MB should not be altered even when it exceeds the current N.
C
C     Calls PYTHAG(A,B) for SQRT(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     Applied Mathematics Division, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   760101  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BQR
C
      INTEGER I,J,K,L,M,N,II,IK,JK,JM,KJ,KK,KM,LL,MB,MK,MN,MZ
      INTEGER M1,M2,M3,M4,NI,NM,NV,ITS,KJ1,M21,M31,IERR,IMULT
      REAL A(NM,*),RV(*)
      REAL F,G,Q,R,S,T,SCALE
      REAL PYTHAG
C
C***FIRST EXECUTABLE STATEMENT  BQR
      IERR = 0
      M1 = MIN(MB,N)
      M = M1 - 1
      M2 = M + M
      M21 = M2 + 1
      M3 = M21 + M
      M31 = M3 + 1
      M4 = M31 + M2
      MN = M + N
      MZ = MB - M1
      ITS = 0
C     .......... TEST FOR CONVERGENCE ..........
   40 G = A(N,MB)
      IF (M .EQ. 0) GO TO 360
      F = 0.0E0
C
      DO 50 K = 1, M
         MK = K + MZ
         F = F + ABS(A(N,MK))
   50 CONTINUE
C
      IF (ITS .EQ. 0 .AND. F .GT. R) R = F
      IF (R + F .LE. R) GO TO 360
      IF (ITS .EQ. 30) GO TO 1000
      ITS = ITS + 1
C     .......... FORM SHIFT FROM BOTTOM 2 BY 2 MINOR ..........
      IF (F .GT. 0.25E0 * R .AND. ITS .LT. 5) GO TO 90
      F = A(N,MB-1)
      IF (F .EQ. 0.0E0) GO TO 70
      Q = (A(N-1,MB) - G) / (2.0E0 * F)
      S = PYTHAG(Q,1.0E0)
      G = G - F / (Q + SIGN(S,Q))
   70 T = T + G
C
      DO 80 I = 1, N
   80 A(I,MB) = A(I,MB) - G
C
   90 DO 100 K = M31, M4
  100 RV(K) = 0.0E0
C
      DO 350 II = 1, MN
         I = II - M
         NI = N - II
         IF (NI .LT. 0) GO TO 230
C     .......... FORM COLUMN OF SHIFTED MATRIX A-G*I ..........
         L = MAX(1,2-I)
C
         DO 110 K = 1, M3
  110    RV(K) = 0.0E0
C
         DO 120 K = L, M1
            KM = K + M
            MK = K + MZ
            RV(KM) = A(II,MK)
  120    CONTINUE
C
         LL = MIN(M,NI)
         IF (LL .EQ. 0) GO TO 135
C
         DO 130 K = 1, LL
            KM = K + M21
            IK = II + K
            MK = MB - K
            RV(KM) = A(IK,MK)
  130    CONTINUE
C     .......... PRE-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
  135    LL = M2
         IMULT = 0
C     .......... MULTIPLICATION PROCEDURE ..........
  140    KJ = M4 - M1
C
         DO 170 J = 1, LL
            KJ = KJ + M1
            JM = J + M3
            IF (RV(JM) .EQ. 0.0E0) GO TO 170
            F = 0.0E0
C
            DO 150 K = 1, M1
               KJ = KJ + 1
               JK = J + K - 1
               F = F + RV(KJ) * RV(JK)
  150       CONTINUE
C
            F = F / RV(JM)
            KJ = KJ - M1
C
            DO 160 K = 1, M1
               KJ = KJ + 1
               JK = J + K - 1
               RV(JK) = RV(JK) - RV(KJ) * F
  160       CONTINUE
C
            KJ = KJ - M1
  170    CONTINUE
C
         IF (IMULT .NE. 0) GO TO 280
C     .......... HOUSEHOLDER REFLECTION ..........
         F = RV(M21)
         S = 0.0E0
         RV(M4) = 0.0E0
         SCALE = 0.0E0
C
         DO 180 K = M21, M3
  180    SCALE = SCALE + ABS(RV(K))
C
         IF (SCALE .EQ. 0.0E0) GO TO 210
C
         DO 190 K = M21, M3
  190    S = S + (RV(K)/SCALE)**2
C
         S = SCALE * SCALE * S
         G = -SIGN(SQRT(S),F)
         RV(M21) = G
         RV(M4) = S - F * G
         KJ = M4 + M2 * M1 + 1
         RV(KJ) = F - G
C
         DO 200 K = 2, M1
            KJ = KJ + 1
            KM = K + M2
            RV(KJ) = RV(KM)
  200    CONTINUE
C     .......... SAVE COLUMN OF TRIANGULAR FACTOR R ..........
  210    DO 220 K = L, M1
            KM = K + M
            MK = K + MZ
            A(II,MK) = RV(KM)
  220    CONTINUE
C
  230    L = MAX(1,M1+1-I)
         IF (I .LE. 0) GO TO 300
C     .......... PERFORM ADDITIONAL STEPS ..........
         DO 240 K = 1, M21
  240    RV(K) = 0.0E0
C
         LL = MIN(M1,NI+M1)
C     .......... GET ROW OF TRIANGULAR FACTOR R ..........
         DO 250 KK = 1, LL
            K = KK - 1
            KM = K + M1
            IK = I + K
            MK = MB - K
            RV(KM) = A(IK,MK)
  250    CONTINUE
C     .......... POST-MULTIPLY WITH HOUSEHOLDER REFLECTIONS ..........
         LL = M1
         IMULT = 1
         GO TO 140
C     .......... STORE COLUMN OF NEW A MATRIX ..........
  280    DO 290 K = L, M1
            MK = K + MZ
            A(I,MK) = RV(K)
  290    CONTINUE
C     .......... UPDATE HOUSEHOLDER REFLECTIONS ..........
  300    IF (L .GT. 1) L = L - 1
         KJ1 = M4 + L * M1
C
         DO 320 J = L, M2
            JM = J + M3
            RV(JM) = RV(JM+1)
C
            DO 320 K = 1, M1
               KJ1 = KJ1 + 1
               KJ = KJ1 - M1
               RV(KJ) = RV(KJ1)
  320    CONTINUE
C
  350 CONTINUE
C
      GO TO 40
C     .......... CONVERGENCE ..........
  360 T = T + G
C
      DO 380 I = 1, N
  380 A(I,MB) = A(I,MB) - G
C
      DO 400 K = 1, M1
         MK = K + MZ
         A(N,MK) = 0.0E0
  400 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- NO CONVERGENCE TO
C                EIGENVALUE AFTER 30 ITERATIONS ..........
 1000 IERR = N
 1001 RETURN
      END
*DECK BSGQ8
      SUBROUTINE BSGQ8 (FUN, XT, BC, N, KK, ID, A, B, INBV, ERR, ANS,
     +   IERR, WORK)
C***BEGIN PROLOGUE  BSGQ8
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BFQAD
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BSGQ8-S, DBSGQ8-D)
C***AUTHOR  Jones, R. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C        BSGQ8, a modification of GAUS8, integrates the
C        product of FUN(X) by the ID-th derivative of a spline
C        BVALU(XT,BC,N,KK,ID,X,INBV,WORK)  between limits A and B.
C
C     Description of Arguments
C
C        INPUT--
C        FUN - Name of external function of one argument which
C              multiplies BVALU.
C        XT  - Knot array for BVALU
C        BC  - B-coefficient array for BVALU
C        N   - Number of B-coefficients for BVALU
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        INBV- Initialization parameter for BVALU
C        ERR - Is a requested pseudorelative error tolerance.  Normally
C              pick a value of ABS(ERR).LT.1E-3.  ANS will normally
C              have no more error than ABS(ERR) times the integral of
C              the absolute value of FUN(X)*BVALU(XT,BC,N,KK,X,ID,
C              INBV,WORK).
C
C
C        OUTPUT--
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        WORK- Work vector of length 3*K for BVALU
C
C***SEE ALSO  BFQAD
C***ROUTINES CALLED  BVALU, I1MACH, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (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  BSGQ8
C
      INTEGER ID, IERR, INBV, K, KK, KML, KMX, L, LMN, LMX, LR, MXL,
     1 N, NBITS, NIB, NLMN, NLMX
      INTEGER I1MACH
      REAL A, AA, AE, ANIB, ANS, AREA, B, BC, C, CE, EE, EF, EPS, ERR,
     1 EST,GL,GLR,GR,HH,SQ2,TOL,VL,VR,WORK,W1, W2, W3, W4, XT, X1,
     2 X2, X3, X4, X, H
      REAL R1MACH, BVALU, G8, FUN
      DIMENSION XT(*), BC(*)
      DIMENSION AA(30), HH(30), LR(30), VL(30), GR(30)
      SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2, NLMN, KMX, KML
      DATA X1, X2, X3, X4/
     1     1.83434642495649805E-01,     5.25532409916328986E-01,
     2     7.96666477413626740E-01,     9.60289856497536232E-01/
      DATA W1, W2, W3, W4/
     1     3.62683783378361983E-01,     3.13706645877887287E-01,
     2     2.22381034453374471E-01,     1.01228536290376259E-01/
      DATA SQ2/1.41421356E0/
      DATA NLMN/1/,KMX/5000/,KML/6/
      G8(X,H)=H*((W1*(FUN(X-X1*H)*BVALU(XT,BC,N,KK,ID,X-X1*H,INBV,WORK)+
     1                FUN(X+X1*H)*BVALU(XT,BC,N,KK,ID,X+X1*H,INBV,WORK))
     2           +W2*(FUN(X-X2*H)*BVALU(XT,BC,N,KK,ID,X-X2*H,INBV,WORK)+
     3              FUN(X+X2*H)*BVALU(XT,BC,N,KK,ID,X+X2*H,INBV,WORK)))
     4          +(W3*(FUN(X-X3*H)*BVALU(XT,BC,N,KK,ID,X-X3*H,INBV,WORK)+
     5                FUN(X+X3*H)*BVALU(XT,BC,N,KK,ID,X+X3*H,INBV,WORK))
     6           +W4*(FUN(X-X4*H)*BVALU(XT,BC,N,KK,ID,X-X4*H,INBV,WORK)+
     7             FUN(X+X4*H)*BVALU(XT,BC,N,KK,ID,X+X4*H,INBV,WORK))))
C
C     INITIALIZE
C
C***FIRST EXECUTABLE STATEMENT  BSGQ8
      K = I1MACH(11)
      ANIB = R1MACH(5)*K/0.30102000E0
      NBITS = INT(ANIB)
      NLMX = (NBITS*5)/8
      ANS = 0.0E0
      IERR = 1
      CE = 0.0E0
      IF (A.EQ.B) GO TO 140
      LMX = NLMX
      LMN = NLMN
      IF (B.EQ.0.0E0) GO TO 10
      IF (SIGN(1.0E0,B)*A.LE.0.0E0) GO TO 10
      C = ABS(1.0E0-A/B)
      IF (C.GT.0.1E0) GO TO 10
      IF (C.LE.0.0E0) GO TO 140
      ANIB = 0.5E0 - LOG(C)/0.69314718E0
      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.0E0**(5-NBITS))/2.0E0
      IF (ERR.EQ.0.0E0) TOL = SQRT(R1MACH(4))
      EPS = TOL
      HH(1) = (B-A)/4.0E0
      AA(1) = A
      LR(1) = 1
      L = 1
      EST = G8(AA(L)+2.0E0*HH(L),2.0E0*HH(L))
      K = 8
      AREA = ABS(EST)
      EF = 0.5E0
      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.0E0*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 CE = CE + (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.5E0
      EF = EF/SQ2
      HH(L) = HH(L-1)*0.5E0
      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.0E0*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.0E0
      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(CE).LE.2.0E0*TOL*AREA)) GO TO 140
      IERR = 2
      CALL XERMSG ('SLATEC', 'BSGQ8',
     +   'ANS IS PROBABLY INSUFFICIENTLY ACCURATE.', 3, 1)
      GO TO 140
  130 IERR = -1
      CALL XERMSG ('SLATEC', 'BSGQ8',
     +   'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL INTEGRATION. ' //
     +   ' ANS IS SET TO ZERO AND IERR TO -1.', 1, -1)
  140 CONTINUE
      IF (ERR.LT.0.0E0) ERR = CE
      RETURN
      END
*DECK BSKIN
      SUBROUTINE BSKIN (X, N, KODE, M, Y, NZ, IERR)
C***BEGIN PROLOGUE  BSKIN
C***PURPOSE  Compute repeated integrals of the K-zero Bessel function.
C***LIBRARY   SLATEC
C***CATEGORY  C10F
C***TYPE      SINGLE PRECISION (BSKIN-S, DBSKIN-D)
C***KEYWORDS  BICKLEY FUNCTIONS, EXPONENTIAL INTEGRAL,
C             INTEGRALS OF BESSEL FUNCTIONS, K-ZERO BESSEL FUNCTION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C         The following definitions are used in BSKIN:
C
C   Definition 1
C         KI(0,X) = K-zero Bessel function.
C
C   Definition 2
C         KI(N,X) = Bickley Function
C                 =  integral from X to infinity of KI(N-1,t)dt
C                     for X .ge. 0 and N = 1,2,...
C   ____________________________________________________________________
C      BSKIN computes sequences of Bickley functions (repeated integrals
C      of the K0 Bessel function); i.e. for fixed X and N and K=1,...,
C      BSKIN computes the M-member sequence
C
C                     Y(K) =        KI(N+K-1,X) for KODE=1
C      or
C                     Y(K) = EXP(X)*KI(N+K-1,X) for KODE=2,
C
C      for N.ge.0 and X.ge.0 (N and X cannot be zero simultaneously).
C
C      INPUT
C        X      - Argument, X .ge. 0.0E0
C        N      - Order of first member of the sequence N .ge. 0
C        KODE   - Selection parameter
C                 KODE = 1 returns Y(K)=       KI(N+K-1,X), K=1,M
C                      = 2 returns Y(K)=EXP(X)*KI(N+K-1,X), K=1,M
C        M      - Number of members in the sequence, M.ge.1
C
C      OUTPUT
C        Y      - A vector of dimension at least M containing the
C                 sequence selected by KODE.
C        NZ     - Underflow flag
C                 NZ = 0 means computation completed
C                    = M means an exponential underflow occurred on
C                        KODE=1.  Y(K)=0.0E0, K=1,...,M is returned
C        IERR   - Error flag
C                 IERR = 0, Normal return, computation completed.
C                      = 1, Input error,   no computation.
C                      = 2, Error,         no computation.  The
C                           termination condition was not met.
C
C      The nominal computational accuracy is the maximum of unit
C      roundoff (=R1MACH(4)) and 1.0e-18 since critical constants
C      are given to only 18 digits.
C
C      DBSKIN is the double precision version of BSKIN.
C
C *Long Description:
C
C         Numerical recurrence on
C
C      (L-1)*KI(L,X) = X(KI(L-3,X) - KI(L-1,X)) + (L-2)*KI(L-2,X)
C
C         is stable where recurrence is carried forward or backward
C         away from INT(X+0.5).  The power series for indices 0,1 and 2
C         on 0.le.X.le. 2 starts a stable recurrence for indices
C         greater than 2.  If N is sufficiently large (N.gt.NLIM), the
C         uniform asymptotic expansion for N to INFINITY is more
C         economical.  On X.gt.2 the recursion is started by evaluating
C         the uniform expansion for the three members whose indices are
C         closest to INT(X+0.5) within the set N,...,N+M-1.  Forward
C         recurrence, backward recurrence or both, complete the
C         sequence depending on the relation of INT(X+0.5) to the
C         indices N,...,N+M-1.
C
C***REFERENCES  D. E. Amos, Uniform asymptotic expansions for
C                 exponential integrals E(N,X) and Bickley functions
C                 KI(N,X), ACM Transactions on Mathematical Software,
C                 1983.
C               D. E. Amos, A portable Fortran subroutine for the
C                 Bickley functions KI(N,X), Algorithm 609, ACM
C                 Transactions on Mathematical Software, 1983.
C***ROUTINES CALLED  BKIAS, BKISR, EXINT, GAMRN, I1MACH, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement label.  (WRB)
C   891009  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  BSKIN
      INTEGER I, ICASE, IERR, IL, I1M, K, KK, KODE, KTRMS, M,
     * M3, N, NE, NFLG, NL, NLIM, NN, NP, NS, NT, NZ
      INTEGER I1MACH
      REAL A, ENLIM, EXI, FN, GR, H, HN, HRTPI, SS, TOL, T1, T2, W, X,
     * XLIM, XNLIM, XP, Y, YS, YSS
      REAL GAMRN, R1MACH
      DIMENSION EXI(102), A(50), YS(3), YSS(3), H(31), Y(*)
      SAVE A, HRTPI
C-----------------------------------------------------------------------
C             COEFFICIENTS IN SERIES OF EXPONENTIAL INTEGRALS
C-----------------------------------------------------------------------
      DATA A(1), A(2), A(3), A(4), A(5), A(6), A(7), A(8), A(9), A(10),
     * A(11), A(12), A(13), A(14), A(15), A(16), A(17), A(18), A(19),
     * A(20), A(21), A(22), A(23), A(24) /1.00000000000000000E+00,
     * 5.00000000000000000E-01,3.75000000000000000E-01,
     * 3.12500000000000000E-01,2.73437500000000000E-01,
     * 2.46093750000000000E-01,2.25585937500000000E-01,
     * 2.09472656250000000E-01,1.96380615234375000E-01,
     * 1.85470581054687500E-01,1.76197052001953125E-01,
     * 1.68188095092773438E-01,1.61180257797241211E-01,
     * 1.54981017112731934E-01,1.49445980787277222E-01,
     * 1.44464448094367981E-01,1.39949934091418982E-01,
     * 1.35833759559318423E-01,1.32060599571559578E-01,
     * 1.28585320635465905E-01,1.25370687619579257E-01,
     * 1.22385671247684513E-01,1.19604178719328047E-01,
     * 1.17004087877603524E-01/
      DATA A(25), A(26), A(27), A(28), A(29), A(30), A(31), A(32),
     * A(33), A(34), A(35), A(36), A(37), A(38), A(39), A(40), A(41),
     * A(42), A(43), A(44), A(45), A(46), A(47), A(48)
     * /1.14566502713486784E-01,1.12275172659217048E-01,
     * 1.10116034723462874E-01,1.08076848895250599E-01,
     * 1.06146905164978267E-01,1.04316786110409676E-01,
     * 1.02578173008569515E-01,1.00923686347140974E-01,
     * 9.93467537479668965E-02,9.78414999033007314E-02,
     * 9.64026543164874854E-02,9.50254735405376642E-02,
     * 9.37056752969190855E-02,9.24393823875012600E-02,
     * 9.12230747245078224E-02,9.00535481254756708E-02,
     * 8.89278787739072249E-02,8.78433924473961612E-02,
     * 8.67976377754033498E-02,8.57883629175498224E-02,
     * 8.48134951571231199E-02,8.38711229887106408E-02,
     * 8.29594803475290034E-02,8.20769326842574183E-02/
      DATA A(49), A(50) /8.12219646354630702E-02,8.03931690779583449E-02
     * /
C-----------------------------------------------------------------------
C             SQRT(PI)/2
C-----------------------------------------------------------------------
      DATA HRTPI /8.86226925452758014E-01/
C
C***FIRST EXECUTABLE STATEMENT  BSKIN
      IERR = 0
      NZ=0
      IF (X.LT.0.0E0) 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 (X.EQ.0.0E0 .AND. N.EQ.0) IERR=1
      IF (IERR.NE.0) RETURN
      IF (X.EQ.0.0E0) GO TO 300
      I1M = -I1MACH(12)
      T1 = 2.3026E0*R1MACH(5)*I1M
      XLIM = T1 - 3.228086E0
      T2 = T1 + N + M - 1
      IF (T2.GT.1000.0E0) XLIM = T1 - 0.5E0*(LOG(T2)-0.451583E0)
      IF (X.GT.XLIM .AND. KODE.EQ.1) GO TO 320
      TOL = MAX(R1MACH(4),1.0E-18)
      I1M = I1MACH(11)
C-----------------------------------------------------------------------
C     LN(NLIM) = 0.125*LN(EPS),   NLIM = 2*KTRMS+N
C-----------------------------------------------------------------------
      XNLIM = 0.287823E0*(I1M-1)*R1MACH(5)
      ENLIM = EXP(XNLIM)
      NLIM = INT(ENLIM) + 2
      NLIM = MIN(100,NLIM)
      NLIM = MAX(20,NLIM)
      M3 = MIN(M,3)
      NL = N + M - 1
      IF (X.GT.2.0E0) GO TO 130
      IF (N.GT.NLIM) GO TO 280
C-----------------------------------------------------------------------
C     COMPUTATION BY SERIES FOR 0.LE.X.LE.2
C-----------------------------------------------------------------------
      NFLG = 0
      NN = N
      IF (NL.LE.2) GO TO 60
      M3 = 3
      NN = 0
      NFLG = 1
   60 CONTINUE
      XP = 1.0E0
      IF (KODE.EQ.2) XP = EXP(X)
      DO 80 I=1,M3
        CALL BKISR(X, NN, W, IERR)
      IF(IERR.NE.0) RETURN
        W = W*XP
        IF (NN.LT.N) GO TO 70
        KK = NN - N + 1
        Y(KK) = W
   70   CONTINUE
        YS(I) = W
        NN = NN + 1
   80 CONTINUE
      IF (NFLG.EQ.0) RETURN
      NS = NN
      XP = 1.0E0
   90 CONTINUE
C-----------------------------------------------------------------------
C     FORWARD RECURSION SCALED BY EXP(X) ON ICASE=0,1,2
C-----------------------------------------------------------------------
      FN = NS - 1
      IL = NL - NS + 1
      IF (IL.LE.0) RETURN
      DO 110 I=1,IL
        T1 = YS(2)
        T2 = YS(3)
        YS(3) = (X*(YS(1)-YS(3))+(FN-1.0E0)*YS(2))/FN
        YS(2) = T2
        YS(1) = T1
        FN = FN + 1.0E0
        IF (NS.LT.N) GO TO 100
        KK = NS - N + 1
        Y(KK) = YS(3)*XP
  100   CONTINUE
        NS = NS + 1
  110 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     COMPUTATION BY ASYMPTOTIC EXPANSION FOR X.GT.2
C-----------------------------------------------------------------------
  130 CONTINUE
      W = X + 0.5E0
      NT = INT(W)
      IF (NL.GT.NT) GO TO 270
C-----------------------------------------------------------------------
C     CASE NL.LE.NT, ICASE=0
C-----------------------------------------------------------------------
      ICASE = 0
      NN = NL
      NFLG = MIN(M-M3,1)
  140 CONTINUE
      KK = (NLIM-NN)/2
      KTRMS = MAX(0,KK)
      NS = NN + 1
      NP = NN - M3 + 1
      XP = 1.0E0
      IF (KODE.EQ.1) XP = EXP(-X)
      DO 150 I=1,M3
        KK = I
        CALL BKIAS(X, NP, KTRMS, A, W, KK, NE, GR, H, IERR)
      IF(IERR.NE.0) RETURN
        YS(I) = W
        NP = NP + 1
  150 CONTINUE
C-----------------------------------------------------------------------
C     SUM SERIES OF EXPONENTIAL INTEGRALS BACKWARD
C-----------------------------------------------------------------------
      IF (KTRMS.EQ.0) GO TO 160
      NE = KTRMS + KTRMS + 1
      NP = NN - M3 + 2
      CALL EXINT(X, NP, 2, NE, TOL, EXI, NZ, IERR)
      IF(NZ.NE.0) GO TO 320
      IF(IERR.EQ.2) RETURN
  160 CONTINUE
      DO 190 I=1,M3
        SS = 0.0E0
        IF (KTRMS.EQ.0) GO TO 180
        KK = I + KTRMS + KTRMS - 2
        IL = KTRMS
        DO 170 K=1,KTRMS
          SS = SS + A(IL)*EXI(KK)
          KK = KK - 2
          IL = IL - 1
  170   CONTINUE
  180   CONTINUE
        YS(I) = YS(I) + SS
  190 CONTINUE
      IF (ICASE.EQ.1) GO TO 200
      IF (NFLG.NE.0) GO TO 220
  200 CONTINUE
      DO 210 I=1,M3
        Y(I) = YS(I)*XP
  210 CONTINUE
      IF (ICASE.EQ.1 .AND. NFLG.EQ.1) GO TO 90
      RETURN
  220 CONTINUE
C-----------------------------------------------------------------------
C     BACKWARD RECURSION SCALED BY EXP(X) ICASE=0,2
C-----------------------------------------------------------------------
      KK = NN - N + 1
      K = M3
      DO 230 I=1,M3
        Y(KK) = YS(K)*XP
        YSS(I) = YS(I)
        KK = KK - 1
        K = K - 1
  230 CONTINUE
      IL = KK
      IF (IL.LE.0) GO TO 250
      FN = NN - 3
      DO 240 I=1,IL
        T1 = YS(2)
        T2 = YS(1)
        YS(1) = YS(2) + ((FN+2.0E0)*YS(3)-(FN+1.0E0)*YS(1))/X
        YS(2) = T2
        YS(3) = T1
        Y(KK) = YS(1)*XP
        KK = KK - 1
        FN = FN - 1.0E0
  240 CONTINUE
  250 CONTINUE
      IF (ICASE.NE.2) RETURN
      DO 260 I=1,M3
        YS(I) = YSS(I)
  260 CONTINUE
      GO TO 90
  270 CONTINUE
      IF (N.LT.NT) GO TO 290
C-----------------------------------------------------------------------
C     ICASE=1, NT.LE.N.LE.NL WITH FORWARD RECURSION
C-----------------------------------------------------------------------
  280 CONTINUE
      NN = N + M3 - 1
      NFLG = MIN(M-M3,1)
      ICASE = 1
      GO TO 140
C-----------------------------------------------------------------------
C     ICASE=2, N.LT.NT.LT.NL WITH BOTH FORWARD AND BACKWARD RECURSION
C-----------------------------------------------------------------------
  290 CONTINUE
      NN = NT + 1
      NFLG = MIN(M-M3,1)
      ICASE = 2
      GO TO 140
C-----------------------------------------------------------------------
C     X=0 CASE
C-----------------------------------------------------------------------
  300 CONTINUE
      FN = N
      HN = 0.5E0*FN
      GR = GAMRN(HN)
      Y(1) = HRTPI*GR
      IF (M.EQ.1) RETURN
      Y(2) = HRTPI/(HN*GR)
      IF (M.EQ.2) RETURN
      DO 310 K=3,M
        Y(K) = FN*Y(K-2)/(FN+1.0E0)
        FN = FN + 1.0E0
  310 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     UNDERFLOW ON KODE=1, X.GT.XLIM
C-----------------------------------------------------------------------
  320 CONTINUE
      NZ=M
      DO 330 I=1,M
        Y(I) = 0.0E0
  330 CONTINUE
      RETURN
      END
*DECK BSPDOC
      SUBROUTINE BSPDOC
C***BEGIN PROLOGUE  BSPDOC
C***PURPOSE  Documentation for BSPLINE, a package of subprograms for
C            working with piecewise polynomial functions
C            in B-representation.
C***LIBRARY   SLATEC
C***CATEGORY  E, E1A, K, Z
C***TYPE      ALL (BSPDOC-A)
C***KEYWORDS  B-SPLINE, DOCUMENTATION, SPLINES
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BSPDOC is a non-executable, B-spline documentary routine.
C         The narrative describes a B-spline and the routines
C         necessary to manipulate B-splines at a fairly high level.
C         The basic package described herein is that of reference
C         5 with names altered to prevent duplication and conflicts
C         with routines from reference 3.  The call lists used here
C         are also different.  Work vectors were added to ensure
C         portability and proper execution in an overlay environ-
C         ment.  These work arrays can be used for other purposes
C         except as noted in BSPVN.  While most of the original
C         routines in reference 5 were restricted to orders 20
C         or less, this restriction was removed from all routines
C         except the quadrature routine BSQAD.  (See the section
C         below on differentiation and integration for details.)
C
C         The subroutines referenced below are single precision
C         routines.  Corresponding double precision versions are also
C         part of the package, and these are referenced by prefixing
C         a D in front of the single precision name.  For example,
C         BVALU and DBVALU are the single and double precision
C         versions for evaluating a B-spline or any of its deriva-
C         tives in the B-representation.
C
C                ****Description of B-Splines****
C
C     A collection of polynomials of fixed degree K-1 defined on a
C     subdivision (X(I),X(I+1)), I=1,...,M-1 of (A,B) with X(1)=A,
C     X(M)=B is called a B-spline of order K.  If the spline has K-2
C     continuous derivatives on (A,B), then the B-spline is simply
C     called a spline of order K.  Each of the M-1 polynomial pieces
C     has K coefficients, making a total of K(M-1) parameters.  This
C     B-spline and its derivatives have M-2 jumps at the subdivision
C     points X(I), I=2,...,M-1.  Continuity requirements at these
C     subdivision points add constraints and reduce the number of free
C     parameters.  If a B-spline is continuous at each of the M-2 sub-
C     division points, there are K(M-1)-(M-2) free parameters; if in
C     addition the B-spline has continuous first derivatives, there
C     are K(M-1)-2(M-2) free parameters, etc., until we get to a
C     spline where we have K(M-1)-(K-1)(M-2) = M+K-2 free parameters.
C     Thus, the principle is that increasing the continuity of
C     derivatives decreases the number of free parameters and
C     conversely.
C
C     The points at which the polynomials are tied together by the
C     continuity conditions are called knots.  If two knots are
C     allowed to come together at some X(I), then we say that we
C     have a knot of multiplicity 2 there, and the knot values are
C     the X(I) value.  If we reverse the procedure of the first
C     paragraph, we find that adding a knot to increase multiplicity
C     increases the number of free parameters and, according to the
C     principle above, we thereby introduce a discontinuity in what
C     was the highest continuous derivative at that knot.  Thus, the
C     number of free parameters is N = NU+K-2 where NU is the sum
C     of multiplicities at the X(I) values with X(1) and X(M) of
C     multiplicity 1 (NU = M if all knots are simple, i.e., for a
C     spline, all knots have multiplicity 1.)  Each knot can have a
C     multiplicity of at most K.  A B-spline is commonly written in the
C     B-representation
C
C               Y(X) = sum( A(I)*B(I,X), I=1 , N)
C
C     to show the explicit dependence of the spline on the free
C     parameters or coefficients A(I)=BCOEF(I) and basis functions
C     B(I,X).  These basis functions are themselves special B-splines
C     which are zero except on (at most) K adjoining intervals where
C     each B(I,X) is positive and, in most cases, hat or bell-
C     shaped.  In order for the nonzero part of B(1,X) to be a spline
C     covering (X(1),X(2)), it is necessary to put K-1 knots to the
C     left of A and similarly for B(N,X) to the right of B.  Thus, the
C     total number of knots for this representation is NU+2K-2 = N+K.
C     These knots are carried in an array T(*) dimensioned by at least
C     N+K.  From the construction, A=T(K) and B=T(N+1) and the spline is
C     defined on T(K).LE.X.LE.T(N+1).  The nonzero part of each basis
C     function lies in the  Interval (T(I),T(I+K)).  In many problems
C     where extrapolation beyond A or B is not anticipated, it is common
C     practice to set T(1)=T(2)=...=T(K)=A and T(N+1)=T(N+2)=...=
C     T(N+K)=B.  In summary, since T(K) and T(N+1) as well as
C     interior knots can have multiplicity K, the number of free
C     parameters N = sum of multiplicities - K.  The fact that each
C     B(I,X) function is nonzero over at most K intervals means that
C     for a given X value, there are at most K nonzero terms of the
C     sum.  This leads to banded matrices in linear algebra problems,
C     and references 3 and 6 take advantage of this in con-
C     structing higher level routines to achieve speed and avoid
C     ill-conditioning.
C
C                     ****Basic Routines****
C
C     The basic routines which most casual users will need are those
C     concerned with direct evaluation of splines or B-splines.
C     Since the B-representation, denoted by (T,BCOEF,N,K), is
C     preferred because of numerical stability, the knots T(*), the
C     B-spline coefficients BCOEF(*), the number of coefficients N,
C     and the order K of the polynomial pieces (of degree K-1) are
C     usually given.  While the knot array runs from T(1) to T(N+K),
C     the B-spline is normally defined on the interval T(K).LE.X.LE.
C     T(N+1).  To evaluate the B-spline or any of its derivatives
C     on this interval, one can use
C
C                  Y = BVALU(T,BCOEF,N,K,ID,X,INBV,WORK)
C
C     where ID is an integer for the ID-th derivative, 0.LE.ID.LE.K-1.
C     ID=0 gives the zero-th derivative or B-spline value at X.
C     If X.LT.T(K) or X.GT.T(N+1), whether by mistake or the result
C     of round off accumulation in incrementing X, BVALU gives a
C     diagnostic.  INBV is an initialization parameter which is set
C     to 1 on the first call.  Distinct splines require distinct
C     INBV parameters.  WORK is a scratch vector of length at least
C     3*K.
C
C     When more conventional communication is needed for publication,
C     physical interpretation, etc., the B-spline coefficients can
C     be converted to piecewise polynomial (PP) coefficients.  Thus,
C     the breakpoints (distinct knots) XI(*), the number of
C     polynomial pieces LXI, and the (right) derivatives C(*,J) at
C     each breakpoint XI(J) are needed to define the Taylor
C     expansion to the right of XI(J) on each interval XI(J).LE.
C     X.LT.XI(J+1), J=1,LXI where XI(1)=A and XI(LXI+1)=B.
C     These are obtained from the (T,BCOEF,N,K) representation by
C
C                CALL BSPPP(T,BCOEF,N,K,LDC,C,XI,LXI,WORK)
C
C     where LDC.GE.K is the leading dimension of the matrix C and
C     WORK is a scratch vector of length at least K*(N+3).
C     Then the PP-representation (C,XI,LXI,K) of Y(X), denoted
C     by Y(J,X) on each interval XI(J).LE.X.LT.XI(J+1), is
C
C     Y(J,X) = sum( C(I,J)*((X-XI(J))**(I-1))/factorial(I-1), I=1,K)
C
C     for J=1,...,LXI.  One must view this conversion from the B-
C     to the PP-representation with some skepticism because the
C     conversion may lose significant digits when the B-spline
C     varies in an almost discontinuous fashion.  To evaluate
C     the B-spline or any of its derivatives using the PP-
C     representation, one uses
C
C                Y = PPVAL(LDC,C,XI,LXI,K,ID,X,INPPV)
C
C     where ID and INPPV have the same meaning and usage as ID and
C     INBV in BVALU.
C
C     To determine to what extent the conversion process loses
C     digits, compute the relative error ABS((Y1-Y2)/Y2) over
C     the X interval with Y1 from PPVAL and Y2 from BVALU.  A
C     major reason for considering PPVAL is that evaluation is
C     much faster than that from BVALU.
C
C     Recall that when multiple knots are encountered, jump type
C     discontinuities in the B-spline or its derivatives occur
C     at these knots, and we need to know that BVALU and PPVAL
C     return right limiting values at these knots except at
C     X=B where left limiting values are returned.  These values
C     are used for the Taylor expansions about left end points of
C     breakpoint intervals.  That is, the derivatives C(*,J) are
C     right derivatives.  Note also that a computed X value which,
C     mathematically, would be a knot value may differ from the knot
C     by a round off error.  When this happens in evaluating a dis-
C     continuous B-spline or some discontinuous derivative, the
C     value at the knot and the value at X can be radically
C     different.  In this case, setting X to a T or XI value makes
C     the computation precise.  For left limiting values at knots
C     other than X=B, see the prologues to BVALU and other
C     routines.
C
C                     ****Interpolation****
C
C     BINTK is used to generate B-spline parameters (T,BCOEF,N,K)
C     which will interpolate the data by calls to BVALU.  A similar
C     interpolation can also be done for cubic splines using BINT4
C     or the code in reference 7.  If the PP-representation is given,
C     one can evaluate this representation at an appropriate number of
C     abscissas to create data then use BINTK or BINT4 to generate
C     the B-representation.
C
C               ****Differentiation and Integration****
C
C     Derivatives of B-splines are obtained from BVALU or PPVAL.
C     Integrals are obtained from BSQAD using the B-representation
C     (T,BCOEF,N,K) and PPQAD using the PP-representation (C,XI,LXI,
C     K).  More complicated integrals involving the product of a
C     of a function F and some derivative of a B-spline can be
C     evaluated with BFQAD or PFQAD using the B- or PP- represen-
C     tations respectively.  All quadrature routines, except for PPQAD,
C     are limited in accuracy to 18 digits or working precision,
C     whichever is smaller.  PPQAD is limited to working precision
C     only.  In addition, the order K for BSQAD is limited to 20 or
C     less.  If orders greater than 20 are required, use BFQAD with
C     F(X) = 1.
C
C                      ****Extrapolation****
C
C     Extrapolation outside the interval (A,B) can be accomplished
C     easily by the PP-representation using PPVAL.  However,
C     caution should be exercised, especially when several knots
C     are located at A or B or when the extrapolation is carried
C     significantly beyond A or B.  On the other hand, direct
C     evaluation with BVALU outside A=T(K).LE.X.LE.T(N+1)=B
C     produces an error message, and some manipulation of the knots
C     and coefficients are needed to extrapolate with BVALU.  This
C     process is described in reference 6.
C
C                ****Curve Fitting and Smoothing****
C
C     Unless one has many accurate data points, direct inter-
C     polation is not recommended for summarizing data.  The
C     results are often not in accordance with intuition since the
C     fitted curve tends to oscillate through the set of points.
C     Monotone splines (reference 7) can help curb this undulating
C     tendency but constrained least squares is more likely to give an
C     acceptable fit with fewer parameters.  Subroutine FC, des-
C     cribed in reference 6, is recommended for this purpose.  The
C     output from this fitting process is the B-representation.
C
C              **** Routines in the B-Spline Package ****
C
C                      Single Precision Routines
C
C         The subroutines referenced below are SINGLE PRECISION
C         routines. Corresponding DOUBLE PRECISION versions are also
C         part of the package and these are referenced by prefixing
C         a D in front of the single precision name. For example,
C         BVALU and DBVALU are the SINGLE and DOUBLE PRECISION
C         versions for evaluating a B-spline or any of its deriva-
C         tives in the B-representation.
C
C     BINT4 - interpolates with splines of order 4
C     BINTK - interpolates with splines of order k
C     BSQAD - integrates the B-representation on subintervals
C     PPQAD - integrates the PP-representation
C     BFQAD - integrates the product of a function F and any spline
C             derivative in the B-representation
C     PFQAD - integrates the product of a function F and any spline
C             derivative in the PP-representation
C     BVALU - evaluates the B-representation or a derivative
C     PPVAL - evaluates the PP-representation or a derivative
C     INTRV - gets the largest index of the knot to the left of x
C     BSPPP - converts from B- to PP-representation
C     BSPVD - computes nonzero basis functions and derivatives at x
C     BSPDR - sets up difference array for BSPEV
C     BSPEV - evaluates the B-representation and derivatives
C     BSPVN - called by BSPEV, BSPVD, BSPPP and BINTK for function and
C             derivative evaluations
C                        Auxiliary Routines
C
C       BSGQ8,PPGQ8,BNSLV,BNFAC,XERMSG,DBSGQ8,DPPGQ8,DBNSLV,DBNFAC
C
C                    Machine Dependent Routines
C
C                      I1MACH, R1MACH, D1MACH
C
C***REFERENCES  1. D. E. Amos, Computation with splines and
C                 B-splines, Report SAND78-1968, Sandia
C                 Laboratories, March 1979.
C               2. D. E. Amos, Quadrature subroutines for splines and
C                 B-splines, Report SAND79-1825, Sandia Laboratories,
C                 December 1979.
C               3. Carl de Boor, A Practical Guide to Splines, Applied
C                 Mathematics Series 27, Springer-Verlag, New York,
C                 1978.
C               4. Carl de Boor, On calculating with B-Splines, Journal
C                 of Approximation Theory 6, (1972), pp. 50-62.
C               5. Carl de Boor, Package for calculating with B-splines,
C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
C                 pp. 441-472.
C               6. R. J. Hanson, Constrained least squares curve fitting
C                 to discrete data using B-splines, a users guide,
C                 Report SAND78-1291, Sandia Laboratories, December
C                 1978.
C               7. 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  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   810223  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900723  PURPOSE section revised.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BSPDOC
C***FIRST EXECUTABLE STATEMENT  BSPDOC
      RETURN
      END
*DECK BSPDR
      SUBROUTINE BSPDR (T, A, N, K, NDERIV, AD)
C***BEGIN PROLOGUE  BSPDR
C***PURPOSE  Use the B-representation to construct a divided difference
C            table preparatory to a (right) derivative calculation.
C***LIBRARY   SLATEC
C***CATEGORY  E3
C***TYPE      SINGLE PRECISION (BSPDR-S, DBSPDR-D)
C***KEYWORDS  B-SPLINE, DATA FITTING, DIFFERENTIATION OF SPLINES,
C             INTERPOLATION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract
C         BSPDR is the BSPLDR routine of the reference.
C
C         BSPDR uses the B-representation (T,A,N,K) to construct a
C         divided difference table ADIF preparatory to a (right)
C         derivative calculation in BSPEV.  The lower triangular matrix
C         ADIF is stored in vector AD by columns.  The arrays are
C         related by
C
C           ADIF(I,J) = AD(I-J+1 + (2*N-J+2)*(J-1)/2)
C
C         I = J,N , J = 1,NDERIV .
C
C     Description of Arguments
C         Input
C          T       - knot vector of length N+K
C          A       - B-spline coefficient vector of length N
C          N       - number of B-spline coefficients
C                    N = sum of knot multiplicities-K
C          K       - order of the spline, K .GE. 1
C          NDERIV  - number of derivatives, 1 .LE. NDERIV .LE. K.
C                    NDERIV=1 gives the zero-th derivative = function
C                    value
C
C         Output
C          AD      - table of differences in a vector of length
C                    (2*N-NDERIV+1)*NDERIV/2 for input to BSPEV
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  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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BSPDR
C
      INTEGER I, ID, II, IPKMID, JJ, JM, K, KMID, N, NDERIV
      REAL A, AD, DIFF, FKMID, T
C     DIMENSION T(N+K), AD((2*N-NDERIV+1)*NDERIV/2)
      DIMENSION T(*), A(*), AD(*)
C***FIRST EXECUTABLE STATEMENT  BSPDR
      IF(K.LT.1) GO TO 100
      IF(N.LT.K) GO TO 105
      IF(NDERIV.LT.1 .OR. NDERIV.GT.K) GO TO 110
      DO 10 I=1,N
        AD(I) = A(I)
   10 CONTINUE
      IF (NDERIV.EQ.1) RETURN
      KMID = K
      JJ = N
      JM = 0
      DO 30 ID=2,NDERIV
        KMID = KMID - 1
        FKMID = KMID
        II = 1
        DO 20 I=ID,N
          IPKMID = I + KMID
          DIFF = T(IPKMID) - T(I)
          IF (DIFF.NE.0.0E0) AD(II+JJ) = (AD(II+JM+1)-AD(II+JM))/
     1     DIFF*FKMID
          II = II + 1
   20   CONTINUE
        JM = JJ
        JJ = JJ + N - ID + 1
   30 CONTINUE
      RETURN
C
C
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPDR', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPDR', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPDR',
     +   'NDERIV DOES NOT SATISFY 1.LE.NDERIV.LE.K', 2, 1)
      RETURN
      END
*DECK BSPEV
      SUBROUTINE BSPEV (T, AD, N, K, NDERIV, X, INEV, SVALUE, WORK)
C***BEGIN PROLOGUE  BSPEV
C***PURPOSE  Calculate the value of the spline and its derivatives from
C            the B-representation.
C***LIBRARY   SLATEC
C***CATEGORY  E3, K6
C***TYPE      SINGLE PRECISION (BSPEV-S, DBSPEV-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
C         BSPEV is the BSPLEV routine of the reference.
C
C         BSPEV calculates the value of the spline and its derivatives
C         at X from the B-representation (T,A,N,K) and returns them
C         in SVALUE(I),I=1,NDERIV, T(K) .LE. X .LE. T(N+1).  AD(I) can
C         be the B-spline coefficients A(I), I=1,N if NDERIV=1.  Other-
C         wise AD must be computed before hand by a call to BSPDR (T,A,
C         N,K,NDERIV,AD).  If X=T(I),I=K,N, right limiting values are
C         obtained.
C
C         To compute left derivatives or left limiting values at a
C         knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1.
C
C         BSPEV calls INTRV, BSPVN
C
C     Description of Arguments
C         Input
C          T       - knot vector of length N+K
C          AD      - vector of length (2*N-NDERIV+1)*NDERIV/2 containing
C                    the difference table from BSPDR.
C          N       - number of B-spline coefficients
C                    N = sum of knot multiplicities-K
C          K       - order of the B-spline, K .GE. 1
C          NDERIV  - number of derivatives, 1 .LE. NDERIV .LE. K.
C                    NDERIV=1 gives the zero-th derivative = function
C                    value
C          X       - argument, T(K) .LE. X .LE. T(N+1)
C          INEV    - an initialization parameter which must be set
C                    to 1 the first time BSPEV is called.
C
C         Output
C          INEV    - INEV contains information for efficient process-
C                    ing after the initial call and INEV must not
C                    be changed by the user.  Distinct splines require
C                    distinct INEV parameters.
C          SVALUE  - vector of length NDERIV containing the spline
C                    value in SVALUE(1) and the NDERIV-1 derivatives
C                    in the remaining components.
C          WORK    - work vector of length 3*K
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  BSPVN, INTRV, 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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BSPEV
C
      INTEGER I,ID,INEV,IWORK,JJ,K,KP1,KP1MN,L,LEFT,LL,MFLAG,
     1 N, NDERIV
      REAL AD, SVALUE, SUM, T, WORK, X
C     DIMENSION T(N+K)
      DIMENSION T(*), AD(*), SVALUE(*), WORK(*)
C***FIRST EXECUTABLE STATEMENT  BSPEV
      IF(K.LT.1) GO TO 100
      IF(N.LT.K) GO TO 105
      IF(NDERIV.LT.1 .OR. NDERIV.GT.K) GO TO 115
      ID = NDERIV
      CALL INTRV(T, N+1, X, INEV, I, MFLAG)
      IF (X.LT.T(K)) GO TO 110
      IF (MFLAG.EQ.0) GO TO 30
      IF (X.GT.T(I)) GO TO 110
   20 IF (I.EQ.K) GO TO 120
      I = I - 1
      IF (X.EQ.T(I)) GO TO 20
C
C *I* HAS BEEN FOUND IN (K,N) SO THAT T(I) .LE. X .LT. T(I+1)
C     (OR .LE. T(I+1), IF T(I) .LT. T(I+1) = T(N+1) ).
   30 KP1MN = K + 1 - ID
      KP1 = K + 1
      CALL BSPVN(T, KP1MN, K, 1, X, I, WORK(1),WORK(KP1),IWORK)
      JJ = (N+N-ID+2)*(ID-1)/2
C     ADIF(LEFTPL,ID) = AD(LEFTPL-ID+1 + (2*N-ID+2)*(ID-1)/2)
C     LEFTPL = LEFT + L
   40 LEFT = I - KP1MN
      SUM = 0.0E0
      LL = LEFT + JJ + 2 - ID
      DO 50 L=1,KP1MN
        SUM = SUM + WORK(L)*AD(LL)
        LL = LL + 1
   50 CONTINUE
      SVALUE(ID) = SUM
      ID = ID - 1
      IF (ID.EQ.0) GO TO 60
      JJ = JJ-(N-ID+1)
      KP1MN = KP1MN + 1
      CALL BSPVN(T, KP1MN, K, 2, X, I, WORK(1), WORK(KP1),IWORK)
      GO TO 40
C
   60 RETURN
C
C
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPEV', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPEV', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPEV', 'X IS NOT IN T(K).LE.X.LE.T(N+1)'
     +   , 2, 1)
      RETURN
  115 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPEV',
     +   'NDERIV DOES NOT SATISFY 1.LE.NDERIV.LE.K', 2, 1)
      RETURN
  120 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPEV',
     +   'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1)
      RETURN
      END
*DECK BSPLVD
      SUBROUTINE BSPLVD (T, K, X, ILEFT, VNIKX, NDERIV)
C***BEGIN PROLOGUE  BSPLVD
C***SUBSIDIARY
C***PURPOSE  Subsidiary to FC
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BSPLVD-S, DFSPVD-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C Calculates value and deriv.s of all B-splines which do not vanish at X
C
C  Fill VNIKX(J,IDERIV), J=IDERIV, ... ,K  with nonzero values of
C  B-splines of order K+1-IDERIV , IDERIV=NDERIV, ... ,1, by repeated
C  calls to BSPLVN
C
C***SEE ALSO  FC
C***ROUTINES CALLED  BSPLVN
C***REVISION HISTORY  (YYMMDD)
C   780801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  BSPLVD
      DIMENSION T(*),VNIKX(K,*)
      DIMENSION A(20,20)
C***FIRST EXECUTABLE STATEMENT  BSPLVD
      CALL BSPLVN(T,K+1-NDERIV,1,X,ILEFT,VNIKX(NDERIV,NDERIV))
      IF (NDERIV .LE. 1)               GO TO 99
      IDERIV = NDERIV
      DO 15 I=2,NDERIV
         IDERVM = IDERIV-1
         DO 11 J=IDERIV,K
   11       VNIKX(J-1,IDERVM) = VNIKX(J,IDERIV)
         IDERIV = IDERVM
         CALL BSPLVN(T,0,2,X,ILEFT,VNIKX(IDERIV,IDERIV))
   15    CONTINUE
C
      DO 20 I=1,K
         DO 19 J=1,K
   19       A(I,J) = 0.
   20    A(I,I) = 1.
      KMD = K
      DO 40 M=2,NDERIV
         KMD = KMD-1
         FKMD = KMD
         I = ILEFT
         J = K
   21       JM1 = J-1
            IPKMD = I + KMD
            DIFF = T(IPKMD) - T(I)
            IF (JM1 .EQ. 0)            GO TO 26
            IF (DIFF .EQ. 0.)          GO TO 25
            DO 24 L=1,J
   24          A(L,J) = (A(L,J) - A(L,J-1))/DIFF*FKMD
   25       J = JM1
            I = I - 1
                                       GO TO 21
   26    IF (DIFF .EQ. 0.)             GO TO 30
         A(1,1) = A(1,1)/DIFF*FKMD
C
   30    DO 40 I=1,K
            V = 0.
            JLOW = MAX(I,M)
            DO 35 J=JLOW,K
   35          V = A(I,J)*VNIKX(J,M) + V
   40       VNIKX(I,M) = V
   99                                  RETURN
      END
*DECK BSPLVN
      SUBROUTINE BSPLVN (T, JHIGH, INDEX, X, ILEFT, VNIKX)
C***BEGIN PROLOGUE  BSPLVN
C***SUBSIDIARY
C***PURPOSE  Subsidiary to FC
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BSPLVN-S, DFSPVN-D)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C Calculates the value of all possibly nonzero B-splines at *X* of
C  order MAX(JHIGH,(J+1)(INDEX-1)) on *T*.
C
C***SEE ALSO  FC
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   780801  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  BSPLVN
      DIMENSION T(*),VNIKX(*)
      DIMENSION DELTAM(20),DELTAP(20)
      SAVE J, DELTAM, DELTAP
      DATA J/1/
      DATA DELTAM/20*0/
      DATA DELTAP/20*0./
C***FIRST EXECUTABLE STATEMENT  BSPLVN
                                       GO TO (10,20),INDEX
   10 J = 1
      VNIKX(1) = 1.
      IF (J .GE. JHIGH)                GO TO 99
C
   20    IPJ = ILEFT+J
         DELTAP(J) = T(IPJ) - X
         IMJP1 = ILEFT-J+1
         DELTAM(J) = X - T(IMJP1)
         VMPREV = 0.
         JP1 = J+1
         DO 26 L=1,J
            JP1ML = JP1-L
            VM = VNIKX(L)/(DELTAP(L) + DELTAM(JP1ML))
            VNIKX(L) = VM*DELTAP(L) + VMPREV
   26       VMPREV = VM*DELTAM(JP1ML)
         VNIKX(JP1) = VMPREV
         J = JP1
         IF (J .LT. JHIGH)             GO TO 20
C
   99                                  RETURN
      END
*DECK BSPPP
      SUBROUTINE BSPPP (T, A, N, K, LDC, C, XI, LXI, WORK)
C***BEGIN PROLOGUE  BSPPP
C***PURPOSE  Convert the B-representation of a B-spline to the piecewise
C            polynomial (PP) form.
C***LIBRARY   SLATEC
C***CATEGORY  E3, K6
C***TYPE      SINGLE PRECISION (BSPPP-S, DBSPPP-D)
C***KEYWORDS  B-SPLINE, PIECEWISE POLYNOMIAL
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract
C         BSPPP is the BSPLPP routine of the reference.
C
C         BSPPP converts the B-representation (T,A,N,K) to the
C         piecewise polynomial (PP) form (C,XI,LXI,K) for use with
C         PPVAL.  Here XI(*), the break point array of length LXI, is
C         the knot array T(*) with multiplicities removed.  The columns
C         of the matrix C(I,J) contain the right Taylor derivatives
C         for the polynomial expansion about XI(J) for the intervals
C         XI(J) .LE. X .LE. XI(J+1), I=1,K, J=1,LXI.  Function PPVAL
C         makes this evaluation at a specified point X in
C         XI(1) .LE. X .LE. XI(LXI(1) .LE. X .LE. XI+1)
C
C     Description of Arguments
C         Input
C          T       - knot vector of length N+K
C          A       - B-spline coefficient vector of length N
C          N       - number of B-spline coefficients
C                    N = sum of knot multiplicities-K
C          K       - order of the B-spline, K .GE. 1
C          LDC     - leading dimension of C, LDC .GE. K
C
C         Output
C          C       - matrix of dimension at least (K,LXI) containing
C                    right derivatives at break points
C          XI      - XI break point vector of length LXI+1
C          LXI     - number of break points, LXI .LE. N-K+1
C          WORK    - work vector of length K*(N+3)
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  BSPDR, BSPEV, 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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BSPPP
C
      INTEGER ILEFT, INEV, K, LDC, LXI, N, NK
      REAL A, C, T, WORK, XI
C     DIMENSION T(N+K),XI(LXI+1),C(LDC,*)
C     HERE, * = THE FINAL VALUE OF THE OUTPUT PARAMETER LXI.
      DIMENSION T(*), A(*), WORK(*), XI(*), C(LDC,*)
C***FIRST EXECUTABLE STATEMENT  BSPPP
      IF(K.LT.1) GO TO 100
      IF(N.LT.K) GO TO 105
      IF(LDC.LT.K) GO TO 110
      CALL BSPDR(T, A, N, K, K, WORK)
      LXI = 0
      XI(1) = T(K)
      INEV = 1
      NK = N*K + 1
      DO 10 ILEFT=K,N
        IF (T(ILEFT+1).EQ.T(ILEFT)) GO TO 10
        LXI = LXI + 1
        XI(LXI+1) = T(ILEFT+1)
        CALL BSPEV(T,WORK(1),N,K, K,XI(LXI),INEV,C(1,LXI),WORK(NK))
   10 CONTINUE
      RETURN
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPPP', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPPP', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPPP', 'LDC DOES NOT SATISFY LDC.GE.K',
     +   2, 1)
      RETURN
      END
*DECK BSPVD
      SUBROUTINE BSPVD (T, K, NDERIV, X, ILEFT, LDVNIK, VNIKX, WORK)
C***BEGIN PROLOGUE  BSPVD
C***PURPOSE  Calculate the value and all derivatives of order less than
C            NDERIV of all basis functions which do not vanish at X.
C***LIBRARY   SLATEC
C***CATEGORY  E3, K6
C***TYPE      SINGLE PRECISION (BSPVD-S, DBSPVD-D)
C***KEYWORDS  DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract
C         BSPVD is the BSPLVD routine of the reference.
C
C         BSPVD calculates the value and all derivatives of order
C         less than NDERIV of all basis functions which do not
C         (possibly) vanish at X.  ILEFT is input such that
C         T(ILEFT) .LE. X .LT. T(ILEFT+1).  A call to INTRV(T,N+1,X,
C         ILO,ILEFT,MFLAG) will produce the proper ILEFT.  The output of
C         BSPVD is a matrix VNIKX(I,J) of dimension at least (K,NDERIV)
C         whose columns contain the K nonzero basis functions and
C         their NDERIV-1 right derivatives at X, I=1,K, J=1,NDERIV.
C         These basis functions have indices ILEFT-K+I, I=1,K,
C         K .LE. ILEFT .LE. N. The nonzero part of the I-th basis
C         function lies in (T(I),T(I+K)), I=1,N.
C
C         If X=T(ILEFT+1) then VNIKX contains left limiting values
C         (left derivatives) at T(ILEFT+1).  In particular, ILEFT = N
C         produces left limiting values at the right end point
C         X=T(N+1). To obtain left limiting values at T(I), I=K+1,N+1,
C         set X= next lower distinct knot, call INTRV to get ILEFT,
C         set X=T(I), and then call BSPVD.
C
C     Description of Arguments
C         Input
C          T       - knot vector of length N+K, where
C                    N = number of B-spline basis functions
C                    N = sum of knot multiplicities-K
C          K       - order of the B-spline, K .GE. 1
C          NDERIV  - number of derivatives = NDERIV-1,
C                    1 .LE. NDERIV .LE. K
C          X       - argument of basis functions,
C                    T(K) .LE. X .LE. T(N+1)
C          ILEFT   - largest integer such that
C                    T(ILEFT) .LE. X .LT. T(ILEFT+1)
C          LDVNIK  - leading dimension of matrix VNIKX
C
C         Output
C          VNIKX   - matrix of dimension at least (K,NDERIV) contain-
C                    ing the nonzero basis functions at X and their
C                    derivatives columnwise.
C          WORK    - a work vector of length (K+1)*(K+2)/2
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  BSPVN, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BSPVD
C
      INTEGER I,IDERIV,ILEFT,IPKMD,J,JJ,JLOW,JM,JP1MID,K,KMD, KP1, L,
     1 LDUMMY, M, MHIGH, NDERIV
      REAL FACTOR, FKMD, T, V, VNIKX, WORK, X
C     DIMENSION T(ILEFT+K), WORK((K+1)*(K+2)/2)
C     A(I,J) = WORK(I+J*(J+1)/2),  I=1,J+1  J=1,K-1
C     A(I,K) = W0RK(I+K*(K-1)/2)  I=1.K
C     WORK(1) AND WORK((K+1)*(K+2)/2) ARE NOT USED.
      DIMENSION T(*), VNIKX(LDVNIK,*), WORK(*)
C***FIRST EXECUTABLE STATEMENT  BSPVD
      IF(K.LT.1) GO TO 200
      IF(NDERIV.LT.1 .OR. NDERIV.GT.K) GO TO 205
      IF(LDVNIK.LT.K) GO TO 210
      IDERIV = NDERIV
      KP1 = K + 1
      JJ = KP1 - IDERIV
      CALL BSPVN(T, JJ, K, 1, X, ILEFT, VNIKX, WORK, IWORK)
      IF (IDERIV.EQ.1) GO TO 100
      MHIGH = IDERIV
      DO 20 M=2,MHIGH
        JP1MID = 1
        DO 10 J=IDERIV,K
          VNIKX(J,IDERIV) = VNIKX(JP1MID,1)
          JP1MID = JP1MID + 1
   10   CONTINUE
        IDERIV = IDERIV - 1
        JJ = KP1 - IDERIV
        CALL BSPVN(T, JJ, K, 2, X, ILEFT, VNIKX, WORK, IWORK)
   20 CONTINUE
C
      JM = KP1*(KP1+1)/2
      DO 30 L = 1,JM
        WORK(L) = 0.0E0
   30 CONTINUE
C     A(I,I) = WORK(I*(I+3)/2) = 1.0       I = 1,K
      L = 2
      J = 0
      DO 40 I = 1,K
        J = J + L
        WORK(J) = 1.0E0
        L = L + 1
   40 CONTINUE
      KMD = K
      DO 90 M=2,MHIGH
        KMD = KMD - 1
        FKMD = KMD
        I = ILEFT
        J = K
        JJ = J*(J+1)/2
        JM = JJ - J
        DO 60 LDUMMY=1,KMD
          IPKMD = I + KMD
          FACTOR = FKMD/(T(IPKMD)-T(I))
          DO 50 L=1,J
            WORK(L+JJ) = (WORK(L+JJ)-WORK(L+JM))*FACTOR
   50     CONTINUE
          I = I - 1
          J = J - 1
          JJ = JM
          JM = JM - J
   60   CONTINUE
C
        DO 80 I=1,K
          V = 0.0E0
          JLOW = MAX(I,M)
          JJ = JLOW*(JLOW+1)/2
          DO 70 J=JLOW,K
            V = WORK(I+JJ)*VNIKX(J,M) + V
            JJ = JJ + J + 1
   70     CONTINUE
          VNIKX(I,M) = V
   80   CONTINUE
   90 CONTINUE
  100 RETURN
C
C
  200 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPVD', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  205 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPVD',
     +   'NDERIV DOES NOT SATISFY 1.LE.NDERIV.LE.K', 2, 1)
      RETURN
  210 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPVD',
     +   'LDVNIK DOES NOT SATISFY LDVNIK.GE.K', 2, 1)
      RETURN
      END
*DECK BSPVN
      SUBROUTINE BSPVN (T, JHIGH, K, INDEX, X, ILEFT, VNIKX, WORK,
     +   IWORK)
C***BEGIN PROLOGUE  BSPVN
C***PURPOSE  Calculate the value of all (possibly) nonzero basis
C            functions at X.
C***LIBRARY   SLATEC
C***CATEGORY  E3, K6
C***TYPE      SINGLE PRECISION (BSPVN-S, DBSPVN-D)
C***KEYWORDS  EVALUATION OF B-SPLINE
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract
C         BSPVN is the BSPLVN routine of the reference.
C
C         BSPVN calculates the value of all (possibly) nonzero basis
C         functions at X of order MAX(JHIGH,(J+1)*(INDEX-1)), where
C         T(K) .LE. X .LE. T(N+1) and J=IWORK is set inside the routine
C         on the first call when INDEX=1.  ILEFT is such that T(ILEFT)
C         .LE. X .LT. T(ILEFT+1).  A call to INTRV(T,N+1,X,ILO,ILEFT,
C         MFLAG) produces the proper ILEFT.  BSPVN calculates using the
C         basic algorithm needed in BSPVD.  If only basis functions are
C         desired, setting JHIGH=K and INDEX=1 can be faster than
C         calling BSPVD, but extra coding is required for derivatives
C         (INDEX=2) and BSPVD is set up for this purpose.
C
C         Left limiting values are set up as described in BSPVD.
C
C     Description of Arguments
C         Input
C          T       - knot vector of length N+K, where
C                    N = number of B-spline basis functions
C                    N = sum of knot multiplicities-K
C          JHIGH   - order of B-spline, 1 .LE. JHIGH .LE. K
C          K       - highest possible order
C          INDEX   - INDEX = 1 gives basis functions of order JHIGH
C                          = 2 denotes previous entry with WORK, IWORK
C                              values saved for subsequent calls to
C                              BSPVN.
C          X       - argument of basis functions,
C                    T(K) .LE. X .LE. T(N+1)
C          ILEFT   - largest integer such that
C                    T(ILEFT) .LE. X .LT. T(ILEFT+1)
C
C         Output
C          VNIKX   - vector of length K for spline values.
C          WORK    - a work vector of length 2*K
C          IWORK   - a work parameter.  Both WORK and IWORK contain
C                    information necessary to continue for INDEX = 2.
C                    When INDEX = 1 exclusively, these are scratch
C                    variables and can be used for other purposes.
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  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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BSPVN
C
      INTEGER ILEFT, IMJP1, INDEX, IPJ, IWORK, JHIGH, JP1, JP1ML, K, L
      REAL T, VM, VMPREV, VNIKX, WORK, X
C     DIMENSION T(ILEFT+JHIGH)
      DIMENSION T(*), VNIKX(*), WORK(*)
C     CONTENT OF J, DELTAM, DELTAP IS EXPECTED UNCHANGED BETWEEN CALLS.
C     WORK(I) = DELTAP(I), WORK(K+I) = DELTAM(I), I = 1,K
C***FIRST EXECUTABLE STATEMENT  BSPVN
      IF(K.LT.1) GO TO 90
      IF(JHIGH.GT.K .OR. JHIGH.LT.1) GO TO 100
      IF(INDEX.LT.1 .OR. INDEX.GT.2) GO TO 105
      IF(X.LT.T(ILEFT) .OR. X.GT.T(ILEFT+1)) GO TO 110
      GO TO (10, 20), INDEX
   10 IWORK = 1
      VNIKX(1) = 1.0E0
      IF (IWORK.GE.JHIGH) GO TO 40
C
   20 IPJ = ILEFT + IWORK
      WORK(IWORK) = T(IPJ) - X
      IMJP1 = ILEFT - IWORK + 1
      WORK(K+IWORK) = X - T(IMJP1)
      VMPREV = 0.0E0
      JP1 = IWORK + 1
      DO 30 L=1,IWORK
        JP1ML = JP1 - L
        VM = VNIKX(L)/(WORK(L)+WORK(K+JP1ML))
        VNIKX(L) = VM*WORK(L) + VMPREV
        VMPREV = VM*WORK(K+JP1ML)
   30 CONTINUE
      VNIKX(JP1) = VMPREV
      IWORK = JP1
      IF (IWORK.LT.JHIGH) GO TO 20
C
   40 RETURN
C
C
   90 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPVN', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPVN',
     +   'JHIGH DOES NOT SATISFY 1.LE.JHIGH.LE.K', 2, 1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPVN', 'INDEX IS NOT 1 OR 2', 2, 1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'BSPVN',
     +   'X DOES NOT SATISFY T(ILEFT).LE.X.LE.T(ILEFT+1)', 2, 1)
      RETURN
      END
*DECK BSQAD
      SUBROUTINE BSQAD (T, BCOEF, N, K, X1, X2, BQUAD, WORK)
C***BEGIN PROLOGUE  BSQAD
C***PURPOSE  Compute the integral of a K-th order B-spline using the
C            B-representation.
C***LIBRARY   SLATEC
C***CATEGORY  H2A2A1, E3, K6
C***TYPE      SINGLE PRECISION (BSQAD-S, DBSQAD-D)
C***KEYWORDS  INTEGRAL OF B-SPLINES, QUADRATURE
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         BSQAD computes the integral on (X1,X2) of a K-th order
C         B-spline using the B-representation (T,BCOEF,N,K).  Orders
C         K as high as 20 are permitted by applying a 2, 6, or 10
C         point Gauss formula on subintervals of (X1,X2) which are
C         formed by included (distinct) knots.
C
C         If orders K greater than 20 are needed, use BFQAD with
C         F(X) = 1.
C
C     Description of Arguments
C         Input
C           T      - knot array of length N+K
C           BCOEF  - B-spline coefficient array of length N
C           N      - length of coefficient array
C           K      - order of B-spline, 1 .LE. K .LE. 20
C           X1,X2  - end points of quadrature interval in
C                    T(K) .LE. X .LE. T(N+1)
C
C         Output
C           BQUAD  - integral of the B-spline over (X1,X2)
C           WORK   - work vector of length 3*K
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  BVALU, INTRV, 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  BSQAD
C
      INTEGER I,IL1,IL2,ILO,INBV, JF,K,LEFT,M,MF,MFLAG,N, NPK, NP1
      REAL A, AA, B, BB, BCOEF, BMA, BPA, BQUAD, C1, GPTS, GWTS, GX, Q,
     1 SUM, T, TA, TB, WORK, X1, X2, Y1, Y2
      REAL BVALU
      DIMENSION T(*), BCOEF(*), GPTS(9), GWTS(9), SUM(5), WORK(*)
C
      SAVE GPTS, GWTS
      DATA GPTS(1), GPTS(2), GPTS(3), GPTS(4), GPTS(5), GPTS(6),
     1     GPTS(7), GPTS(8), GPTS(9)/
     2     5.77350269189625764E-01,     2.38619186083196909E-01,
     3     6.61209386466264514E-01,     9.32469514203152028E-01,
     4     1.48874338981631211E-01,     4.33395394129247191E-01,
     5     6.79409568299024406E-01,     8.65063366688984511E-01,
     6     9.73906528517171720E-01/
      DATA GWTS(1), GWTS(2), GWTS(3), GWTS(4), GWTS(5), GWTS(6),
     1     GWTS(7), GWTS(8), GWTS(9)/
     2     1.00000000000000000E+00,     4.67913934572691047E-01,
     3     3.60761573048138608E-01,     1.71324492379170345E-01,
     4     2.95524224714752870E-01,     2.69266719309996355E-01,
     5     2.19086362515982044E-01,     1.49451349150580593E-01,
     6     6.66713443086881376E-02/
C
C***FIRST EXECUTABLE STATEMENT  BSQAD
      BQUAD = 0.0E0
      IF(K.LT.1 .OR. K.GT.20) GO TO 65
      IF(N.LT.K) GO TO 70
      AA = MIN(X1,X2)
      BB = MAX(X1,X2)
      IF (AA.LT.T(K)) GO TO 60
      NP1 = N + 1
      IF (BB.GT.T(NP1)) GO TO 60
      IF (AA.EQ.BB) RETURN
      NPK = N + K
C     SELECTION OF 2, 6, OR 10 POINT GAUSS FORMULA
      JF = 0
      MF = 1
      IF (K.LE.4) GO TO 10
      JF = 1
      MF = 3
      IF (K.LE.12) GO TO 10
      JF = 4
      MF = 5
   10 CONTINUE
C
      DO 20 I=1,MF
        SUM(I) = 0.0E0
   20 CONTINUE
      ILO = 1
      INBV = 1
      CALL INTRV(T, NPK, AA, ILO, IL1, MFLAG)
      CALL INTRV(T, NPK, BB, ILO, IL2, MFLAG)
      IF (IL2.GE.NP1) IL2 = N
      DO 40 LEFT=IL1,IL2
        TA = T(LEFT)
        TB = T(LEFT+1)
        IF (TA.EQ.TB) GO TO 40
        A = MAX(AA,TA)
        B = MIN(BB,TB)
        BMA = 0.5E0*(B-A)
        BPA = 0.5E0*(B+A)
        DO 30 M=1,MF
          C1 = BMA*GPTS(JF+M)
          GX = -C1 + BPA
          Y2 = BVALU(T,BCOEF,N,K,0,GX,INBV,WORK)
          GX = C1 + BPA
          Y1 = BVALU(T,BCOEF,N,K,0,GX,INBV,WORK)
          SUM(M) = SUM(M) + (Y1+Y2)*BMA
   30   CONTINUE
   40 CONTINUE
      Q = 0.0E0
      DO 50 M=1,MF
        Q = Q + GWTS(JF+M)*SUM(M)
   50 CONTINUE
      IF (X1.GT.X2) Q = -Q
      BQUAD = Q
      RETURN
C
C
   60 CONTINUE
      CALL XERMSG ('SLATEC', 'BSQAD',
     +   'X1 OR X2 OR BOTH DO NOT SATISFY T(K).LE.X.LE.T(N+1)', 2, 1)
      RETURN
   65 CONTINUE
      CALL XERMSG ('SLATEC', 'BSQAD', 'K DOES NOT SATISFY 1.LE.K.LE.20'
     +   , 2, 1)
      RETURN
   70 CONTINUE
      CALL XERMSG ('SLATEC', 'BSQAD', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
      END
*DECK BSRH
      FUNCTION BSRH (XLL, XRR, IZ, C, A, BH, F, SGN)
C***BEGIN PROLOGUE  BSRH
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BLKTRI
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BCRH-S, BSRH-S)
C***AUTHOR  (UNKNOWN)
C***SEE ALSO  BLKTRI
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    CBLKT
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  BSRH
      DIMENSION       A(*)       ,C(*)       ,BH(*)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C***FIRST EXECUTABLE STATEMENT  BSRH
      XL = XLL
      XR = XRR
      DX = .5*ABS(XR-XL)
  101 X = .5*(XL+XR)
      IF (SGN*F(X,IZ,C,A,BH)) 103,105,102
  102 XR = X
      GO TO 104
  103 XL = X
  104 DX = .5*DX
      IF (DX-CNV) 105,105,101
  105 BSRH = .5*(XL+XR)
      RETURN
      END
*DECK BVALU
      FUNCTION BVALU (T, A, N, K, IDERIV, X, INBV, WORK)
C***BEGIN PROLOGUE  BVALU
C***PURPOSE  Evaluate the B-representation of a B-spline at X for the
C            function value or any of its derivatives.
C***LIBRARY   SLATEC
C***CATEGORY  E3, K6
C***TYPE      SINGLE PRECISION (BVALU-S, DBVALU-D)
C***KEYWORDS  DIFFERENTIATION OF B-SPLINE, EVALUATION OF B-SPLINE
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract
C         BVALU is the BVALUE function of the reference.
C
C         BVALU evaluates the B-representation (T,A,N,K) of a B-spline
C         at X for the function value on IDERIV = 0 or any of its
C         derivatives on IDERIV = 1,2,...,K-1.  Right limiting values
C         (right derivatives) are returned except at the right end
C         point X=T(N+1) where left limiting values are computed.  The
C         spline is defined on T(K) .LE. X .LE. T(N+1).  BVALU returns
C         a fatal error message when X is outside of this interval.
C
C         To compute left derivatives or left limiting values at a
C         knot T(I), replace N by I-1 and set X=T(I), I=K+1,N+1.
C
C         BVALU calls INTRV
C
C     Description of Arguments
C         Input
C          T       - knot vector of length N+K
C          A       - B-spline coefficient vector of length N
C          N       - number of B-spline coefficients
C                    N = sum of knot multiplicities-K
C          K       - order of the B-spline, K .GE. 1
C          IDERIV  - order of the derivative, 0 .LE. IDERIV .LE. K-1
C                    IDERIV=0 returns the B-spline value
C          X       - argument, T(K) .LE. X .LE. T(N+1)
C          INBV    - an initialization parameter which must be set
C                    to 1 the first time BVALU is called.
C
C         Output
C          INBV    - INBV contains information for efficient process-
C                    ing after the initial call and INBV must not
C                    be changed by the user.  Distinct splines require
C                    distinct INBV parameters.
C          WORK    - work vector of length 3*K.
C          BVALU   - value of the IDERIV-th derivative at X
C
C     Error Conditions
C         An 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  INTRV, 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  BVALU
C
      INTEGER I,IDERIV,IDERP1,IHI,IHMKMJ,ILO,IMK,IMKPJ, INBV, IPJ,
     1 IP1, IP1MJ, J, JJ, J1, J2, K, KMIDER, KMJ, KM1, KPK, MFLAG, N
      REAL A, FKMJ, T, WORK, X
C     DIMENSION T(N+K), WORK(3*K)
      DIMENSION T(*), A(*), WORK(*)
C***FIRST EXECUTABLE STATEMENT  BVALU
      BVALU = 0.0E0
      IF(K.LT.1) GO TO 102
      IF(N.LT.K) GO TO 101
      IF(IDERIV.LT.0 .OR. IDERIV.GE.K) GO TO 110
      KMIDER = K - IDERIV
C
C *** FIND *I* IN (K,N) SUCH THAT T(I) .LE. X .LT. T(I+1)
C     (OR, .LE. T(I+1) IF T(I) .LT. T(I+1) = T(N+1)).
      KM1 = K - 1
      CALL INTRV(T, N+1, X, INBV, I, MFLAG)
      IF (X.LT.T(K)) GO TO 120
      IF (MFLAG.EQ.0) GO TO 20
      IF (X.GT.T(I)) GO TO 130
   10 IF (I.EQ.K) GO TO 140
      I = I - 1
      IF (X.EQ.T(I)) GO TO 10
C
C *** DIFFERENCE THE COEFFICIENTS *IDERIV* TIMES
C     WORK(I) = AJ(I), WORK(K+I) = DP(I), WORK(K+K+I) = DM(I), I=1.K
C
   20 IMK = I - K
      DO 30 J=1,K
        IMKPJ = IMK + J
        WORK(J) = A(IMKPJ)
   30 CONTINUE
      IF (IDERIV.EQ.0) GO TO 60
      DO 50 J=1,IDERIV
        KMJ = K - J
        FKMJ = KMJ
        DO 40 JJ=1,KMJ
          IHI = I + JJ
          IHMKMJ = IHI - KMJ
          WORK(JJ) = (WORK(JJ+1)-WORK(JJ))/(T(IHI)-T(IHMKMJ))*FKMJ
   40   CONTINUE
   50 CONTINUE
C
C *** COMPUTE VALUE AT *X* IN (T(I),(T(I+1)) OF IDERIV-TH DERIVATIVE,
C     GIVEN ITS RELEVANT B-SPLINE COEFF. IN AJ(1),...,AJ(K-IDERIV).
   60 IF (IDERIV.EQ.KM1) GO TO 100
      IP1 = I + 1
      KPK = K + K
      J1 = K + 1
      J2 = KPK + 1
      DO 70 J=1,KMIDER
        IPJ = I + J
        WORK(J1) = T(IPJ) - X
        IP1MJ = IP1 - J
        WORK(J2) = X - T(IP1MJ)
        J1 = J1 + 1
        J2 = J2 + 1
   70 CONTINUE
      IDERP1 = IDERIV + 1
      DO 90 J=IDERP1,KM1
        KMJ = K - J
        ILO = KMJ
        DO 80 JJ=1,KMJ
          WORK(JJ) = (WORK(JJ+1)*WORK(KPK+ILO)+WORK(JJ)
     1              *WORK(K+JJ))/(WORK(KPK+ILO)+WORK(K+JJ))
          ILO = ILO - 1
   80   CONTINUE
   90 CONTINUE
  100 BVALU = WORK(1)
      RETURN
C
C
  101 CONTINUE
      CALL XERMSG ('SLATEC', 'BVALU', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
  102 CONTINUE
      CALL XERMSG ('SLATEC', 'BVALU', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'BVALU',
     +   'IDERIV DOES NOT SATISFY 0.LE.IDERIV.LT.K', 2, 1)
      RETURN
  120 CONTINUE
      CALL XERMSG ('SLATEC', 'BVALU',
     +   'X IS N0T GREATER THAN OR EQUAL TO T(K)', 2, 1)
      RETURN
  130 CONTINUE
      CALL XERMSG ('SLATEC', 'BVALU',
     +   'X IS NOT LESS THAN OR EQUAL TO T(N+1)', 2, 1)
      RETURN
  140 CONTINUE
      CALL XERMSG ('SLATEC', 'BVALU',
     +   'A LEFT LIMITING VALUE CANNOT BE OBTAINED AT T(K)', 2, 1)
      RETURN
      END
*DECK BVDER
      SUBROUTINE BVDER (X, Y, YP, G, IPAR)
C***BEGIN PROLOGUE  BVDER
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BVDER-S, DBVDER-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C **********************************************************************
C     NFC = Number of base solution vectors
C
C     NCOMP = Number of components per solution vector
C
C              1 -- Nonzero particular solution
C     INHOMO =
C              2 or 3 -- Zero particular solution
C
C             0 -- Inhomogeneous vector term G(X) identically zero
C     IGOFX =
C             1 -- Inhomogeneous vector term G(X) not identically zero
C
C     G = Inhomogeneous vector term G(X)
C
C     XSAV = Previous value of X
C
C     C = Normalization factor for the particular solution
C
C           0   ( if  NEQIVP = 0 )
C     IVP =
C           Number of differential equations integrated due to
C           the original boundary value problem   ( if  NEQIVP .GT. 0 )
C
C     NOFST - For problems with auxiliary initial value equations,
C             NOFST communicates to the routine FMAT how to access
C             the dependent variables corresponding to this initial
C             value problem.  For example, during any call to FMAT,
C             the first dependent variable for the initial value
C             problem is in position  Y(NOFST + 1).
C             See example in SAND77-1328.
C **********************************************************************
C
C***SEE ALSO  BVSUP
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    ML8SZ, MLIVP
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890921  Realigned order of variables in certain COMMON blocks.
C           (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910701  Corrected ROUTINES CALLED section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C   920618  Minor restructuring of code.  (RWC, WRB)
C***END PROLOGUE  BVDER
      DIMENSION Y(*),YP(*),G(*)
C
C **********************************************************************
C
      COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMP,NFC
C
C **********************************************************************
C     The COMMON block below is used to communicate with the user
C     supplied subroutine FMAT.  The user should not alter this
C     COMMON block.
C
      COMMON /MLIVP/ NOFST
C **********************************************************************
C
C***FIRST EXECUTABLE STATEMENT  BVDER
      IF (IVP .GT. 0) CALL UIVP(X,Y(IVP+1),YP(IVP+1))
      NOFST = IVP
      NA = 1
      DO 10 K=1,NFC
         CALL FMAT(X,Y(NA),YP(NA))
         NOFST = NOFST - NCOMP
         NA = NA + NCOMP
   10 CONTINUE
C
      IF (INHOMO .NE. 1) RETURN
      CALL FMAT(X,Y(NA),YP(NA))
C
      IF (IGOFX .EQ. 0) RETURN
      IF (X .NE. XSAV) THEN
         IF (IVP .EQ. 0) CALL GVEC(X,G)
         IF (IVP .GT. 0) CALL UVEC(X,Y(IVP+1),G)
         XSAV = X
      ENDIF
C
C     If the user has chosen not to normalize the particular
C     solution, then C is defined in BVPOR to be 1.0
C
C     The following loop is just
C     CALL SAXPY (NCOMP, 1.0E0/C, G, 1, YP(NA), 1)
C
      DO 20 J=1,NCOMP
         L = NA + J - 1
         YP(L) = YP(L) + G(J)/C
   20 CONTINUE
      RETURN
      END
*DECK BVPOR
      SUBROUTINE BVPOR (Y, NROWY, NCOMP, XPTS, NXPTS, A, NROWA, ALPHA,
     +   NIC, B, NROWB, BETA, NFC, IFLAG, Z, MXNON, P, NTP, IP, W, NIV,
     +   YHP, U, V, COEF, S, STOWA, G, WORK, IWORK, NFCC)
C***BEGIN PROLOGUE  BVPOR
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (BVPOR-S, DBVPOR-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C **********************************************************************
C     INPUT to BVPOR    (items not defined in BVSUP comments)
C **********************************************************************
C
C     NOPG = 0 -- Orthonormalization points not pre-assigned
C          = 1 -- Orthonormalization points pre-assigned
C
C     MXNON = Maximum number of orthogonalizations allowed.
C
C     NDISK = 0 -- IN-CORE storage
C           = 1 -- DISK storage.  Value of NTAPE in data statement
C                  is set to 13.  If another value is desired,
C                  the data statement must be changed.
C
C     INTEG = Type of integrator and associated test to be used
C             to determine when to orthonormalize.
C
C             1 -- Use GRAM-SCHMIDT test and DERKF
C             2 -- Use GRAM-SCHMIDT test and DEABM
C
C     TOL = Tolerance for allowable error in orthogonalization test.
C
C     NPS = 0 Normalize particular solution to unit length at each
C             point of orthonormalization.
C         = 1 Do not normalize particular solution.
C
C     NTP = Must be .GE. NFC*(NFC+1)/2.
C
C
C     NFCC = 2*NFC for special treatment of a complex valued problem
C
C     ICOCO = 0 Skip final computations (superposition coefficients
C               and ,hence, boundary problem solution)
C           = 1 Calculate superposition coefficients and obtain
C               solution to the boundary value problem
C
C **********************************************************************
C     OUTPUT from BVPOR
C **********************************************************************
C
C     Y(NROWY,NXPTS) = Solution at specified output points.
C
C     MXNON = Number of orthonormalizations performed by BVPOR.
C
C     Z(MXNON+1) = Locations of orthonormalizations performed by BVPOR.
C
C     NIV = Number of independent vectors returned from MGSBV. Normally
C        this parameter will be meaningful only when MGSBV returns with
C           MFLAG = 2.
C
C **********************************************************************
C
C     The following variables are in the argument list because of
C     variable dimensioning. In general, they contain no information of
C     use to the user.  The amount of storage set aside by the user must
C     be greater than or equal to that indicated by the dimension
C     statements.   For the DISK storage mode, NON = 0 and KPTS = 1,
C     while for the IN-CORE storage mode, NON = MXNON and KPTS = NXPTS.
C
C     P(NTP,NON+1)
C     IP(NFCC,NON+1)
C     YHP(NCOMP,NFC+1)  plus an additional column of the length  NEQIVP
C     U(NCOMP,NFC,KPTS)
C     V(NCOMP,KPTS)
C     W(NFCC,NON+1)
C     COEF(NFCC)
C     S(NFC+1)
C     STOWA(NCOMP*(NFC+1)+NEQIVP+1)
C     G(NCOMP)
C     WORK(KKKWS)
C     IWORK(LLLIWS)
C
C **********************************************************************
C     Subroutines used by BVPOR
C         LSSUDS -- Solves an underdetermined system of linear
C                   equations.  This routine is used to get a full
C                   set of initial conditions for integration.
C                   Called by BVPOR
C
C         SVECS -- Obtains starting vectors for special treatment
C                  of complex valued problems , called by BVPOR
C
C         RKFAB -- Routine which conducts integration using DERKF or
C                   DEABM
C
C         STWAY -- Storage for backup capability, called by
C                   BVPOR and REORT
C
C         STOR1 -- Storage at output points, called by BVPOR,
C                  RKFAB, REORT and STWAY.
C
C         SDOT -- Single precision vector inner product routine,
C                   called by BVPOR, SCOEF, LSSUDS, MGSBV,
C                   BKSOL, REORT and PRVEC.
C         ** NOTE **
C         A considerable improvement in speed can be achieved if a
C         machine language version is used for SDOT.
C
C         SCOEF -- Computes the superposition constants from the
C                  boundary conditions at Xfinal.
C
C         BKSOL -- Solves an upper triangular set of linear equations.
C
C **********************************************************************
C
C***SEE ALSO  BVSUP
C***ROUTINES CALLED  BKSOL, LSSUDS, RKFAB, SCOEF, SDOT, STOR1, STWAY,
C                    SVECS
C***COMMON BLOCKS    ML15TO, ML18JR, ML8SZ
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890921  Realigned order of variables in certain COMMON blocks.
C           (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  BVPOR
C
      DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*),
     1          BETA(*),P(NTP,*),IP(NFCC,*),
     2          U(NCOMP,NFC,*),V(NCOMP,*),W(NFCC,*),
     3          COEF(*),Z(*),YHP(NCOMP,*),XPTS(*),S(*),
     4          WORK(*),IWORK(*),STOWA(*),G(*)
C
C **********************************************************************
C
      COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD
      COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
     1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
      COMMON /ML18JR/ AE,RE,TOL,NXPTSD,NICD,NOPG,MXNOND,NDISK,NTAPE,
     1                NEQ,INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD,
     2                ICOCO
C
C **********************************************************************
C
C***FIRST EXECUTABLE STATEMENT  BVPOR
      NFCP1 = NFC + 1
      NUMORT = 0
      C = 1.0
C
C **********************************************************************
C     CALCULATE INITIAL CONDITIONS WHICH SATISFY
C                   A*YH(XINITIAL)=0  AND  A*YP(XINITIAL)=ALPHA.
C     WHEN NFC .NE. NFCC LSSUDS DEFINES VALUES YHP IN A MATRIX OF SIZE
C     (NFCC+1)*NCOMP AND ,HENCE, OVERFLOWS THE STORAGE ALLOCATION INTO
C     THE U ARRAY. HOWEVER, THIS IS OKAY SINCE PLENTY OF SPACE IS
C     AVAILABLE IN U AND IT HAS NOT YET BEEN USED.
C
      NDW = NROWA * NCOMP
      KWS = NDW + NIC + 1
      KWD = KWS + NIC
      KWT = KWD + NIC
      KWC = KWT + NIC
      IFLAG = 0
      CALL LSSUDS(A,YHP(1,NFCC+1),ALPHA,NIC,NCOMP,NROWA,YHP,NCOMP,
     1            IFLAG,1,IRA,0,WORK(1),WORK(NDW+1),IWORK,WORK(KWS),
     2            WORK(KWD),WORK(KWT),ISFLG,WORK(KWC))
      IF (IFLAG .EQ. 1) GO TO 3
      IFLAG=-4
      GO TO 250
    3 IF (NFC .NE. NFCC) CALL SVECS(NCOMP,NFC,YHP,WORK,IWORK,
     1                   INHOMO,IFLAG)
      IF (IFLAG .EQ. 1)  GO TO 5
      IFLAG=-5
      GO TO 250
C
C **********************************************************************
C     DETERMINE THE NUMBER OF DIFFERENTIAL EQUATIONS TO BE INTEGRATED,
C     INITIALIZE VARIABLES FOR AUXILIARY INITIAL VALUE PROBLEM AND
C     STORE INITIAL CONDITIONS.
C
    5 NEQ = NCOMP * NFC
      IF (INHOMO .EQ. 1)  NEQ = NEQ + NCOMP
      IVP = 0
      IF (NEQIVP .EQ. 0)  GO TO 10
      IVP = NEQ
      NEQ = NEQ + NEQIVP
      NFCP2 = NFCP1
      IF (INHOMO .EQ. 1)  NFCP2 = NFCP1 + 1
      DO 7 K = 1,NEQIVP
    7 YHP(K,NFCP2) = ALPHA(NIC+K)
   10 CALL STOR1(U,YHP,V,YHP(1,NFCP1),0,NDISK,NTAPE)
C
C **********************************************************************
C     SET UP DATA FOR THE ORTHONORMALIZATION TESTING PROCEDURE AND
C     SAVE INITIAL CONDITIONS IN CASE A RESTART IS NECESSARY.
C
      NSWOT=1
      KNSWOT=0
      LOTJP=1
      TND=LOG10(10.*TOL)
      PWCND=LOG10(SQRT(TOL))
      X=XBEG
      PX=X
      XOT=XEND
      XOP=X
      KOP=1
      CALL STWAY(U,V,YHP,0,STOWA)
C
C **********************************************************************
C ******** FORWARD INTEGRATION OF ALL INITIAL VALUE EQUATIONS **********
C **********************************************************************
C
      CALL RKFAB(NCOMP,XPTS,NXPTS,NFC,IFLAG,Z,MXNON,P,NTP,IP,
     1            YHP,NIV,U,V,W,S,STOWA,G,WORK,IWORK,NFCC)
      IF (IFLAG .NE. 0  .OR.  ICOCO .EQ. 0)  GO TO 250
C
C **********************************************************************
C **************** BACKWARD SWEEP TO OBTAIN SOLUTION *******************
C **********************************************************************
C
C     CALCULATE SUPERPOSITION COEFFICIENTS AT XFINAL.
C
C   FOR THE DISK STORAGE VERSION, IT IS NOT NECESSARY TO READ  U  AND  V
C   AT THE LAST OUTPUT POINT, SINCE THE LOCAL COPY OF EACH STILL EXISTS.
C
      KOD = 1
      IF (NDISK .EQ. 0)  KOD = NXPTS
      I1=1+NFCC*NFCC
      I2=I1+NFCC
      CALL SCOEF(U(1,1,KOD),V(1,KOD),NCOMP,NROWB,NFC,NIC,B,BETA,COEF,
     1           INHOMO,RE,AE,WORK,WORK(I1),WORK(I2),IWORK,IFLAG,NFCC)
C
C **********************************************************************
C     CALCULATE SOLUTION AT OUTPUT POINTS BY RECURRING BACKWARDS.
C     AS WE RECUR BACKWARDS FROM XFINAL TO XINITIAL WE MUST CALCULATE
C     NEW SUPERPOSITION COEFFICIENTS EACH TIME WE CROSS A POINT OF
C     ORTHONORMALIZATION.
C
      K = NUMORT
      NCOMP2=NCOMP/2
      IC=1
      IF (NFC .NE. NFCC) IC=2
      DO 200 J = 1,NXPTS
      KPTS = NXPTS - J + 1
      KOD = KPTS
      IF (NDISK .EQ. 1)  KOD = 1
  135 IF (K .EQ. 0)  GO TO 170
      IF (XEND.GT.XBEG .AND. XPTS(KPTS).GE.Z(K))  GO TO 170
      IF (XEND.LT.XBEG .AND. XPTS(KPTS).LE.Z(K))  GO TO 170
      NON = K
      IF (NDISK .EQ. 0)  GO TO 136
      NON = 1
      BACKSPACE NTAPE
      READ (NTAPE) (IP(I,1), I = 1,NFCC),(P(I,1), I = 1,NTP)
      BACKSPACE NTAPE
  136 IF (INHOMO .NE. 1)  GO TO 150
      IF (NDISK .EQ. 0)  GO TO 138
      BACKSPACE NTAPE
      READ (NTAPE) (W(I,1), I = 1,NFCC)
      BACKSPACE NTAPE
  138 DO 140 N = 1,NFCC
  140 COEF(N) = COEF(N) - W(N,NON)
  150 CALL BKSOL(NFCC,P(1,NON),COEF)
      DO 155 M = 1,NFCC
  155 WORK(M) = COEF(M)
      DO 160 M = 1,NFCC
      L = IP(M,NON)
  160 COEF(L) = WORK(M)
      K = K - 1
      GO TO 135
  170 IF (NDISK .EQ. 0)  GO TO 175
      BACKSPACE NTAPE
      READ (NTAPE) (V(I,1), I = 1,NCOMP),
     1             ((U(I,M,1), I = 1,NCOMP), M = 1,NFC)
      BACKSPACE NTAPE
  175 DO 180 N = 1,NCOMP
  180 Y(N,KPTS) = V(N,KOD) + SDOT(NFC,U(N,1,KOD),NCOMP,COEF,IC)
      IF (NFC .EQ. NFCC) GO TO 200
      DO 190 N=1,NCOMP2
      NN=NCOMP2+N
      Y(N,KPTS)=Y(N,KPTS) - SDOT(NFC,U(NN,1,KOD),NCOMP,COEF(2),2)
  190 Y(NN,KPTS)=Y(NN,KPTS) + SDOT(NFC,U(N,1,KOD),NCOMP,COEF(2),2)
  200 CONTINUE
C
C **********************************************************************
C
  250 MXNON = NUMORT
      RETURN
      END
*DECK BVSUP
      SUBROUTINE BVSUP (Y, NROWY, NCOMP, XPTS, NXPTS, A, NROWA, ALPHA,
     +   NIC, B, NROWB, BETA, NFC, IGOFX, RE, AE, IFLAG, WORK, NDW,
     +   IWORK, NDIW, NEQIVP)
C***BEGIN PROLOGUE  BVSUP
C***PURPOSE  Solve a linear two-point boundary value problem using
C            superposition coupled with an orthonormalization procedure
C            and a variable-step integration scheme.
C***LIBRARY   SLATEC
C***CATEGORY  I1B1
C***TYPE      SINGLE PRECISION (BVSUP-S, DBVSUP-D)
C***KEYWORDS  ORTHONORMALIZATION, SHOOTING,
C             TWO-POINT BOUNDARY VALUE PROBLEM
C***AUTHOR  Scott, M. R., (SNLA)
C           Watts, H. A., (SNLA)
C***DESCRIPTION
C
C **********************************************************************
C     Subroutine BVSUP solves a LINEAR two-point boundary-value problem
C     of the form
C                        dY/dX = MATRIX(X,U)*Y(X) + G(X,U)
C                A*Y(Xinitial) = ALPHA ,  B*Y(Xfinal) = BETA
C
C     Coupled with the solution of the initial value problem
C
C                        dU/dX = F(X,U)
C                      U(Xinitial) = ETA
C
C **********************************************************************
C     Abstract
C        The method of solution uses superposition coupled with an
C     orthonormalization procedure and a variable-step integration
C     scheme.  Each time the superposition solutions start to
C     lose their numerical linear independence, the vectors are
C     reorthonormalized before integration proceeds.  The underlying
C     principle of the algorithm is then to piece together the
C     intermediate (orthogonalized) solutions, defined on the various
C     subintervals, to obtain the desired solutions.
C
C **********************************************************************
C     INPUT to BVSUP
C **********************************************************************
C
C     NROWY = Actual row dimension of Y in calling program.
C             NROWY must be .GE. NCOMP
C
C     NCOMP = Number of components per solution vector.
C             NCOMP is equal to number of original differential
C             equations.  NCOMP = NIC + NFC.
C
C     XPTS = Desired output points for solution. They must be monotonic.
C            Xinitial = XPTS(1)
C            Xfinal = XPTS(NXPTS)
C
C     NXPTS = Number of output points
C
C     A(NROWA,NCOMP) = Boundary condition matrix at Xinitial,
C                      must be contained in (NIC,NCOMP) sub-matrix.
C
C     NROWA = Actual row dimension of A in calling program,
C             NROWA must be .GE. NIC.
C
C     ALPHA(NIC+NEQIVP) = Boundary conditions at Xinitial.
C                         If NEQIVP .GT. 0 (see below), the boundary
C                         conditions at Xinitial for the initial value
C                         equations must be stored starting in
C                         position (NIC + 1) of ALPHA.
C                         Thus,  ALPHA(NIC+K) = ETA(K).
C
C     NIC = Number of boundary conditions at Xinitial.
C
C     B(NROWB,NCOMP) = Boundary condition matrix at Xfinal,
C                      must be contained in (NFC,NCOMP) sub-matrix.
C
C     NROWB = Actual row dimension of B in calling program,
C             NROWB must be .GE. NFC.
C
C     BETA(NFC) = Boundary conditions at Xfinal.
C
C     NFC = Number of boundary conditions at Xfinal
C
C     IGOFX =0 -- The inhomogeneous term G(X) is identically zero.
C           =1 -- The inhomogeneous term G(X) is not identically zero.
C                 (if IGOFX=1, then subroutine GVEC (or UVEC) must be
C                  supplied).
C
C     RE = Relative error tolerance used by the integrator
C          (see one of the integrators)
C
C     AE = Absolute error tolerance used by the integrator
C          (see one of the integrators)
C **NOTE-  RE and AE should not both be zero.
C
C     IFLAG = A status parameter used principally for output.
C             However, for efficient solution of problems which
C             are originally defined as complex valued (but
C             converted to real systems to use this code), the
C             user must set IFLAG=13 on input. See the comment below
C             for more information on solving such problems.
C
C     WORK(NDW) = Floating point array used for internal storage.
C
C     NDW = Actual dimension of WORK array allocated by user.
C           An estimate for NDW can be computed from the following
C            NDW = 130 + NCOMP**2 * (6 + NXPTS/2 + expected number of
C                                                orthonormalizations/8)
C             For the DISK or TAPE storage mode,
C            NDW = 6 * NCOMP**2 + 10 * NCOMP + 130
C  However, when the ADAMS integrator is to be used, the estimates are
C            NDW = 130 + NCOMP**2 * (13 + NXPTS/2 + expected number of
C                                                orthonormalizations/8)
C    and     NDW = 13 * NCOMP**2 + 22 * NCOMP + 130   , respectively.
C
C     IWORK(NDIW) = Integer array used for internal storage.
C
C     NDIW = Actual dimension of IWORK array allocated by user.
C            An estimate for NDIW can be computed from the following
C            NDIW = 68 + NCOMP * (1 + expected number of
C                                        orthonormalizations)
C **NOTE --  The amount of storage required is problem dependent and may
C            be difficult to predict in advance. Experience has shown
C            that for most problems 20 or fewer orthonormalizations
C            should suffice. If the problem cannot be completed with the
C            allotted storage, then a message will be printed which
C            estimates the amount of storage necessary. In any case, the
C            user can examine the IWORK array for the actual storage
C            requirements, as described in the output information below.
C
C     NEQIVP = Number of auxiliary initial value equations being added
C              to the boundary value problem.
C **NOTE -- Occasionally the coefficients  MATRIX  and/or  G  may be
C           functions which depend on the independent variable  X  and
C           on  U, the solution of an auxiliary initial value problem.
C           In order to avoid the difficulties associated with
C           interpolation, the auxiliary equations may be solved
C           simultaneously with the given boundary value problem.
C           This initial value problem may be LINEAR or NONLINEAR.
C                 See SAND77-1328 for an example.
C
C
C     The user must supply subroutines FMAT, GVEC, UIVP and UVEC, when
C     needed (they MUST be so named), to evaluate the derivatives
C     as follows
C
C        A. FMAT must be supplied.
C
C              SUBROUTINE FMAT(X,Y,YP)
C              X = Independent variable (input to FMAT)
C              Y = Dependent variable vector (input to FMAT)
C              YP = dY/dX = Derivative vector (output from FMAT)
C
C            Compute the derivatives for the HOMOGENEOUS problem
C              YP(I) = dY(I)/dX = MATRIX(X) * Y(I)  , I = 1,...,NCOMP
C
C            When (NEQIVP .GT. 0) and  MATRIX  is dependent on  U  as
C            well as on  X, the following common statement must be
C            included in FMAT
C                    COMMON /MLIVP/ NOFST
C            For convenience, the  U  vector is stored at the bottom
C            of the  Y  array.  Thus, during any call to FMAT,
C            U(I) is referenced by  Y(NOFST + I).
C
C
C            Subroutine BVDER calls FMAT NFC times to evaluate the
C            homogeneous equations and, if necessary, it calls FMAT once
C            in evaluating the particular solution. Since X remains
C            unchanged in this sequence of calls it is possible to
C            realize considerable computational savings for complicated
C            and expensive evaluations of the MATRIX entries. To do this
C            the user merely passes a variable, say XS, via COMMON where
C            XS is defined in the main program to be any value except
C            the initial X. Then the non-constant elements of MATRIX(X)
C            appearing in the differential equations need only be
C            computed if X is unequal to XS, whereupon XS is reset to X.
C
C
C        B. If  NEQIVP .GT. 0 ,  UIVP must also be supplied.
C
C              SUBROUTINE UIVP(X,U,UP)
C              X = Independent variable (input to UIVP)
C              U = Dependent variable vector (input to UIVP)
C              UP = dU/dX = Derivative vector (output from UIVP)
C
C            Compute the derivatives for the auxiliary initial value eqs
C              UP(I) = dU(I)/dX, I = 1,...,NEQIVP.
C
C            Subroutine BVDER calls UIVP once to evaluate the
C            derivatives for the auxiliary initial value equations.
C
C
C        C. If  NEQIVP = 0  and  IGOFX = 1 ,  GVEC must be supplied.
C
C              SUBROUTINE GVEC(X,G)
C              X = Independent variable (input to GVEC)
C              G = Vector of inhomogeneous terms G(X) (output from GVEC)
C
C            Compute the inhomogeneous terms G(X)
C                G(I) = G(X) values for I = 1,...,NCOMP.
C
C            Subroutine BVDER calls GVEC in evaluating the particular
C            solution provided G(X) is NOT identically zero. Thus, when
C            IGOFX=0, the user need NOT write a GVEC subroutine. Also,
C            the user does not have to bother with the computational
C            savings scheme for GVEC as this is automatically achieved
C            via the BVDER subroutine.
C
C
C        D. If  NEQIVP .GT. 0  and  IGOFX = 1 ,  UVEC must be supplied.
C
C              SUBROUTINE UVEC(X,U,G)
C              X = Independent variable (input to UVEC)
C              U = Dependent variable vector from the auxiliary initial
C                  value problem    (input to UVEC)
C              G = Array of inhomogeneous terms G(X,U)(output from UVEC)
C
C            Compute the inhomogeneous terms G(X,U)
C                G(I) = G(X,U) values for I = 1,...,NCOMP.
C
C            Subroutine BVDER calls UVEC in evaluating the particular
C            solution provided G(X,U) is NOT identically zero.  Thus,
C            when IGOFX=0, the user need NOT write a UVEC subroutine.
C
C
C
C     The following is optional input to BVSUP to give the user more
C     flexibility in use of the code.  See SAND75-0198 , SAND77-1328 ,
C     SAND77-1690,SAND78-0522, and SAND78-1501 for more information.
C
C ****CAUTION -- The user MUST zero out IWORK(1),...,IWORK(15)
C                prior to calling BVSUP. These locations define optional
C                input and MUST be zero UNLESS set to special values by
C                the user as described below.
C
C     IWORK(1) -- Number of orthonormalization points.
C                 A value need be set only if IWORK(11) = 1
C
C     IWORK(9) -- Integrator and orthonormalization parameter
C                 (default value is 1)
C                 1 = RUNGE-KUTTA-FEHLBERG code using GRAM-SCHMIDT test.
C                 2 = ADAMS code using GRAM-SCHMIDT TEST.
C
C     IWORK(11) -- Orthonormalization points parameter
C                  (default value is 0)
C                  0 - Orthonormalization points not pre-assigned.
C                  1 - Orthonormalization points pre-assigned in
C                      the first IWORK(1) positions of WORK.
C
C     IWORK(12) -- Storage parameter
C                  (default value is 0)
C                  0 - All storage IN CORE
C                LUN - Homogeneous and inhomogeneous solutions at
C                     output points and orthonormalization information
C                     are stored on DISK.  The logical unit number to be
C                     used for DISK I/O (NTAPE) is set to IWORK(12).
C
C     WORK(1),... -- Pre-assigned orthonormalization points, stored
C                    monotonically, corresponding to the direction
C                    of integration.
C
C
C
C                 ******************************
C                 *** COMPLEX VALUED PROBLEM ***
C                 ******************************
C **NOTE***
C       Suppose the original boundary value problem is NC equations
C     of the form
C                   dW/dX = MAT(X,U)*W(X) + H(X,U)
C                 R*W(Xinitial)=GAMMA , S*W(Xfinal)=DELTA
C
C     where all variables are complex valued. The BVSUP code can be
C     used by converting to a real system of size 2*NC. To solve the
C     larger dimensioned problem efficiently,  the user must initialize
C     IFLAG=13 on input and order the vector components according to
C     Y(1)=real(W(1)),...,Y(NC)=real(W(NC)),Y(NC+1)=imag(W(1)),....,
C     Y(2*NC)=imag(W(NC)). Then define
C                        ...........................
C                        . real(MAT)    -imag(MAT) .
C            MATRIX  =   .                         .
C                        . imag(MAT)     real(MAT) .
C                        ...........................
C
C     The matrices A,B and vectors G,ALPHA,BETA must be defined
C     similarly. Further details can be found in SAND78-1501.
C
C
C **********************************************************************
C     OUTPUT from BVSUP
C **********************************************************************
C
C     Y(NROWY,NXPTS) = Solution at specified output points.
C
C     IFLAG output values
C            =-5 Algorithm ,for obtaining starting vectors for the
C                special complex problem structure, was unable to obtain
C                the initial vectors satisfying the necessary
C                independence criteria.
C            =-4 Rank of boundary condition matrix A is less than NIC,
C                as determined by LSSUDS.
C            =-2 Invalid input parameters.
C            =-1 Insufficient number of storage locations allocated for
C                WORK or IWORK.
C
C            =0 Indicates successful solution
C
C            =1 A computed solution is returned but UNIQUENESS of the
C               solution of the boundary-value problem is questionable.
C               For an eigenvalue problem, this should be treated as a
C               successful execution since this is the expected mode
C               of return.
C            =2 A computed solution is returned but the EXISTENCE of the
C               solution to the boundary-value problem is questionable.
C            =3 A nontrivial solution approximation is returned although
C               the boundary condition matrix B*Y(Xfinal) is found to be
C               nonsingular (to the desired accuracy level) while the
C               right hand side vector is zero. To eliminate this type
C               of return, the accuracy of the eigenvalue parameter
C               must be improved.
C           ***NOTE- We attempt to diagnose the correct problem behavior
C               and report possible difficulties by the appropriate
C               error flag.  However, the user should probably resolve
C               the problem using smaller error tolerances and/or
C               perturbations in the boundary conditions or other
C               parameters. This will often reveal the correct
C               interpretation for the problem posed.
C
C            =13 Maximum number of orthonormalizations attained before
C                reaching Xfinal.
C            =20-flag from integrator (DERKF or DEABM) values can range
C                from 21 to 25.
C            =30 Solution vectors form a dependent set.
C
C     WORK(1),...,WORK(IWORK(1)) = Orthonormalization points
C                                  determined by BVPOR.
C
C     IWORK(1) = Number of orthonormalizations performed by BVPOR.
C
C     IWORK(2) = Maximum number of orthonormalizations allowed as
C                calculated from storage allocated by user.
C
C     IWORK(3),IWORK(4),IWORK(5),IWORK(6)   Give information about
C                actual storage requirements for WORK and IWORK
C                arrays.  In particular,
C                       required storage for  WORK array is
C        IWORK(3) + IWORK(4)*(expected number of orthonormalizations)
C
C                       required storage for IWORK array is
C        IWORK(5) + IWORK(6)*(expected number of orthonormalizations)
C
C     IWORK(8) = Final value of exponent parameter used in tolerance
C                test for orthonormalization.
C
C     IWORK(16) = Number of independent vectors returned from MGSBV.
C                 It is only of interest when IFLAG=30 is obtained.
C
C     IWORK(17) = Numerically estimated rank of the boundary
C                 condition matrix defined from B*Y(Xfinal)
C
C **********************************************************************
C
C     Necessary machine constants are defined in the function
C     routine R1MACH. The user must make sure that the values
C     set in R1MACH are relevant to the computer being used.
C
C **********************************************************************
C
C***REFERENCES  M. R. Scott and H. A. Watts, SUPORT - a computer code
C                 for two-point boundary-value problems via
C                 orthonormalization, SIAM Journal of Numerical
C                 Analysis 14, (1977), pp. 40-70.
C               B. L. Darlow, M. R. Scott and H. A. Watts, Modifications
C                 of SUPORT, a linear boundary value problem solver
C                 Part I - pre-assigning orthonormalization points,
C                 auxiliary initial value problem, disk or tape storage,
C                 Report SAND77-1328, Sandia Laboratories, Albuquerque,
C                 New Mexico, 1977.
C               B. L. Darlow, M. R. Scott and H. A. Watts, Modifications
C                 of SUPORT, a linear boundary value problem solver
C                 Part II - inclusion of an Adams integrator, Report
C                 SAND77-1690, Sandia Laboratories, Albuquerque,
C                 New Mexico, 1977.
C               M. E. Lord and H. A. Watts, Modifications of SUPORT,
C                 a linear boundary value problem solver Part III -
C                 orthonormalization improvements, Report SAND78-0522,
C                 Sandia Laboratories, Albuquerque, New Mexico, 1978.
C               H. A. Watts, M. R. Scott and M. E. Lord, Computational
C                 solution of complex*16 valued boundary problems,
C                 Report SAND78-1501, Sandia Laboratories,
C                 Albuquerque, New Mexico, 1978.
C***ROUTINES CALLED  EXBVP, MACON, XERMSG
C***COMMON BLOCKS    ML15TO, ML17BW, ML18JR, ML5MCO, ML8SZ
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890921  Realigned order of variables in certain COMMON blocks.
C           (WRB)
C   890921  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900510  Convert XERRWV calls to XERMSG calls.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  BVSUP
C **********************************************************************
C
C
      DIMENSION Y(NROWY,*),A(NROWA,*),ALPHA(*),B(NROWB,*),
     1          BETA(*),WORK(*),IWORK(*),XPTS(*)
      CHARACTER*8 XERN1, XERN2, XERN3, XERN4
C
C **********************************************************************
C     THE COMMON BLOCK BELOW IS USED TO COMMUNICATE WITH SUBROUTINE
C     BVDER.  THE USER SHOULD NOT ALTER OR USE THIS COMMON BLOCK IN THE
C     CALLING PROGRAM.
C
      COMMON /ML8SZ/ C,XSAV,IGOFXD,INHOMO,IVP,NCOMPD,NFCD
C
C **********************************************************************
C     THESE COMMON BLOCKS AID IN REDUCING THE NUMBER OF SUBROUTINE
C     ARGUMENTS PREVALENT IN THIS MODULAR STRUCTURE
C
      COMMON /ML18JR/ AED,RED,TOL,NXPTSD,NICD,NOPG,MXNON,NDISK,NTAPE,
     1                NEQ,INDPVT,INTEG,NPS,NTP,NEQIVD,NUMORT,NFCC,
     2                ICOCO
      COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9,
     1                K10,K11,L1,L2,KKKINT,LLLINT
C
C **********************************************************************
C     THIS COMMON BLOCK IS USED IN SUBROUTINES BVSUP,BVPOR,RKFAB,
C     REORT, AND STWAY. IT CONTAINS INFORMATION NECESSARY
C     FOR THE ORTHONORMALIZATION TESTING PROCEDURE AND A BACKUP
C     RESTARTING CAPABILITY.
C
      COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP,
     1                KNSWOT,KOP,LOTJP,MNSWOT,NSWOT
C
C **********************************************************************
C     THIS COMMON BLOCK CONTAINS THE MACHINE DEPENDENT PARAMETERS
C     USED BY THE CODE
C
      COMMON /ML5MCO/ URO,SRU,EPS,SQOVFL,TWOU,FOURU,LPAR
C
C **********************************************************************
C     SET UP MACHINE DEPENDENT CONSTANTS.
C
C***FIRST EXECUTABLE STATEMENT  BVSUP
      CALL MACON
C
C **********************************************************************
C     TEST FOR INVALID INPUT
C
      IF (NROWY .LT. NCOMP)  GO TO 20
      IF (NCOMP .NE. NIC+NFC)  GO TO 20
      IF (NXPTS .LT. 2)  GO TO 20
      IF (NIC .LE. 0)  GO TO 20
      IF (NROWA .LT. NIC)  GO TO 20
      IF (NFC .LE. 0)  GO TO 20
      IF (NROWB .LT. NFC)  GO TO 20
      IF (IGOFX .LT. 0  .OR.  IGOFX .GT. 1) GO TO 20
      IF (RE .LT. 0.0)  GO TO 20
      IF (AE .LT. 0.0)  GO TO 20
      IF (RE .EQ. 0.0  .AND.  AE .EQ. 0.0)  GO TO 20
      IS = 1
      IF (XPTS(NXPTS) .LT. XPTS(1))  IS = 2
      NXPTSM = NXPTS - 1
      DO 13 K = 1,NXPTSM
      IF (IS .EQ. 2) GO TO 12
      IF (XPTS(K+1) .LE. XPTS(K))  GO TO 20
      GO TO 13
   12 IF (XPTS(K) .LE. XPTS(K+1))  GO TO 20
   13 CONTINUE
      GO TO 30
   20 IFLAG = -2
      RETURN
   30 CONTINUE
C
C **********************************************************************
C     CHECK FOR DISK STORAGE
C
      KPTS = NXPTS
      NDISK = 0
      IF (IWORK(12) .EQ. 0)  GO TO 35
      NTAPE = IWORK(12)
      KPTS = 1
      NDISK = 1
   35 CONTINUE
C
C **********************************************************************
C     SET INTEG PARAMETER ACCORDING TO CHOICE OF INTEGRATOR.
C
      INTEG = 1
      IF (IWORK(9) .EQ. 2)  INTEG = 2
C
C **********************************************************************
C     COMPUTE INHOMO
C
      IF (IGOFX .EQ. 1)  GO TO 43
      DO 40 J = 1,NIC
      IF (ALPHA(J) .NE. 0.0)  GO TO 43
   40 CONTINUE
      DO 41 J = 1,NFC
      IF (BETA(J) .NE. 0.0)  GO TO 42
   41 CONTINUE
      INHOMO = 3
      GO TO 45
   42 INHOMO = 2
      GO TO 45
   43 INHOMO = 1
   45 CONTINUE
C
C **********************************************************************
C     TO TAKE ADVANTAGE OF THE SPECIAL STRUCTURE WHEN SOLVING A
C     COMPLEX VALUED PROBLEM,WE INTRODUCE NFCC=NFC WHILE CHANGING
C     THE INTERNAL VALUE OF NFC
C
      NFCC=NFC
      IF (IFLAG .EQ. 13) NFC=NFC/2
C
C **********************************************************************
C     DETERMINE NECESSARY STORAGE REQUIREMENTS
C
C FOR BASIC ARRAYS IN BVPOR
      KKKYHP = NCOMP*(NFC+1) + NEQIVP
      KKKU   = NCOMP*NFC*KPTS
      KKKV   = NCOMP*KPTS
      KKKCOE = NFCC
      KKKS   = NFC+1
      KKKSTO = NCOMP*(NFC+1) + NEQIVP + 1
      KKKG   = NCOMP
C
C FOR ORTHONORMALIZATION RELATED MATTERS
      NTP = (NFCC*(NFCC+1))/2
      KKKZPW = 1 + NTP + NFCC
      LLLIP  = NFCC
C
C FOR ADDITIONAL REQUIRED WORK SPACE
C   (LSSUDS)
      KKKSUD = 4*NIC + (NROWA+1)*NCOMP
      LLLSUD = NIC
C   (SVECS)
      KKKSVC = 1 + 4*NFCC + 2*NFCC**2
      LLLSVC = 2*NFCC
C
      NDEQ=NCOMP*NFC+NEQIVP
      IF (INHOMO .EQ. 1) NDEQ=NDEQ+NCOMP
      GO TO (51,52),INTEG
C   (DERKF)
   51 KKKINT = 33 + 7*NDEQ
      LLLINT = 34
      GO TO 55
C   (DEABM)
   52 KKKINT = 130 + 21*NDEQ
      LLLINT = 51
C
C   (COEF)
   55 KKKCOF = 5*NFCC + NFCC**2
      LLLCOF = 3 + NFCC
C
      KKKWS  = MAX(KKKSUD,KKKSVC,KKKINT,KKKCOF)
      LLLIWS = MAX(LLLSUD,LLLSVC,LLLINT,LLLCOF)
C
      NEEDW  = KKKYHP + KKKU + KKKV + KKKCOE + KKKS + KKKSTO + KKKG +
     1         KKKZPW + KKKWS
      NEEDIW = 17 + LLLIP + LLLIWS
C **********************************************************************
C     COMPUTE THE NUMBER OF POSSIBLE ORTHONORMALIZATIONS WITH THE
C     ALLOTTED STORAGE
C
      IWORK(3) = NEEDW
      IWORK(4) = KKKZPW
      IWORK(5) = NEEDIW
      IWORK(6) = LLLIP
      NRTEMP = NDW - NEEDW
      NITEMP = NDIW - NEEDIW
      IF (NRTEMP .LT. 0)  GO TO 70
      IF (NITEMP .GE. 0)  GO TO 75
C
   70 IFLAG = -1
      IF (NDISK .NE. 1) THEN
         WRITE (XERN1, '(I8)') NEEDW
         WRITE (XERN2, '(I8)') KKKZPW
         WRITE (XERN3, '(I8)') NEEDIW
         WRITE (XERN4, '(I8)') LLLIP
         CALL XERMSG ('SLATEC', 'BVSUP',
     *      'REQUIRED STORAGE FOR WORK ARRAY IS '  // XERN1 // ' + ' //
     *      XERN2 // '*(EXPECTED NUMBER OF ORTHONORMALIZATIONS) $$'  //
     *      'REQUIRED STORAGE FOR IWORK ARRAY IS ' // XERN3 // ' + ' //
     *      XERN4 // '*(EXPECTED NUMBER OF ORTHONORMALIZATIONS)', 1, 0)
      ELSE
         WRITE (XERN1, '(I8)') NEEDW
         WRITE (XERN2, '(I8)') NEEDIW
         CALL XERMSG ('SLATEC', 'BVSUP',
     *      'REQUIRED STORAGE FOR WORK ARRAY IS '  // XERN1 //
     *      ' + NUMBER OF ORTHONOMALIZATIONS. $$'  //
     *      'REQUIRED STORAGE FOR IWORK ARRAY IS ' // XERN2, 1, 0)
      ENDIF
      RETURN
C
   75 IF (NDISK .EQ. 0)  GO TO 77
      NON = 0
      MXNON = NRTEMP
      GO TO 78
C
   77 MXNONR = NRTEMP / KKKZPW
      MXNONI = NITEMP / LLLIP
      MXNON = MIN(MXNONR,MXNONI)
      NON = MXNON
C
   78 IWORK(2) = MXNON
C
C **********************************************************************
C     CHECK FOR PRE-ASSIGNED ORTHONORMALIZATION POINTS
C
      NOPG = 0
      IF (IWORK(11) .NE. 1)  GO TO 85
      IF (MXNON .LT. IWORK(1))  GO TO 70
      NOPG = 1
      MXNON = IWORK(1)
      WORK(MXNON+1) = 2. * XPTS(NXPTS)  -  XPTS(1)
   85 CONTINUE
C
C **********************************************************************
C     ALLOCATE STORAGE FROM WORK AND IWORK ARRAYS
C
C  (Z)
      K1 = 1 + (MXNON+1)
C  (P)
      K2 = K1 + NTP*(NON+1)
C  (W)
      K3 = K2 + NFCC*(NON+1)
C  (YHP)
      K4 = K3 + KKKYHP
C  (U)
      K5 = K4 + KKKU
C  (V)
      K6 = K5 + KKKV
C  (COEF)
      K7 = K6 + KKKCOE
C  (S)
      K8 = K7 + KKKS
C  (STOWA)
      K9 = K8 + KKKSTO
C  (G)
      K10 = K9 + KKKG
      K11 = K10 + KKKWS
C            REQUIRED ADDITIONAL REAL WORK SPACE STARTS AT WORK(K10)
C            AND EXTENDS TO WORK(K11-1)
C
C     FIRST 17 LOCATIONS OF IWORK ARE USED FOR OPTIONAL
C     INPUT AND OUTPUT ITEMS
C  (IP)
      L1 = 18 + NFCC*(NON+1)
      L2 = L1 + LLLIWS
C            REQUIRED INTEGER WORK SPACE STARTS AT IWORK(L1)
C            AND EXTENDS TO IWORK(L2-1)
C
C **********************************************************************
C     SET INDICATOR FOR NORMALIZATION OF PARTICULAR SOLUTION
C
      NPS = 0
      IF (IWORK(10) .EQ. 1)  NPS = 1
C
C **********************************************************************
C     SET PIVOTING PARAMETER
C
      INDPVT=0
      IF (IWORK(15) .EQ. 1) INDPVT=1
C
C **********************************************************************
C     SET OTHER COMMON BLOCK PARAMETERS
C
      NFCD = NFC
      NCOMPD = NCOMP
      IGOFXD = IGOFX
      NXPTSD = NXPTS
      NICD = NIC
      RED = RE
      AED = AE
      NEQIVD = NEQIVP
      MNSWOT = 20
      IF (IWORK(13) .EQ. -1) MNSWOT=MAX(1,IWORK(14))
      XBEG=XPTS(1)
      XEND=XPTS(NXPTS)
      XSAV=XEND
      ICOCO=1
      IF (INHOMO .EQ. 3  .AND.  NOPG .EQ. 1) WORK(MXNON+1)=XEND
C
C **********************************************************************
C
      CALL EXBVP(Y,NROWY,XPTS,A,NROWA,ALPHA,B,NROWB,BETA,IFLAG,WORK,
     1           IWORK)
      NFC=NFCC
      IWORK(17)=IWORK(L1)
      RETURN
      END
