Add Makefile.extras to build libopenlibm-extras.

Replace amos with slatec

Makefile

@@ -1,7 +1,7 @@
 OPENLIBM_HOME=$(abspath .)
 include ./Make.inc
 
-SUBDIRS = src ld80 $(ARCH) bsdsrc amos Faddeeva
+SUBDIRS = src ld80 $(ARCH) bsdsrc
 
 define INC_template
 TEST=test
@@ -23,6 +23,7 @@ OBJS =  $(patsubst %.f,%.f.o,\
 
 all: libopenlibm.a libopenlibm.$(SHLIB_EXT) 
 	$(MAKE) -C test
+	$(MAKE) -f Makefile.extras
 libopenlibm.a: $(OBJS)  
 	$(AR) -rcs libopenlibm.a $(OBJS)
 libopenlibm.$(SHLIB_EXT): $(OBJS)
@@ -30,4 +31,5 @@ libopenlibm.$(SHLIB_EXT): $(OBJS)
 
 distclean:
 	rm -f $(OBJS) *.a *.$(SHLIB_EXT)
+	$(MAKE) -f Makefile.extras distclean
 	$(MAKE) -C test clean

amos/.gitignore

@@ -1,3 +0,0 @@
-*.o
-/libamos.dylib
-/libamos.so

amos/d1mach.f

@@ -1,97 +0,0 @@
-*DECK D1MACH
-      DOUBLE PRECISION FUNCTION D1MACH(I)
-C***BEGIN PROLOGUE  D1MACH
-C***DATE WRITTEN   750101   (YYMMDD)
-C***REVISION DATE  890213   (YYMMDD)
-C***CATEGORY NO.  R1
-C***KEYWORDS  LIBRARY=SLATEC,TYPE=DOUBLE PRECISION(R1MACH-S D1MACH-D),
-C             MACHINE CONSTANTS
-C***AUTHOR  FOX, P. A., (BELL LABS)
-C           HALL, A. D., (BELL LABS)
-C           SCHRYER, N. L., (BELL LABS)
-C***PURPOSE  Returns double precision machine dependent constants
-C***DESCRIPTION
-C
-C   D1MACH can be used to obtain machine-dependent parameters
-C   for the local machine environment.  It is a function
-C   subprogram with one (input) argument, and can be called
-C   as follows, for example
-C
-C        D = D1MACH(I)
-C
-C   where I=1,...,5.  The (output) value of D above is
-C   determined by the (input) value of I.  The results for
-C   various values of I are discussed below.
-C
-C   D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude.
-C   D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
-C   D1MACH( 3) = B**(-T), the smallest relative spacing.
-C   D1MACH( 4) = B**(1-T), the largest relative spacing.
-C   D1MACH( 5) = LOG10(B)
-C
-C   Assume double precision numbers are represented in the T-digit,
-C   base-B form
-C
-C              sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
-C
-C   where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and
-C   EMIN .LE. E .LE. EMAX.
-C
-C   The values of B, T, EMIN and EMAX are provided in I1MACH as
-C   follows:
-C   I1MACH(10) = B, the base.
-C   I1MACH(14) = T, the number of base-B digits.
-C   I1MACH(15) = EMIN, the smallest exponent E.
-C   I1MACH(16) = EMAX, the largest exponent E.
-C
-C   To alter this function for a particular environment,
-C   the desired set of DATA statements should be activated by
-C   removing the C from column 1.  Also, the values of
-C   D1MACH(1) - D1MACH(4) should be checked for consistency
-C   with the local operating system.
-C
-C***REFERENCES  FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
-C                 PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
-C                 SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
-C***ROUTINES CALLED  XERROR
-C***END PROLOGUE  D1MACH
-C
-      INTEGER SMALL(4)
-      INTEGER LARGE(4)
-      INTEGER RIGHT(4)
-      INTEGER DIVER(4)
-      INTEGER LOG10(4)
-C
-      DOUBLE PRECISION DMACH(5)
-      SAVE DMACH
-C
-C      EQUIVALENCE (DMACH(1),SMALL(1))
-C      EQUIVALENCE (DMACH(2),LARGE(1))
-C      EQUIVALENCE (DMACH(3),RIGHT(1))
-C      EQUIVALENCE (DMACH(4),DIVER(1))
-C      EQUIVALENCE (DMACH(5),LOG10(1))
-C
-C     MACHINE CONSTANTS FOR THE IBM PC
-C     ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION
-C     ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087.
-C
-      DATA DMACH(1) / 2.23D-308 /
-C      DATA SMALL(1),SMALL(2) /  2002288515,    1050897 /
-      DATA DMACH(2) / 1.79D-308 /
-C      DATA LARGE(1),LARGE(2) /  1487780761, 2146426097 /
-      DATA DMACH(3) / 1.11D-16 /
-C      DATA RIGHT(1),RIGHT(2) / -1209488034, 1017118298 /
-      DATA DMACH(4) / 2.22D-16 /
-C      DATA DIVER(1),DIVER(2) / -1209488034, 1018166874 /
-      DATA DMACH(5) / 0.3010299956639812 /
-C      DATA LOG10(1),LOG10(2) /  1352628735, 1070810131 /
-C
-C
-C***FIRST EXECUTABLE STATEMENT  D1MACH
-      IF (I .LT. 1  .OR.  I .GT. 5)
-     1   CALL XERROR ('D1MACH -- I OUT OF BOUNDS', 25, 1, 2)
-C
-      D1MACH = DMACH(I)
-      RETURN
-C
-      END

amos/i1mach.f

@@ -1,113 +0,0 @@
-*DECK I1MACH
-      INTEGER FUNCTION I1MACH(I)
-C***BEGIN PROLOGUE  I1MACH
-C***DATE WRITTEN   750101   (YYMMDD)
-C***REVISION DATE  890213   (YYMMDD)
-C***CATEGORY NO.  R1
-C***KEYWORDS  LIBRARY=SLATEC,TYPE=INTEGER(I1MACH-I),MACHINE CONSTANTS
-C***AUTHOR  FOX, P. A., (BELL LABS)
-C           HALL, A. D., (BELL LABS)
-C           SCHRYER, N. L., (BELL LABS)
-C***PURPOSE  Returns integer machine dependent constants
-C***DESCRIPTION
-C
-C     I1MACH can be used to obtain machine-dependent parameters
-C     for the local machine environment.  It is a function
-C     subroutine with one (input) argument, and can be called
-C     as follows, for example
-C
-C          K = I1MACH(I)
-C
-C     where I=1,...,16.  The (output) value of K above is
-C     determined by the (input) value of I.  The results for
-C     various values of I are discussed below.
-C
-C  I/O unit numbers.
-C    I1MACH( 1) = the standard input unit.
-C    I1MACH( 2) = the standard output unit.
-C    I1MACH( 3) = the standard punch unit.
-C    I1MACH( 4) = the standard error message unit.
-C
-C  Words.
-C    I1MACH( 5) = the number of bits per integer storage unit.
-C    I1MACH( 6) = the number of characters per integer storage unit.
-C
-C  Integers.
-C    assume integers are represented in the S-digit, base-A form
-C
-C               sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
-C
-C               where 0 .LE. X(I) .LT. A for I=0,...,S-1.
-C    I1MACH( 7) = A, the base.
-C    I1MACH( 8) = S, the number of base-A digits.
-C    I1MACH( 9) = A**S - 1, the largest magnitude.
-C
-C  Floating-Point Numbers.
-C    Assume floating-point numbers are represented in the T-digit,
-C    base-B form
-C               sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
-C
-C               where 0 .LE. X(I) .LT. B for I=1,...,T,
-C               0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
-C    I1MACH(10) = B, the base.
-C
-C  Single-Precision
-C    I1MACH(11) = T, the number of base-B digits.
-C    I1MACH(12) = EMIN, the smallest exponent E.
-C    I1MACH(13) = EMAX, the largest exponent E.
-C
-C  Double-Precision
-C    I1MACH(14) = T, the number of base-B digits.
-C    I1MACH(15) = EMIN, the smallest exponent E.
-C    I1MACH(16) = EMAX, the largest exponent E.
-C
-C  To alter this function for a particular environment,
-C  the desired set of DATA statements should be activated by
-C  removing the C from column 1.  Also, the values of
-C  I1MACH(1) - I1MACH(4) should be checked for consistency
-C  with the local operating system.
-C
-C***REFERENCES  FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
-C                 PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
-C                 SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
-C***ROUTINES CALLED  (NONE)
-C***END PROLOGUE  I1MACH
-C
-      INTEGER IMACH(16),OUTPUT
-      SAVE IMACH
-      EQUIVALENCE (IMACH(4),OUTPUT)
-C
-C     MACHINE CONSTANTS FOR THE IBM PC
-C
-      DATA IMACH( 1) /     5 /
-      DATA IMACH( 2) /     6 /
-      DATA IMACH( 3) /     0 /
-      DATA IMACH( 4) /     0 /
-      DATA IMACH( 5) /    32 /
-      DATA IMACH( 6) /     4 /
-      DATA IMACH( 7) /     2 /
-      DATA IMACH( 8) /    31 /
-      DATA IMACH( 9) / 2147483647 /
-      DATA IMACH(10) /     2 /
-      DATA IMACH(11) /    24 /
-      DATA IMACH(12) /  -125 /
-      DATA IMACH(13) /   127 /
-      DATA IMACH(14) /    53 /
-      DATA IMACH(15) / -1021 /
-      DATA IMACH(16) /  1023 /
-C
-C***FIRST EXECUTABLE STATEMENT  I1MACH
-      IF (I .LT. 1  .OR.  I .GT. 16) GO TO 10
-C
-      I1MACH = IMACH(I)
-      RETURN
-C
-   10 CONTINUE
-      WRITE (UNIT = OUTPUT, FMT = 9000)
- 9000 FORMAT ('1ERROR    1 IN I1MACH - I OUT OF BOUNDS')
-C
-C     CALL FDUMP
-C
-C
-      STOP
-      END

amos/zbesh.f

@@ -1,348 +0,0 @@
-      SUBROUTINE ZBESH(ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR)
-C***BEGIN PROLOGUE  ZBESH
-C***DATE WRITTEN   830501   (YYMMDD)
-C***REVISION DATE  890801   (YYMMDD)
-C***CATEGORY NO.  B5K
-C***KEYWORDS  H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
-C             BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS
-C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
-C***PURPOSE  TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT
-C***DESCRIPTION
-C
-C                      ***A DOUBLE PRECISION ROUTINE***
-C         ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
-C         HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1
-C         OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX
-C         Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI.
-C         ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS
-C
-C         CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z)       MM=3-2*M,   I**2=-1.
-C
-C         WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND
-C         LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE
-C         NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1).
-C
-C         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION
-C           ZR,ZI  - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
-C                    -PT.LT.ARG(Z).LE.PI
-C           FNU    - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0
-C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
-C                    KODE= 1  RETURNS
-C                             CY(J)=H(M,FNU+J-1,Z),   J=1,...,N
-C                        = 2  RETURNS
-C                             CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))
-C                                  J=1,...,N  ,  I**2=-1
-C           M      - KIND OF HANKEL FUNCTION, M=1 OR 2
-C           N      - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1
-C
-C         OUTPUT     CYR,CYI ARE DOUBLE PRECISION
-C           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
-C                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
-C                    CY(J)=H(M,FNU+J-1,Z)  OR
-C                    CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))  J=1,...,N
-C                    DEPENDING ON KODE, I**2=-1.
-C           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
-C                    NZ= 0   , NORMAL RETURN
-C                    NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE
-C                              TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0)
-C                              J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR
-C                              Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY
-C                              HALF PLANES, NZ STATES ONLY THE NUMBER
-C                              OF UNDERFLOWS.
-C           IERR   - ERROR FLAG
-C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
-C                    IERR=1, INPUT ERROR   - NO COMPUTATION
-C                    IERR=2, OVERFLOW      - NO COMPUTATION, FNU TOO
-C                            LARGE OR CABS(Z) TOO SMALL OR BOTH
-C                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
-C                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
-C                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE
-C                            ACCURACY
-C                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
-C                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
-C                            CANCE BY ARGUMENT REDUCTION
-C                    IERR=5, ERROR              - NO COMPUTATION,
-C                            ALGORITHM TERMINATION CONDITION NOT MET
-C
-C***LONG DESCRIPTION
-C
-C         THE COMPUTATION IS CARRIED OUT BY THE RELATION
-C
-C         H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP))
-C             MP=MM*HPI*I,  MM=3-2*M,  HPI=PI/2,  I**2=-1
-C
-C         FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE
-C         RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED
-C         TO THE LEFT HALF PLANE BY THE RELATION
-C
-C         K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)
-C         MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1
-C
-C         WHERE I(FNU,Z) IS THE I BESSEL FUNCTION.
-C
-C         EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z
-C         PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2.  EXPONENTIAL
-C         GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES.  SCALING
-C         BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE
-C         WHOLE Z PLANE FOR Z TO INFINITY.
-C
-C         FOR NEGATIVE ORDERS,THE FORMULAE
-C
-C               H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I)
-C               H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I)
-C                         I**2=-1
-C
-C         CAN BE USED.
-C
-C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
-C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
-C         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
-C         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
-C         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
-C         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
-C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
-C         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
-C         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
-C         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
-C         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
-C         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
-C         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
-C         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
-C         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
-C         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
-C         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
-C         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
-C         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
-C
-C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
-C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
-C         ROUNDOFF,1.0D-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
-C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
-C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
-C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
-C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
-C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
-C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
-C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
-C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
-C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
-C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
-C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
-C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
-C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
-C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
-C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
-C         OR -PI/2+P.
-C
-C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
-C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
-C                 COMMERCE, 1955.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
-C
-C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
-C                 1018, MAY, 1985
-C
-C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
-C                 MATH. SOFTWARE, 1986
-C
-C***ROUTINES CALLED  ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH
-C***END PROLOGUE  ZBESH
-C
-C     COMPLEX CY,Z,ZN,ZT,CSGN
-      DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM,
-     * FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI,
-     * ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI,
-     * CSGNR, CSGNI
-      INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M,
-     * MM, MR, N, NN, NUF, NW, NZ, I1MACH
-      DIMENSION CYR(N), CYI(N)
-C
-      DATA HPI /1.57079632679489662D0/
-C
-C***FIRST EXECUTABLE STATEMENT  ZBESH
-      IERR = 0
-      NZ=0
-      IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1
-      IF (FNU.LT.0.0D0) IERR=1
-      IF (M.LT.1 .OR. M.GT.2) IERR=1
-      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
-      IF (N.LT.1) IERR=1
-      IF (IERR.NE.0) RETURN
-      NN = N
-C-----------------------------------------------------------------------
-C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
-C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
-C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
-C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
-C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
-C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
-C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
-C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
-C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
-C-----------------------------------------------------------------------
-      TOL = DMAX1(D1MACH(4),1.0D-18)
-      K1 = I1MACH(15)
-      K2 = I1MACH(16)
-      R1M5 = D1MACH(5)
-      K = MIN0(IABS(K1),IABS(K2))
-      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
-      K1 = I1MACH(14) - 1
-      AA = R1M5*DBLE(FLOAT(K1))
-      DIG = DMIN1(AA,18.0D0)
-      AA = AA*2.303D0
-      ALIM = ELIM + DMAX1(-AA,-41.45D0)
-      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
-      RL = 1.2D0*DIG + 3.0D0
-      FN = FNU + DBLE(FLOAT(NN-1))
-      MM = 3 - M - M
-      FMM = DBLE(FLOAT(MM))
-      ZNR = FMM*ZI
-      ZNI = -FMM*ZR
-C-----------------------------------------------------------------------
-C     TEST FOR PROPER RANGE
-C-----------------------------------------------------------------------
-      AZ = ZABS(COMPLEX(ZR,ZI))
-      AA = 0.5D0/TOL
-      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
-      AA = DMIN1(AA,BB)
-      IF (AZ.GT.AA) GO TO 260
-      IF (FN.GT.AA) GO TO 260
-      AA = DSQRT(AA)
-      IF (AZ.GT.AA) IERR=3
-      IF (FN.GT.AA) IERR=3
-C-----------------------------------------------------------------------
-C     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
-C-----------------------------------------------------------------------
-      UFL = D1MACH(1)*1.0D+3
-      IF (AZ.LT.UFL) GO TO 230
-      IF (FNU.GT.FNUL) GO TO 90
-      IF (FN.LE.1.0D0) GO TO 70
-      IF (FN.GT.2.0D0) GO TO 60
-      IF (AZ.GT.TOL) GO TO 70
-      ARG = 0.5D0*AZ
-      ALN = -FN*DLOG(ARG)
-      IF (ALN.GT.ELIM) GO TO 230
-      GO TO 70
-   60 CONTINUE
-      CALL ZUOIK(ZNR, ZNI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM,
-     * ALIM)
-      IF (NUF.LT.0) GO TO 230
-      NZ = NZ + NUF
-      NN = NN - NUF
-C-----------------------------------------------------------------------
-C     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
-C     IF NUF=NN, THEN CY(I)=CZERO FOR ALL I
-C-----------------------------------------------------------------------
-      IF (NN.EQ.0) GO TO 140
-   70 CONTINUE
-      IF ((ZNR.LT.0.0D0) .OR. (ZNR.EQ.0.0D0 .AND. ZNI.LT.0.0D0 .AND.
-     * M.EQ.2)) GO TO 80
-C-----------------------------------------------------------------------
-C     RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR.
-C     YN.GE.0. .OR. M=1)
-C-----------------------------------------------------------------------
-      CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM)
-      GO TO 110
-C-----------------------------------------------------------------------
-C     LEFT HALF PLANE COMPUTATION
-C-----------------------------------------------------------------------
-   80 CONTINUE
-      MR = -MM
-      CALL ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL,
-     * TOL, ELIM, ALIM)
-      IF (NW.LT.0) GO TO 240
-      NZ=NW
-      GO TO 110
-   90 CONTINUE
-C-----------------------------------------------------------------------
-C     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL
-C-----------------------------------------------------------------------
-      MR = 0
-      IF ((ZNR.GE.0.0D0) .AND. (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0 .OR.
-     * M.NE.2)) GO TO 100
-      MR = -MM
-      IF (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0) GO TO 100
-      ZNR = -ZNR
-      ZNI = -ZNI
-  100 CONTINUE
-      CALL ZBUNK(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM,
-     * ALIM)
-      IF (NW.LT.0) GO TO 240
-      NZ = NZ + NW
-  110 CONTINUE
-C-----------------------------------------------------------------------
-C     H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT)
-C
-C     ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2
-C-----------------------------------------------------------------------
-      SGN = DSIGN(HPI,-FMM)
-C-----------------------------------------------------------------------
-C     CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
-C     WHEN FNU IS LARGE
-C-----------------------------------------------------------------------
-      INU = INT(SNGL(FNU))
-      INUH = INU/2
-      IR = INU - 2*INUH
-      ARG = (FNU-DBLE(FLOAT(INU-IR)))*SGN
-      RHPI = 1.0D0/SGN
-C     ZNI = RHPI*DCOS(ARG)
-C     ZNR = -RHPI*DSIN(ARG)
-      CSGNI = RHPI*DCOS(ARG)
-      CSGNR = -RHPI*DSIN(ARG)
-      IF (MOD(INUH,2).EQ.0) GO TO 120
-C     ZNR = -ZNR
-C     ZNI = -ZNI
-      CSGNR = -CSGNR
-      CSGNI = -CSGNI
-  120 CONTINUE
-      ZTI = -FMM
-      RTOL = 1.0D0/TOL
-      ASCLE = UFL*RTOL
-      DO 130 I=1,NN
-C       STR = CYR(I)*ZNR - CYI(I)*ZNI
-C       CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR
-C       CYR(I) = STR
-C       STR = -ZNI*ZTI
-C       ZNI = ZNR*ZTI
-C       ZNR = STR
-        AA = CYR(I)
-        BB = CYI(I)
-        ATOL = 1.0D0
-        IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 135
-          AA = AA*RTOL
-          BB = BB*RTOL
-          ATOL = TOL
-  135 CONTINUE
-      STR = AA*CSGNR - BB*CSGNI
-      STI = AA*CSGNI + BB*CSGNR
-      CYR(I) = STR*ATOL
-      CYI(I) = STI*ATOL
-      STR = -CSGNI*ZTI
-      CSGNI = CSGNR*ZTI
-      CSGNR = STR
-  130 CONTINUE
-      RETURN
-  140 CONTINUE
-      IF (ZNR.LT.0.0D0) GO TO 230
-      RETURN
-  230 CONTINUE
-      NZ=0
-      IERR=2
-      RETURN
-  240 CONTINUE
-      IF(NW.EQ.(-1)) GO TO 230
-      NZ=0
-      IERR=5
-      RETURN
-  260 CONTINUE
-      NZ=0
-      IERR=4
-      RETURN
-      END

amos/zbesi.f

@@ -1,269 +0,0 @@
-      SUBROUTINE ZBESI(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
-C***BEGIN PROLOGUE  ZBESI
-C***DATE WRITTEN   830501   (YYMMDD)
-C***REVISION DATE  890801   (YYMMDD)
-C***CATEGORY NO.  B5K
-C***KEYWORDS  I-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION,
-C             MODIFIED BESSEL FUNCTION OF THE FIRST KIND
-C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
-C***PURPOSE  TO COMPUTE I-BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C***DESCRIPTION
-C
-C                    ***A DOUBLE PRECISION ROUTINE***
-C         ON KODE=1, ZBESI COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
-C         BESSEL FUNCTIONS CY(J)=I(FNU+J-1,Z) FOR REAL, NONNEGATIVE
-C         ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z IN THE CUT PLANE
-C         -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESI RETURNS THE SCALED
-C         FUNCTIONS
-C
-C         CY(J)=EXP(-ABS(X))*I(FNU+J-1,Z)   J = 1,...,N , X=REAL(Z)
-C
-C         WITH THE EXPONENTIAL GROWTH REMOVED IN BOTH THE LEFT AND
-C         RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
-C         ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
-C         (REF. 1).
-C
-C         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION
-C           ZR,ZI  - Z=CMPLX(ZR,ZI),  -PI.LT.ARG(Z).LE.PI
-C           FNU    - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0D0
-C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
-C                    KODE= 1  RETURNS
-C                             CY(J)=I(FNU+J-1,Z), J=1,...,N
-C                        = 2  RETURNS
-C                             CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)), J=1,...,N
-C           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
-C
-C         OUTPUT     CYR,CYI ARE DOUBLE PRECISION
-C           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
-C                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
-C                    CY(J)=I(FNU+J-1,Z)  OR
-C                    CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X))  J=1,...,N
-C                    DEPENDING ON KODE, X=REAL(Z)
-C           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
-C                    NZ= 0   , NORMAL RETURN
-C                    NZ.GT.0 , LAST NZ COMPONENTS OF CY SET TO ZERO
-C                              TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0)
-C                              J = N-NZ+1,...,N
-C           IERR   - ERROR FLAG
-C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
-C                    IERR=1, INPUT ERROR   - NO COMPUTATION
-C                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(Z) TOO
-C                            LARGE ON KODE=1
-C                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
-C                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
-C                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE
-C                            ACCURACY
-C                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
-C                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
-C                            CANCE BY ARGUMENT REDUCTION
-C                    IERR=5, ERROR              - NO COMPUTATION,
-C                            ALGORITHM TERMINATION CONDITION NOT MET
-C
-C***LONG DESCRIPTION
-C
-C         THE COMPUTATION IS CARRIED OUT BY THE POWER SERIES FOR
-C         SMALL CABS(Z), THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z),
-C         THE MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN AND A
-C         NEUMANN SERIES FOR IMTERMEDIATE MAGNITUDES, AND THE
-C         UNIFORM ASYMPTOTIC EXPANSIONS FOR I(FNU,Z) AND J(FNU,Z)
-C         FOR LARGE ORDERS. BACKWARD RECURRENCE IS USED TO GENERATE
-C         SEQUENCES OR REDUCE ORDERS WHEN NECESSARY.
-C
-C         THE CALCULATIONS ABOVE ARE DONE IN THE RIGHT HALF PLANE AND
-C         CONTINUED INTO THE LEFT HALF PLANE BY THE FORMULA
-C
-C         I(FNU,Z*EXP(M*PI)) = EXP(M*PI*FNU)*I(FNU,Z)  REAL(Z).GT.0.0
-C                       M = +I OR -I,  I**2=-1
-C
-C         FOR NEGATIVE ORDERS,THE FORMULA
-C
-C              I(-FNU,Z) = I(FNU,Z) + (2/PI)*SIN(PI*FNU)*K(FNU,Z)
-C
-C         CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE
-C         THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE
-C         INTEGER,THE MAGNITUDE OF I(-FNU,Z)=I(FNU,Z) IS A LARGE
-C         NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER,
-C         K(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF
-C         TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY
-C         UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN
-C         OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE,
-C         LARGE MEANS FNU.GT.CABS(Z).
-C
-C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
-C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
-C         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
-C         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
-C         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
-C         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
-C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
-C         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
-C         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
-C         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
-C         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
-C         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
-C         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
-C         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
-C         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
-C         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
-C         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
-C         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
-C         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
-C
-C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
-C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
-C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
-C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
-C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
-C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
-C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
-C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
-C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
-C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
-C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
-C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
-C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
-C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
-C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
-C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
-C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
-C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
-C         OR -PI/2+P.
-C
-C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
-C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
-C                 COMMERCE, 1955.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
-C
-C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
-C                 1018, MAY, 1985
-C
-C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
-C                 MATH. SOFTWARE, 1986
-C
-C***ROUTINES CALLED  ZBINU,I1MACH,D1MACH
-C***END PROLOGUE  ZBESI
-C     COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN
-      DOUBLE PRECISION AA, ALIM, ARG, CONEI, CONER, CSGNI, CSGNR, CYI,
-     * CYR, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR,
-     * ZR, D1MACH, AZ, BB, FN, ZABS, ASCLE, RTOL, ATOL, STI
-      INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN, I1MACH
-      DIMENSION CYR(N), CYI(N)
-      DATA PI /3.14159265358979324D0/
-      DATA CONER, CONEI /1.0D0,0.0D0/
-C
-C***FIRST EXECUTABLE STATEMENT  ZBESI
-      IERR = 0
-      NZ=0
-      IF (FNU.LT.0.0D0) IERR=1
-      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
-      IF (N.LT.1) IERR=1
-      IF (IERR.NE.0) RETURN
-C-----------------------------------------------------------------------
-C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
-C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
-C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
-C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
-C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
-C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
-C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
-C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
-C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
-C-----------------------------------------------------------------------
-      TOL = DMAX1(D1MACH(4),1.0D-18)
-      K1 = I1MACH(15)
-      K2 = I1MACH(16)
-      R1M5 = D1MACH(5)
-      K = MIN0(IABS(K1),IABS(K2))
-      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
-      K1 = I1MACH(14) - 1
-      AA = R1M5*DBLE(FLOAT(K1))
-      DIG = DMIN1(AA,18.0D0)
-      AA = AA*2.303D0
-      ALIM = ELIM + DMAX1(-AA,-41.45D0)
-      RL = 1.2D0*DIG + 3.0D0
-      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
-C-----------------------------------------------------------------------------
-C     TEST FOR PROPER RANGE
-C-----------------------------------------------------------------------
-      AZ = ZABS(COMPLEX(ZR,ZI))
-      FN = FNU+DBLE(FLOAT(N-1))
-      AA = 0.5D0/TOL
-      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
-      AA = DMIN1(AA,BB)
-      IF (AZ.GT.AA) GO TO 260
-      IF (FN.GT.AA) GO TO 260
-      AA = DSQRT(AA)
-      IF (AZ.GT.AA) IERR=3
-      IF (FN.GT.AA) IERR=3
-      ZNR = ZR
-      ZNI = ZI
-      CSGNR = CONER
-      CSGNI = CONEI
-      IF (ZR.GE.0.0D0) GO TO 40
-      ZNR = -ZR
-      ZNI = -ZI
-C-----------------------------------------------------------------------
-C     CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
-C     WHEN FNU IS LARGE
-C-----------------------------------------------------------------------
-      INU = INT(SNGL(FNU))
-      ARG = (FNU-DBLE(FLOAT(INU)))*PI
-      IF (ZI.LT.0.0D0) ARG = -ARG
-      CSGNR = DCOS(ARG)
-      CSGNI = DSIN(ARG)
-      IF (MOD(INU,2).EQ.0) GO TO 40
-      CSGNR = -CSGNR
-      CSGNI = -CSGNI
-   40 CONTINUE
-      CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL,
-     * ELIM, ALIM)
-      IF (NZ.LT.0) GO TO 120
-      IF (ZR.GE.0.0D0) RETURN
-C-----------------------------------------------------------------------
-C     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE
-C-----------------------------------------------------------------------
-      NN = N - NZ
-      IF (NN.EQ.0) RETURN
-      RTOL = 1.0D0/TOL
-      ASCLE = D1MACH(1)*RTOL*1.0D+3
-      DO 50 I=1,NN
-C       STR = CYR(I)*CSGNR - CYI(I)*CSGNI
-C       CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR
-C       CYR(I) = STR
-        AA = CYR(I)
-        BB = CYI(I)
-        ATOL = 1.0D0
-        IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55
-          AA = AA*RTOL
-          BB = BB*RTOL
-          ATOL = TOL
-   55   CONTINUE
-        STR = AA*CSGNR - BB*CSGNI
-        STI = AA*CSGNI + BB*CSGNR
-        CYR(I) = STR*ATOL
-        CYI(I) = STI*ATOL
-        CSGNR = -CSGNR
-        CSGNI = -CSGNI
-   50 CONTINUE
-      RETURN
-  120 CONTINUE
-      IF(NZ.EQ.(-2)) GO TO 130
-      NZ = 0
-      IERR=2
-      RETURN
-  130 CONTINUE
-      NZ=0
-      IERR=5
-      RETURN
-  260 CONTINUE
-      NZ=0
-      IERR=4
-      RETURN
-      END

amos/zbesj.f

@@ -1,266 +0,0 @@
-      SUBROUTINE ZBESJ(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
-C***BEGIN PROLOGUE  ZBESJ
-C***DATE WRITTEN   830501   (YYMMDD)
-C***REVISION DATE  890801   (YYMMDD)
-C***CATEGORY NO.  B5K
-C***KEYWORDS  J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT,
-C             BESSEL FUNCTION OF FIRST KIND
-C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
-C***PURPOSE  TO COMPUTE THE J-BESSEL FUNCTION OF A COMPLEX ARGUMENT
-C***DESCRIPTION
-C
-C                      ***A DOUBLE PRECISION ROUTINE***
-C         ON KODE=1, CBESJ COMPUTES AN N MEMBER  SEQUENCE OF COMPLEX
-C         BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE
-C         ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE
-C         -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESJ RETURNS THE SCALED
-C         FUNCTIONS
-C
-C         CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z)   I = 1,...,N , Y=AIMAG(Z)
-C
-C         WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND
-C         LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
-C         ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
-C         (REF. 1).
-C
-C         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION
-C           ZR,ZI  - Z=CMPLX(ZR,ZI),  -PI.LT.ARG(Z).LE.PI
-C           FNU    - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0
-C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
-C                    KODE= 1  RETURNS
-C                             CY(I)=J(FNU+I-1,Z), I=1,...,N
-C                        = 2  RETURNS
-C                             CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)), I=1,...,N
-C           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
-C
-C         OUTPUT     CYR,CYI ARE DOUBLE PRECISION
-C           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
-C                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
-C                    CY(I)=J(FNU+I-1,Z)  OR
-C                    CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y))  I=1,...,N
-C                    DEPENDING ON KODE, Y=AIMAG(Z).
-C           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
-C                    NZ= 0   , NORMAL RETURN
-C                    NZ.GT.0 , LAST NZ COMPONENTS OF CY SET  ZERO DUE
-C                              TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0),
-C                              I = N-NZ+1,...,N
-C           IERR   - ERROR FLAG
-C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
-C                    IERR=1, INPUT ERROR   - NO COMPUTATION
-C                    IERR=2, OVERFLOW      - NO COMPUTATION, AIMAG(Z)
-C                            TOO LARGE ON KODE=1
-C                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
-C                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
-C                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE
-C                            ACCURACY
-C                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
-C                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
-C                            CANCE BY ARGUMENT REDUCTION
-C                    IERR=5, ERROR              - NO COMPUTATION,
-C                            ALGORITHM TERMINATION CONDITION NOT MET
-C
-C***LONG DESCRIPTION
-C
-C         THE COMPUTATION IS CARRIED OUT BY THE FORMULA
-C
-C         J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z)    AIMAG(Z).GE.0.0
-C
-C         J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z)    AIMAG(Z).LT.0.0
-C
-C         WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION.
-C
-C         FOR NEGATIVE ORDERS,THE FORMULA
-C
-C              J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU)
-C
-C         CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE
-C         THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE
-C         INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A
-C         LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER,
-C         Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF
-C         TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY
-C         UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN
-C         OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE,
-C         LARGE MEANS FNU.GT.CABS(Z).
-C
-C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
-C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
-C         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
-C         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
-C         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
-C         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
-C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
-C         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
-C         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
-C         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
-C         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
-C         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
-C         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
-C         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
-C         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
-C         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
-C         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
-C         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
-C         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
-C
-C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
-C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
-C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
-C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
-C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
-C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
-C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
-C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
-C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
-C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
-C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
-C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
-C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
-C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
-C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
-C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
-C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
-C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
-C         OR -PI/2+P.
-C
-C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
-C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
-C                 COMMERCE, 1955.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
-C
-C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
-C                 1018, MAY, 1985
-C
-C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
-C                 MATH. SOFTWARE, 1986
-C
-C***ROUTINES CALLED  ZBINU,I1MACH,D1MACH
-C***END PROLOGUE  ZBESJ
-C
-C     COMPLEX CI,CSGN,CY,Z,ZN
-      DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG,
-     * ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR,
-     * D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI
-      INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH
-      DIMENSION CYR(N), CYI(N)
-      DATA HPI /1.57079632679489662D0/
-C
-C***FIRST EXECUTABLE STATEMENT  ZBESJ
-      IERR = 0
-      NZ=0
-      IF (FNU.LT.0.0D0) IERR=1
-      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
-      IF (N.LT.1) IERR=1
-      IF (IERR.NE.0) RETURN
-C-----------------------------------------------------------------------
-C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
-C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
-C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
-C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
-C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
-C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
-C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
-C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
-C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
-C-----------------------------------------------------------------------
-      TOL = DMAX1(D1MACH(4),1.0D-18)
-      K1 = I1MACH(15)
-      K2 = I1MACH(16)
-      R1M5 = D1MACH(5)
-      K = MIN0(IABS(K1),IABS(K2))
-      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
-      K1 = I1MACH(14) - 1
-      AA = R1M5*DBLE(FLOAT(K1))
-      DIG = DMIN1(AA,18.0D0)
-      AA = AA*2.303D0
-      ALIM = ELIM + DMAX1(-AA,-41.45D0)
-      RL = 1.2D0*DIG + 3.0D0
-      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
-C-----------------------------------------------------------------------
-C     TEST FOR PROPER RANGE
-C-----------------------------------------------------------------------
-      AZ = ZABS(COMPLEX(ZR,ZI))
-      FN = FNU+DBLE(FLOAT(N-1))
-      AA = 0.5D0/TOL
-      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
-      AA = DMIN1(AA,BB)
-      IF (AZ.GT.AA) GO TO 260
-      IF (FN.GT.AA) GO TO 260
-      AA = DSQRT(AA)
-      IF (AZ.GT.AA) IERR=3
-      IF (FN.GT.AA) IERR=3
-C-----------------------------------------------------------------------
-C     CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
-C     WHEN FNU IS LARGE
-C-----------------------------------------------------------------------
-      CII = 1.0D0
-      INU = INT(SNGL(FNU))
-      INUH = INU/2
-      IR = INU - 2*INUH
-      ARG = (FNU-DBLE(FLOAT(INU-IR)))*HPI
-      CSGNR = DCOS(ARG)
-      CSGNI = DSIN(ARG)
-      IF (MOD(INUH,2).EQ.0) GO TO 40
-      CSGNR = -CSGNR
-      CSGNI = -CSGNI
-   40 CONTINUE
-C-----------------------------------------------------------------------
-C     ZN IS IN THE RIGHT HALF PLANE
-C-----------------------------------------------------------------------
-      ZNR = ZI
-      ZNI = -ZR
-      IF (ZI.GE.0.0D0) GO TO 50
-      ZNR = -ZNR
-      ZNI = -ZNI
-      CSGNI = -CSGNI
-      CII = -CII
-   50 CONTINUE
-      CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL,
-     * ELIM, ALIM)
-      IF (NZ.LT.0) GO TO 130
-      NL = N - NZ
-      IF (NL.EQ.0) RETURN
-      RTOL = 1.0D0/TOL
-      ASCLE = D1MACH(1)*RTOL*1.0D+3
-      DO 60 I=1,NL
-C       STR = CYR(I)*CSGNR - CYI(I)*CSGNI
-C       CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR
-C       CYR(I) = STR
-        AA = CYR(I)
-        BB = CYI(I)
-        ATOL = 1.0D0
-        IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55
-          AA = AA*RTOL
-          BB = BB*RTOL
-          ATOL = TOL
-   55   CONTINUE
-        STR = AA*CSGNR - BB*CSGNI
-        STI = AA*CSGNI + BB*CSGNR
-        CYR(I) = STR*ATOL
-        CYI(I) = STI*ATOL
-        STR = -CSGNI*CII
-        CSGNI = CSGNR*CII
-        CSGNR = STR
-   60 CONTINUE
-      RETURN
-  130 CONTINUE
-      IF(NZ.EQ.(-2)) GO TO 140
-      NZ = 0
-      IERR = 2
-      RETURN
-  140 CONTINUE
-      NZ=0
-      IERR=5
-      RETURN
-  260 CONTINUE
-      NZ=0
-      IERR=4
-      RETURN
-      END

amos/zbesk.f

@@ -1,281 +0,0 @@
-      SUBROUTINE ZBESK(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
-C***BEGIN PROLOGUE  ZBESK
-C***DATE WRITTEN   830501   (YYMMDD)
-C***REVISION DATE  890801   (YYMMDD)
-C***CATEGORY NO.  B5K
-C***KEYWORDS  K-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION,
-C             MODIFIED BESSEL FUNCTION OF THE SECOND KIND,
-C             BESSEL FUNCTION OF THE THIRD KIND
-C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
-C***PURPOSE  TO COMPUTE K-BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C***DESCRIPTION
-C
-C                      ***A DOUBLE PRECISION ROUTINE***
-C
-C         ON KODE=1, CBESK COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
-C         BESSEL FUNCTIONS CY(J)=K(FNU+J-1,Z) FOR REAL, NONNEGATIVE
-C         ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z.NE.CMPLX(0.0,0.0)
-C         IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESK
-C         RETURNS THE SCALED K FUNCTIONS,
-C
-C         CY(J)=EXP(Z)*K(FNU+J-1,Z) , J=1,...,N,
-C
-C         WHICH REMOVE THE EXPONENTIAL BEHAVIOR IN BOTH THE LEFT AND
-C         RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND
-C         NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL
-C         FUNCTIONS (REF. 1).
-C
-C         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION
-C           ZR,ZI  - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
-C                    -PI.LT.ARG(Z).LE.PI
-C           FNU    - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0D0
-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                             CY(I)=K(FNU+I-1,Z), I=1,...,N
-C                        = 2  RETURNS
-C                             CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N
-C
-C         OUTPUT     CYR,CYI ARE DOUBLE PRECISION
-C           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
-C                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
-C                    CY(I)=K(FNU+I-1,Z), I=1,...,N OR
-C                    CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N
-C                    DEPENDING ON KODE
-C           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW.
-C                    NZ= 0   , NORMAL RETURN
-C                    NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE
-C                              TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0),
-C                              I=1,...,N WHEN X.GE.0.0. WHEN X.LT.0.0
-C                              NZ STATES ONLY THE NUMBER OF UNDERFLOWS
-C                              IN THE SEQUENCE.
-C
-C           IERR   - ERROR FLAG
-C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
-C                    IERR=1, INPUT ERROR   - NO COMPUTATION
-C                    IERR=2, OVERFLOW      - NO COMPUTATION, FNU IS
-C                            TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH
-C                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
-C                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
-C                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE
-C                            ACCURACY
-C                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
-C                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
-C                            CANCE BY ARGUMENT REDUCTION
-C                    IERR=5, ERROR              - NO COMPUTATION,
-C                            ALGORITHM TERMINATION CONDITION NOT MET
-C
-C***LONG DESCRIPTION
-C
-C         EQUATIONS OF THE REFERENCE ARE IMPLEMENTED FOR SMALL ORDERS
-C         DNU AND DNU+1.0 IN THE RIGHT HALF PLANE X.GE.0.0. FORWARD
-C         RECURRENCE GENERATES HIGHER ORDERS. K IS CONTINUED TO THE LEFT
-C         HALF PLANE BY THE RELATION
-C
-C         K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)
-C         MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1
-C
-C         WHERE I(FNU,Z) IS THE I BESSEL FUNCTION.
-C
-C         FOR LARGE ORDERS, FNU.GT.FNUL, THE K FUNCTION IS COMPUTED
-C         BY MEANS OF ITS UNIFORM ASYMPTOTIC EXPANSIONS.
-C
-C         FOR NEGATIVE ORDERS, THE FORMULA
-C
-C                       K(-FNU,Z) = K(FNU,Z)
-C
-C         CAN BE USED.
-C
-C         CBESK ASSUMES THAT A SIGNIFICANT DIGIT SINH(X) FUNCTION IS
-C         AVAILABLE.
-C
-C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
-C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
-C         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
-C         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
-C         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
-C         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
-C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
-C         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
-C         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
-C         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
-C         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
-C         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
-C         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
-C         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
-C         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
-C         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
-C         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
-C         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
-C         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
-C
-C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
-C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
-C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
-C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
-C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
-C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
-C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
-C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
-C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
-C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
-C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
-C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
-C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
-C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
-C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
-C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
-C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
-C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
-C         OR -PI/2+P.
-C
-C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
-C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
-C                 COMMERCE, 1955.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983.
-C
-C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
-C                 1018, MAY, 1985
-C
-C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
-C                 MATH. SOFTWARE, 1986
-C
-C***ROUTINES CALLED  ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH
-C***END PROLOGUE  ZBESK
-C
-C     COMPLEX CY,Z
-      DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, FN,
-     * FNU, FNUL, RL, R1M5, TOL, UFL, ZI, ZR, D1MACH, ZABS, BB
-      INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH
-      DIMENSION CYR(N), CYI(N)
-C***FIRST EXECUTABLE STATEMENT  ZBESK
-      IERR = 0
-      NZ=0
-      IF (ZI.EQ.0.0E0 .AND. ZR.EQ.0.0E0) IERR=1
-      IF (FNU.LT.0.0D0) IERR=1
-      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
-      IF (N.LT.1) IERR=1
-      IF (IERR.NE.0) RETURN
-      NN = N
-C-----------------------------------------------------------------------
-C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
-C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
-C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
-C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
-C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
-C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
-C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
-C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
-C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
-C-----------------------------------------------------------------------
-      TOL = DMAX1(D1MACH(4),1.0D-18)
-      K1 = I1MACH(15)
-      K2 = I1MACH(16)
-      R1M5 = D1MACH(5)
-      K = MIN0(IABS(K1),IABS(K2))
-      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
-      K1 = I1MACH(14) - 1
-      AA = R1M5*DBLE(FLOAT(K1))
-      DIG = DMIN1(AA,18.0D0)
-      AA = AA*2.303D0
-      ALIM = ELIM + DMAX1(-AA,-41.45D0)
-      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
-      RL = 1.2D0*DIG + 3.0D0
-C-----------------------------------------------------------------------------
-C     TEST FOR PROPER RANGE
-C-----------------------------------------------------------------------
-      AZ = ZABS(COMPLEX(ZR,ZI))
-      FN = FNU + DBLE(FLOAT(NN-1))
-      AA = 0.5D0/TOL
-      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
-      AA = DMIN1(AA,BB)
-      IF (AZ.GT.AA) GO TO 260
-      IF (FN.GT.AA) GO TO 260
-      AA = DSQRT(AA)
-      IF (AZ.GT.AA) IERR=3
-      IF (FN.GT.AA) IERR=3
-C-----------------------------------------------------------------------
-C     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
-C-----------------------------------------------------------------------
-C     UFL = DEXP(-ELIM)
-      UFL = D1MACH(1)*1.0D+3
-      IF (AZ.LT.UFL) GO TO 180
-      IF (FNU.GT.FNUL) GO TO 80
-      IF (FN.LE.1.0D0) GO TO 60
-      IF (FN.GT.2.0D0) GO TO 50
-      IF (AZ.GT.TOL) GO TO 60
-      ARG = 0.5D0*AZ
-      ALN = -FN*DLOG(ARG)
-      IF (ALN.GT.ELIM) GO TO 180
-      GO TO 60
-   50 CONTINUE
-      CALL ZUOIK(ZR, ZI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM,
-     * ALIM)
-      IF (NUF.LT.0) GO TO 180
-      NZ = NZ + NUF
-      NN = NN - NUF
-C-----------------------------------------------------------------------
-C     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
-C     IF NUF=NN, THEN CY(I)=CZERO FOR ALL I
-C-----------------------------------------------------------------------
-      IF (NN.EQ.0) GO TO 100
-   60 CONTINUE
-      IF (ZR.LT.0.0D0) GO TO 70
-C-----------------------------------------------------------------------
-C     RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0.
-C-----------------------------------------------------------------------
-      CALL ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
-      IF (NW.LT.0) GO TO 200
-      NZ=NW
-      RETURN
-C-----------------------------------------------------------------------
-C     LEFT HALF PLANE COMPUTATION
-C     PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2.
-C-----------------------------------------------------------------------
-   70 CONTINUE
-      IF (NZ.NE.0) GO TO 180
-      MR = 1
-      IF (ZI.LT.0.0D0) MR = -1
-      CALL ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL,
-     * TOL, ELIM, ALIM)
-      IF (NW.LT.0) GO TO 200
-      NZ=NW
-      RETURN
-C-----------------------------------------------------------------------
-C     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL
-C-----------------------------------------------------------------------
-   80 CONTINUE
-      MR = 0
-      IF (ZR.GE.0.0D0) GO TO 90
-      MR = 1
-      IF (ZI.LT.0.0D0) MR = -1
-   90 CONTINUE
-      CALL ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM,
-     * ALIM)
-      IF (NW.LT.0) GO TO 200
-      NZ = NZ + NW
-      RETURN
-  100 CONTINUE
-      IF (ZR.LT.0.0D0) GO TO 180
-      RETURN
-  180 CONTINUE
-      NZ = 0
-      IERR=2
-      RETURN
-  200 CONTINUE
-      IF(NW.EQ.(-1)) GO TO 180
-      NZ=0
-      IERR=5
-      RETURN
-  260 CONTINUE
-      NZ=0
-      IERR=4
-      RETURN
-      END

amos/zbesy.f

@@ -1,244 +0,0 @@
-      SUBROUTINE ZBESY(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, CWRKI,
-     *                 IERR)
-C***BEGIN PROLOGUE  ZBESY
-C***DATE WRITTEN   830501   (YYMMDD)
-C***REVISION DATE  890801   (YYMMDD)
-C***CATEGORY NO.  B5K
-C***KEYWORDS  Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT,
-C             BESSEL FUNCTION OF SECOND KIND
-C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
-C***PURPOSE  TO COMPUTE THE Y-BESSEL FUNCTION OF A COMPLEX ARGUMENT
-C***DESCRIPTION
-C
-C                      ***A DOUBLE PRECISION ROUTINE***
-C
-C         ON KODE=1, CBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
-C         BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE
-C         ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE
-C         -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESY RETURNS THE SCALED
-C         FUNCTIONS
-C
-C         CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z)   I = 1,...,N , Y=AIMAG(Z)
-C
-C         WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND
-C         LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
-C         ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
-C         (REF. 1).
-C
-C         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION
-C           ZR,ZI  - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
-C                    -PI.LT.ARG(Z).LE.PI
-C           FNU    - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0
-C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
-C                    KODE= 1  RETURNS
-C                             CY(I)=Y(FNU+I-1,Z), I=1,...,N
-C                        = 2  RETURNS
-C                             CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N
-C                             WHERE Y=AIMAG(Z)
-C           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
-C           CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT
-C           CWRKI    AT LEAST N
-C
-C         OUTPUT     CYR,CYI ARE DOUBLE PRECISION
-C           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
-C                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
-C                    CY(I)=Y(FNU+I-1,Z)  OR
-C                    CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y))  I=1,...,N
-C                    DEPENDING ON KODE.
-C           NZ     - NZ=0 , A NORMAL RETURN
-C                    NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO
-C                    UNDERFLOW (GENERALLY ON KODE=2)
-C           IERR   - ERROR FLAG
-C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
-C                    IERR=1, INPUT ERROR   - NO COMPUTATION
-C                    IERR=2, OVERFLOW      - NO COMPUTATION, FNU IS
-C                            TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH
-C                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
-C                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
-C                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE
-C                            ACCURACY
-C                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
-C                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
-C                            CANCE BY ARGUMENT REDUCTION
-C                    IERR=5, ERROR              - NO COMPUTATION,
-C                            ALGORITHM TERMINATION CONDITION NOT MET
-C
-C***LONG DESCRIPTION
-C
-C         THE COMPUTATION IS CARRIED OUT BY THE FORMULA
-C
-C         Y(FNU,Z)=0.5*(H(1,FNU,Z)-H(2,FNU,Z))/I
-C
-C         WHERE I**2 = -1 AND THE HANKEL BESSEL FUNCTIONS H(1,FNU,Z)
-C         AND H(2,FNU,Z) ARE CALCULATED IN CBESH.
-C
-C         FOR NEGATIVE ORDERS,THE FORMULA
-C
-C              Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU)
-C
-C         CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD
-C         INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE
-C         POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)*
-C         SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS
-C         NOT A HALF ODD INTEGER, Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A
-C         LARGE POSITIVE POWER OF TEN AND THE MOST THAT THE SECOND TERM
-C         CAN BE REDUCED IS BY UNIT ROUNDOFF FROM THE COEFFICIENT. THUS,
-C         WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF
-C         ODD INTEGER. HERE, LARGE MEANS FNU.GT.CABS(Z).
-C
-C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
-C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
-C         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
-C         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
-C         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
-C         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
-C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
-C         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
-C         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
-C         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
-C         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
-C         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
-C         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
-C         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
-C         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
-C         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
-C         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
-C         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
-C         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
-C
-C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
-C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
-C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
-C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
-C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
-C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
-C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
-C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
-C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
-C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
-C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
-C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
-C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
-C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
-C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
-C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
-C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
-C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
-C         OR -PI/2+P.
-C
-C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
-C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
-C                 COMMERCE, 1955.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
-C
-C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
-C                 1018, MAY, 1985
-C
-C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
-C                 MATH. SOFTWARE, 1986
-C
-C***ROUTINES CALLED  ZBESH,I1MACH,D1MACH
-C***END PROLOGUE  ZBESY
-C
-C     COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV
-      DOUBLE PRECISION CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2R,
-     * ELIM, EXI, EXR, EY, FNU, HCII, STI, STR, TAY, ZI, ZR, DEXP,
-     * D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL
-      INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH
-      DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N)
-C***FIRST EXECUTABLE STATEMENT  ZBESY
-      IERR = 0
-      NZ=0
-      IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1
-      IF (FNU.LT.0.0D0) IERR=1
-      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
-      IF (N.LT.1) IERR=1
-      IF (IERR.NE.0) RETURN
-      HCII = 0.5D0
-      CALL ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR)
-      IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
-      CALL ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR)
-      IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
-      NZ = MIN0(NZ1,NZ2)
-      IF (KODE.EQ.2) GO TO 60
-      DO 50 I=1,N
-        STR = CWRKR(I) - CYR(I)
-        STI = CWRKI(I) - CYI(I)
-        CYR(I) = -STI*HCII
-        CYI(I) = STR*HCII
-   50 CONTINUE
-      RETURN
-   60 CONTINUE
-      TOL = DMAX1(D1MACH(4),1.0D-18)
-      K1 = I1MACH(15)
-      K2 = I1MACH(16)
-      K = MIN0(IABS(K1),IABS(K2))
-      R1M5 = D1MACH(5)
-C-----------------------------------------------------------------------
-C     ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT
-C-----------------------------------------------------------------------
-      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
-      EXR = DCOS(ZR)
-      EXI = DSIN(ZR)
-      EY = 0.0D0
-      TAY = DABS(ZI+ZI)
-      IF (TAY.LT.ELIM) EY = DEXP(-TAY)
-      IF (ZI.LT.0.0D0) GO TO 90
-      C1R = EXR*EY
-      C1I = EXI*EY
-      C2R = EXR
-      C2I = -EXI
-   70 CONTINUE
-      NZ = 0
-      RTOL = 1.0D0/TOL
-      ASCLE = D1MACH(1)*RTOL*1.0D+3
-      DO 80 I=1,N
-C       STR = C1R*CYR(I) - C1I*CYI(I)
-C       STI = C1R*CYI(I) + C1I*CYR(I)
-C       STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I)
-C       STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I)
-C       CYR(I) = -STI*HCII
-C       CYI(I) = STR*HCII
-        AA = CWRKR(I)
-        BB = CWRKI(I)
-        ATOL = 1.0D0
-        IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 75
-          AA = AA*RTOL
-          BB = BB*RTOL
-          ATOL = TOL
-   75   CONTINUE
-        STR = (AA*C2R - BB*C2I)*ATOL
-        STI = (AA*C2I + BB*C2R)*ATOL
-        AA = CYR(I)
-        BB = CYI(I)
-        ATOL = 1.0D0
-        IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 85
-          AA = AA*RTOL
-          BB = BB*RTOL
-          ATOL = TOL
-   85   CONTINUE
-        STR = STR - (AA*C1R - BB*C1I)*ATOL
-        STI = STI - (AA*C1I + BB*C1R)*ATOL
-        CYR(I) = -STI*HCII
-        CYI(I) =  STR*HCII
-        IF (STR.EQ.0.0D0 .AND. STI.EQ.0.0D0 .AND. EY.EQ.0.0D0) NZ = NZ
-     *   + 1
-   80 CONTINUE
-      RETURN
-   90 CONTINUE
-      C1R = EXR
-      C1I = EXI
-      C2R = EXR*EY
-      C2I = -EXI*EY
-      GO TO 70
-  170 CONTINUE
-      NZ = 0
-      RETURN
-      END

amos/zbiry.f

@@ -1,364 +0,0 @@
-      SUBROUTINE ZBIRY(ZR, ZI, ID, KODE, BIR, BII, IERR)
-C***BEGIN PROLOGUE  ZBIRY
-C***DATE WRITTEN   830501   (YYMMDD)
-C***REVISION DATE  890801   (YYMMDD)
-C***CATEGORY NO.  B5K
-C***KEYWORDS  AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD
-C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
-C***PURPOSE  TO COMPUTE AIRY FUNCTIONS BI(Z) AND DBI(Z) FOR COMPLEX Z
-C***DESCRIPTION
-C
-C                      ***A DOUBLE PRECISION ROUTINE***
-C         ON KODE=1, CBIRY COMPUTES THE COMPLEX AIRY FUNCTION BI(Z) OR
-C         ITS DERIVATIVE DBI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON
-C         KODE=2, A SCALING OPTION CEXP(-AXZTA)*BI(Z) OR CEXP(-AXZTA)*
-C         DBI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL BEHAVIOR IN
-C         BOTH THE LEFT AND RIGHT HALF PLANES WHERE
-C         ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA).
-C         DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF
-C         MATHEMATICAL FUNCTIONS (REF. 1).
-C
-C         INPUT      ZR,ZI ARE DOUBLE PRECISION
-C           ZR,ZI  - Z=CMPLX(ZR,ZI)
-C           ID     - ORDER OF DERIVATIVE, ID=0 OR ID=1
-C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
-C                    KODE= 1  RETURNS
-C                             BI=BI(Z)                 ON ID=0 OR
-C                             BI=DBI(Z)/DZ             ON ID=1
-C                        = 2  RETURNS
-C                             BI=CEXP(-AXZTA)*BI(Z)     ON ID=0 OR
-C                             BI=CEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE
-C                             ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA)
-C                             AND AXZTA=ABS(XZTA)
-C
-C         OUTPUT     BIR,BII ARE DOUBLE PRECISION
-C           BIR,BII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND
-C                    KODE
-C           IERR   - ERROR FLAG
-C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
-C                    IERR=1, INPUT ERROR   - NO COMPUTATION
-C                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(Z)
-C                            TOO LARGE ON KODE=1
-C                    IERR=3, CABS(Z) LARGE      - COMPUTATION COMPLETED
-C                            LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION
-C                            PRODUCE LESS THAN HALF OF MACHINE ACCURACY
-C                    IERR=4, CABS(Z) TOO LARGE  - NO COMPUTATION
-C                            COMPLETE LOSS OF ACCURACY BY ARGUMENT
-C                            REDUCTION
-C                    IERR=5, ERROR              - NO COMPUTATION,
-C                            ALGORITHM TERMINATION CONDITION NOT MET
-C
-C***LONG DESCRIPTION
-C
-C         BI AND DBI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE I BESSEL
-C         FUNCTIONS BY
-C
-C                BI(Z)=C*SQRT(Z)*( I(-1/3,ZTA) + I(1/3,ZTA) )
-C               DBI(Z)=C *  Z  * ( I(-2/3,ZTA) + I(2/3,ZTA) )
-C                               C=1.0/SQRT(3.0)
-C                             ZTA=(2/3)*Z**(3/2)
-C
-C         WITH THE POWER SERIES FOR CABS(Z).LE.1.0.
-C
-C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
-C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES
-C         OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF
-C         THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR),
-C         THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR
-C         FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
-C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
-C         ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN
-C         ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT
-C         FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE
-C         LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA
-C         MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,
-C         AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE
-C         PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE
-C         PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-
-C         ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-
-C         NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN
-C         DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN
-C         EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES,
-C         NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE
-C         PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER
-C         MACHINES.
-C
-C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
-C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
-C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
-C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
-C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
-C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
-C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
-C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
-C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
-C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
-C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
-C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
-C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
-C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
-C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
-C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
-C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
-C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
-C         OR -PI/2+P.
-C
-C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
-C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
-C                 COMMERCE, 1955.
-C
-C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
-C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
-C
-C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
-C                 1018, MAY, 1985
-C
-C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
-C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
-C                 MATH. SOFTWARE, 1986
-C
-C***ROUTINES CALLED  ZBINU,ZABS,ZDIV,ZSQRT,D1MACH,I1MACH
-C***END PROLOGUE  ZBIRY
-C     COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3
-      DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR,
-     * BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2,
-     * DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5,
-     * SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I,
-     * TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS
-      INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH
-      DIMENSION CYR(2), CYI(2)
-      DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01,
-     * 6.14926627446000736D-01,4.48288357353826359D-01,
-     * 5.77350269189625765D-01,3.14159265358979324D+00/
-      DATA CONER, CONEI /1.0D0,0.0D0/
-C***FIRST EXECUTABLE STATEMENT  ZBIRY
-      IERR = 0
-      NZ=0
-      IF (ID.LT.0 .OR. ID.GT.1) IERR=1
-      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
-      IF (IERR.NE.0) RETURN
-      AZ = ZABS(COMPLEX(ZR,ZI))
-      TOL = DMAX1(D1MACH(4),1.0D-18)
-      FID = DBLE(FLOAT(ID))
-      IF (AZ.GT.1.0E0) GO TO 70
-C-----------------------------------------------------------------------
-C     POWER SERIES FOR CABS(Z).LE.1.
-C-----------------------------------------------------------------------
-      S1R = CONER
-      S1I = CONEI
-      S2R = CONER
-      S2I = CONEI
-      IF (AZ.LT.TOL) GO TO 130
-      AA = AZ*AZ
-      IF (AA.LT.TOL/AZ) GO TO 40
-      TRM1R = CONER
-      TRM1I = CONEI
-      TRM2R = CONER
-      TRM2I = CONEI
-      ATRM = 1.0D0
-      STR = ZR*ZR - ZI*ZI
-      STI = ZR*ZI + ZI*ZR
-      Z3R = STR*ZR - STI*ZI
-      Z3I = STR*ZI + STI*ZR
-      AZ3 = AZ*AA
-      AK = 2.0D0 + FID
-      BK = 3.0D0 - FID - FID
-      CK = 4.0D0 - FID
-      DK = 3.0D0 + FID + FID
-      D1 = AK*DK
-      D2 = BK*CK
-      AD = DMIN1(D1,D2)
-      AK = 24.0D0 + 9.0D0*FID
-      BK = 30.0D0 - 9.0D0*FID
-      DO 30 K=1,25
-        STR = (TRM1R*Z3R-TRM1I*Z3I)/D1
-        TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1
-        TRM1R = STR
-        S1R = S1R + TRM1R
-        S1I = S1I + TRM1I
-        STR = (TRM2R*Z3R-TRM2I*Z3I)/D2
-        TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2
-        TRM2R = STR
-        S2R = S2R + TRM2R
-        S2I = S2I + TRM2I
-        ATRM = ATRM*AZ3/AD
-        D1 = D1 + AK
-        D2 = D2 + BK
-        AD = DMIN1(D1,D2)
-        IF (ATRM.LT.TOL*AD) GO TO 40
-        AK = AK + 18.0D0
-        BK = BK + 18.0D0
-   30 CONTINUE
-   40 CONTINUE
-      IF (ID.EQ.1) GO TO 50
-      BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I)
-      BII = C1*S1I + C2*(ZR*S2I+ZI*S2R)
-      IF (KODE.EQ.1) RETURN
-      CALL ZSQRT(ZR, ZI, STR, STI)
-      ZTAR = TTH*(ZR*STR-ZI*STI)
-      ZTAI = TTH*(ZR*STI+ZI*STR)
-      AA = ZTAR
-      AA = -DABS(AA)
-      EAA = DEXP(AA)
-      BIR = BIR*EAA
-      BII = BII*EAA
-      RETURN
-   50 CONTINUE
-      BIR = S2R*C2
-      BII = S2I*C2
-      IF (AZ.LE.TOL) GO TO 60
-      CC = C1/(1.0D0+FID)
-      STR = S1R*ZR - S1I*ZI
-      STI = S1R*ZI + S1I*ZR
-      BIR = BIR + CC*(STR*ZR-STI*ZI)
-      BII = BII + CC*(STR*ZI+STI*ZR)
-   60 CONTINUE
-      IF (KODE.EQ.1) RETURN
-      CALL ZSQRT(ZR, ZI, STR, STI)
-      ZTAR = TTH*(ZR*STR-ZI*STI)
-      ZTAI = TTH*(ZR*STI+ZI*STR)
-      AA = ZTAR
-      AA = -DABS(AA)
-      EAA = DEXP(AA)
-      BIR = BIR*EAA
-      BII = BII*EAA
-      RETURN
-C-----------------------------------------------------------------------
-C     CASE FOR CABS(Z).GT.1.0
-C-----------------------------------------------------------------------
-   70 CONTINUE
-      FNU = (1.0D0+FID)/3.0D0
-C-----------------------------------------------------------------------
-C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
-C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
-C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
-C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
-C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
-C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
-C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
-C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
-C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
-C-----------------------------------------------------------------------
-      K1 = I1MACH(15)
-      K2 = I1MACH(16)
-      R1M5 = D1MACH(5)
-      K = MIN0(IABS(K1),IABS(K2))
-      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
-      K1 = I1MACH(14) - 1
-      AA = R1M5*DBLE(FLOAT(K1))
-      DIG = DMIN1(AA,18.0D0)
-      AA = AA*2.303D0
-      ALIM = ELIM + DMAX1(-AA,-41.45D0)
-      RL = 1.2D0*DIG + 3.0D0
-      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
-C-----------------------------------------------------------------------
-C     TEST FOR RANGE
-C-----------------------------------------------------------------------
-      AA=0.5D0/TOL
-      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
-      AA=DMIN1(AA,BB)
-      AA=AA**TTH
-      IF (AZ.GT.AA) GO TO 260
-      AA=DSQRT(AA)
-      IF (AZ.GT.AA) IERR=3
-      CALL ZSQRT(ZR, ZI, CSQR, CSQI)
-      ZTAR = TTH*(ZR*CSQR-ZI*CSQI)
-      ZTAI = TTH*(ZR*CSQI+ZI*CSQR)
-C-----------------------------------------------------------------------
-C     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
-C-----------------------------------------------------------------------
-      SFAC = 1.0D0
-      AK = ZTAI
-      IF (ZR.GE.0.0D0) GO TO 80
-      BK = ZTAR
-      CK = -DABS(BK)
-      ZTAR = CK
-      ZTAI = AK
-   80 CONTINUE
-      IF (ZI.NE.0.0D0 .OR. ZR.GT.0.0D0) GO TO 90
-      ZTAR = 0.0D0
-      ZTAI = AK
-   90 CONTINUE
-      AA = ZTAR
-      IF (KODE.EQ.2) GO TO 100
-C-----------------------------------------------------------------------
-C     OVERFLOW TEST
-C-----------------------------------------------------------------------
-      BB = DABS(AA)
-      IF (BB.LT.ALIM) GO TO 100
-      BB = BB + 0.25D0*DLOG(AZ)
-      SFAC = TOL
-      IF (BB.GT.ELIM) GO TO 190
-  100 CONTINUE
-      FMR = 0.0D0
-      IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110
-      FMR = PI
-      IF (ZI.LT.0.0D0) FMR = -PI
-      ZTAR = -ZTAR
-      ZTAI = -ZTAI
-  110 CONTINUE
-C-----------------------------------------------------------------------
-C     AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA)
-C     KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBESI
-C-----------------------------------------------------------------------
-      CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL,
-     * ELIM, ALIM)
-      IF (NZ.LT.0) GO TO 200
-      AA = FMR*FNU
-      Z3R = SFAC
-      STR = DCOS(AA)
-      STI = DSIN(AA)
-      S1R = (STR*CYR(1)-STI*CYI(1))*Z3R
-      S1I = (STR*CYI(1)+STI*CYR(1))*Z3R
-      FNU = (2.0D0-FID)/3.0D0
-      CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL,
-     * ELIM, ALIM)
-      CYR(1) = CYR(1)*Z3R
-      CYI(1) = CYI(1)*Z3R
-      CYR(2) = CYR(2)*Z3R
-      CYI(2) = CYI(2)*Z3R
-C-----------------------------------------------------------------------
-C     BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3
-C-----------------------------------------------------------------------
-      CALL ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI)
-      S2R = (FNU+FNU)*STR + CYR(2)
-      S2I = (FNU+FNU)*STI + CYI(2)
-      AA = FMR*(FNU-1.0D0)
-      STR = DCOS(AA)
-      STI = DSIN(AA)
-      S1R = COEF*(S1R+S2R*STR-S2I*STI)
-      S1I = COEF*(S1I+S2R*STI+S2I*STR)
-      IF (ID.EQ.1) GO TO 120
-      STR = CSQR*S1R - CSQI*S1I
-      S1I = CSQR*S1I + CSQI*S1R
-      S1R = STR
-      BIR = S1R/SFAC
-      BII = S1I/SFAC
-      RETURN
-  120 CONTINUE
-      STR = ZR*S1R - ZI*S1I
-      S1I = ZR*S1I + ZI*S1R
-      S1R = STR
-      BIR = S1R/SFAC
-      BII = S1I/SFAC
-      RETURN
-  130 CONTINUE
-      AA = C1*(1.0D0-FID) + FID*C2
-      BIR = AA
-      BII = 0.0D0
-      RETURN
-  190 CONTINUE
-      IERR=2
-      NZ=0
-      RETURN
-  200 CONTINUE
-      IF(NZ.EQ.(-1)) GO TO 190
-      NZ=0
-      IERR=5
-      RETURN
-  260 CONTINUE
-      IERR=4
-      NZ=0
-      RETURN
-      END

amos/zdiv.f

@@ -1,19 +0,0 @@
-      SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI)
-C***BEGIN PROLOGUE  ZDIV
-C***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
-C
-C     DOUBLE PRECISION COMPLEX DIVIDE C=A/B.
-C
-C***ROUTINES CALLED  ZABS
-C***END PROLOGUE  ZDIV
-      DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD
-      DOUBLE PRECISION ZABS
-      BM = 1.0D0/ZABS(COMPLEX(BR,BI))
-      CC = BR*BM
-      CD = BI*BM
-      CA = (AR*CC+AI*CD)*BM
-      CB = (AI*CC-AR*CD)*BM
-      CR = CA
-      CI = CB
-      RETURN
-      END

amos/zexp.f

@@ -1,16 +0,0 @@
-      SUBROUTINE ZEXP(AR, AI, BR, BI)
-C***BEGIN PROLOGUE  ZEXP
-C***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
-C
-C     DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A)
-C
-C***ROUTINES CALLED  (NONE)
-C***END PROLOGUE  ZEXP
-      DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB
-      ZM = DEXP(AR)
-      CA = ZM*DCOS(AI)
-      CB = ZM*DSIN(AI)
-      BR = CA
-      BI = CB
-      RETURN
-      END

amos/zmlt.f

@@ -1,15 +0,0 @@
-      SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI)
-C***BEGIN PROLOGUE  ZMLT
-C***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
-C
-C     DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B.
-C
-C***ROUTINES CALLED  (NONE)
-C***END PROLOGUE  ZMLT
-      DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB
-      CA = AR*BR - AI*BI
-      CB = AR*BI + AI*BR
-      CR = CA
-      CI = CB
-      RETURN
-      END

amos/zshch.f

@@ -1,22 +0,0 @@
-      SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI)
-C***BEGIN PROLOGUE  ZSHCH
-C***REFER TO  ZBESK,ZBESH
-C
-C     ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y)
-C     AND CCH=COSH(X+I*Y), WHERE I**2=-1.
-C
-C***ROUTINES CALLED  (NONE)
-C***END PROLOGUE  ZSHCH
-C
-      DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR,
-     * DCOSH, DSINH
-      SH = DSINH(ZR)
-      CH = DCOSH(ZR)
-      SN = DSIN(ZI)
-      CN = DCOS(ZI)
-      CSHR = SH*CN
-      CSHI = CH*SN
-      CCHR = CH*CN
-      CCHI = SH*SN
-      RETURN
-      END

amos/Make.files → slatec/Make.files

@@ -1,5 +1,6 @@
 $(CUR_SRCS) +=  d1mach.f zabs.f   zasyi.f  zbesk.f  zbknu.f  zexp.f   zmlt.f   zshch.f  zuni1.f  zunk2.f \
 	dgamln.f zacai.f  zbesh.f  zbesy.f  zbuni.f  zkscl.f  zrati.f  zsqrt.f  zuni2.f  zuoik.f \
 	i1mach.f zacon.f  zbesi.f  zbinu.f  zbunk.f  zlog.f   zs1s2.f  zuchk.f  zunik.f  zwrsk.f \
-	xerror.f zairy.f  zbesj.f  zbiry.f  zdiv.f   zmlri.f  zseri.f  zunhj.f  zunk1.f
+	xerror.f zairy.f  zbesj.f  zbiry.f  zdiv.f   zmlri.f  zseri.f  zunhj.f  zunk1.f \
+	xermsg.f fdump.f j4save.f xercnt.f xerhlt.f xerprn.f xersve.f xgetua.f
 

slatec/aaaaaa.f

@@ -0,0 +1,71 @@
+*DECK AAAAAA
+      SUBROUTINE AAAAAA (VER)
+C***BEGIN PROLOGUE  AAAAAA
+C***PURPOSE  SLATEC Common Mathematical Library disclaimer and version.
+C***LIBRARY   SLATEC
+C***CATEGORY  Z
+C***TYPE      ALL (AAAAAA-A)
+C***KEYWORDS  DISCLAIMER, DOCUMENTATION, VERSION
+C***AUTHOR  SLATEC Common Mathematical Library Committee
+C***DESCRIPTION
+C
+C   The SLATEC Common Mathematical Library is issued by the following
+C
+C           Air Force Weapons Laboratory, Albuquerque
+C           Lawrence Livermore National Laboratory, Livermore
+C           Los Alamos National Laboratory, Los Alamos
+C           National Institute of Standards and Technology, Washington
+C           National Energy Research Supercomputer Center, Livermore
+C           Oak Ridge National Laboratory, Oak Ridge
+C           Sandia National Laboratories, Albuquerque
+C           Sandia National Laboratories, Livermore
+C
+C   All questions concerning the distribution of the library should be
+C   directed to the NATIONAL ENERGY SOFTWARE CENTER, 9700 Cass Ave.,
+C   Argonne, Illinois  60439, and not to the authors of the subprograms.
+C
+C                    * * * * * Notice * * * * *
+C
+C   This material was prepared as an account of work sponsored by the
+C   United States Government.  Neither the United States, nor the
+C   Department of Energy, nor the Department of Defense, nor any of
+C   their employees, nor any of their contractors, subcontractors, or
+C   their employees, makes any warranty, expressed or implied, or
+C   assumes any legal liability or responsibility for the accuracy,
+C   completeness, or usefulness of any information, apparatus, product,
+C   or process disclosed, or represents that its use would not infringe
+C   upon privately owned rights.
+C
+C *Usage:
+C
+C        CHARACTER * 16 VER
+C
+C        CALL AAAAAA (VER)
+C
+C *Arguments:
+C
+C     VER:OUT   will contain the version number of the SLATEC CML.
+C
+C *Description:
+C
+C   This routine contains the SLATEC Common Mathematical Library
+C   disclaimer and can be used to return the library version number.
+C
+C***REFERENCES  Kirby W. Fong, Thomas H. Jefferson, Tokihiko Suyehiro
+C                 and Lee Walton, Guide to the SLATEC Common Mathema-
+C                 tical Library, April 10, 1990.
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   800424  DATE WRITTEN
+C   890414  REVISION DATE from Version 3.2
+C   890713  Routine modified to return version number.  (WRB)
+C   900330  Prologue converted to Version 4.0 format.  (BAB)
+C   920501  Reformatted the REFERENCES section.  (WRB)
+C   921215  Updated for Version 4.0.  (WRB)
+C   930701  Updated for Version 4.1.  (WRB)
+C***END PROLOGUE  AAAAAA
+      CHARACTER * (*) VER
+C***FIRST EXECUTABLE STATEMENT  AAAAAA
+      VER = ' 4.1'
+      RETURN
+      END

slatec/acosh.f

@@ -0,0 +1,39 @@
+*DECK ACOSH
+      FUNCTION ACOSH (X)
+C***BEGIN PROLOGUE  ACOSH
+C***PURPOSE  Compute the arc hyperbolic cosine.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C4C
+C***TYPE      SINGLE PRECISION (ACOSH-S, DACOSH-D, CACOSH-C)
+C***KEYWORDS  ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB,
+C             INVERSE HYPERBOLIC COSINE
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C ACOSH(X) computes the arc hyperbolic cosine of X.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  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  ACOSH
+      SAVE ALN2,XMAX
+      DATA ALN2 / 0.6931471805 5994530942E0/
+      DATA XMAX /0./
+C***FIRST EXECUTABLE STATEMENT  ACOSH
+      IF (XMAX.EQ.0.) XMAX = 1.0/SQRT(R1MACH(3))
+C
+      IF (X .LT. 1.0) CALL XERMSG ('SLATEC', 'ACOSH', 'X LESS THAN 1',
+     +   1, 2)
+C
+      IF (X.LT.XMAX) ACOSH = LOG (X + SQRT(X*X-1.0))
+      IF (X.GE.XMAX) ACOSH = ALN2 + LOG(X)
+C
+      RETURN
+      END

slatec/ai.f

@@ -0,0 +1,90 @@
+*DECK AI
+      FUNCTION AI (X)
+C***BEGIN PROLOGUE  AI
+C***PURPOSE  Evaluate the Airy function.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C10D
+C***TYPE      SINGLE PRECISION (AI-S, DAI-D)
+C***KEYWORDS  AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C AI(X) computes the Airy function Ai(X)
+C Series for AIF        on the interval -1.00000D+00 to  1.00000D+00
+C                                        with weighted error   1.09E-19
+C                                         log weighted error  18.96
+C                               significant figures required  17.76
+C                                    decimal places required  19.44
+C
+C Series for AIG        on the interval -1.00000D+00 to  1.00000D+00
+C                                        with weighted error   1.51E-17
+C                                         log weighted error  16.82
+C                               significant figures required  15.19
+C                                    decimal places required  17.27
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  AIE, 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   920618  Removed space from variable names.  (RWC, WRB)
+C***END PROLOGUE  AI
+      DIMENSION AIFCS(9), AIGCS(8)
+      LOGICAL FIRST
+      SAVE AIFCS, AIGCS, NAIF, NAIG, X3SML, XMAX, FIRST
+      DATA AIFCS( 1) /   -.0379713584 9666999750E0 /
+      DATA AIFCS( 2) /    .0591918885 3726363857E0 /
+      DATA AIFCS( 3) /    .0009862928 0577279975E0 /
+      DATA AIFCS( 4) /    .0000068488 4381907656E0 /
+      DATA AIFCS( 5) /    .0000000259 4202596219E0 /
+      DATA AIFCS( 6) /    .0000000000 6176612774E0 /
+      DATA AIFCS( 7) /    .0000000000 0010092454E0 /
+      DATA AIFCS( 8) /    .0000000000 0000012014E0 /
+      DATA AIFCS( 9) /    .0000000000 0000000010E0 /
+      DATA AIGCS( 1) /    .0181523655 8116127E0 /
+      DATA AIGCS( 2) /    .0215725631 6601076E0 /
+      DATA AIGCS( 3) /    .0002567835 6987483E0 /
+      DATA AIGCS( 4) /    .0000014265 2141197E0 /
+      DATA AIGCS( 5) /    .0000000045 7211492E0 /
+      DATA AIGCS( 6) /    .0000000000 0952517E0 /
+      DATA AIGCS( 7) /    .0000000000 0001392E0 /
+      DATA AIGCS( 8) /    .0000000000 0000001E0 /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  AI
+      IF (FIRST) THEN
+         NAIF = INITS (AIFCS, 9, 0.1*R1MACH(3))
+         NAIG = INITS (AIGCS, 8, 0.1*R1MACH(3))
+C
+         X3SML = R1MACH(3)**0.3334
+         XMAXT = (-1.5*LOG(R1MACH(1)))**0.6667
+         XMAX = XMAXT - XMAXT*LOG(XMAXT)/
+     *                   (4.0*SQRT(XMAXT)+1.0) - 0.01
+      ENDIF
+      FIRST = .FALSE.
+C
+      IF (X.GE.(-1.0)) GO TO 20
+      CALL R9AIMP (X, XM, THETA)
+      AI = XM * COS(THETA)
+      RETURN
+C
+ 20   IF (X.GT.1.0) GO TO 30
+      Z = 0.0
+      IF (ABS(X).GT.X3SML) Z = X**3
+      AI = 0.375 + (CSEVL (Z, AIFCS, NAIF) - X*(0.25 +
+     1  CSEVL (Z, AIGCS, NAIG)) )
+      RETURN
+C
+ 30   IF (X.GT.XMAX) GO TO 40
+      AI = AIE(X) * EXP(-2.0*X*SQRT(X)/3.0)
+      RETURN
+C
+ 40   AI = 0.0
+      CALL XERMSG ('SLATEC', 'AI', 'X SO BIG AI UNDERFLOWS', 1, 1)
+      RETURN
+C
+      END

slatec/aie.f

@@ -0,0 +1,133 @@
+*DECK AIE
+      FUNCTION AIE (X)
+C***BEGIN PROLOGUE  AIE
+C***PURPOSE  Calculate the Airy function for a negative argument and an
+C            exponentially scaled Airy function for a non-negative
+C            argument.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C10D
+C***TYPE      SINGLE PRECISION (AIE-S, DAIE-D)
+C***KEYWORDS  EXPONENTIALLY SCALED AIRY FUNCTION, FNLIB,
+C             SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C AIE(X) computes the exponentially scaled Airy function for
+C non-negative X.  It evaluates AI(X) for X .LE. 0.0 and
+C EXP(ZETA)*AI(X) for X .GE. 0.0 where ZETA = (2.0/3.0)*(X**1.5).
+C
+C Series for AIF        on the interval -1.00000D+00 to  1.00000D+00
+C                                        with weighted error   1.09E-19
+C                                         log weighted error  18.96
+C                               significant figures required  17.76
+C                                    decimal places required  19.44
+C
+C Series for AIG        on the interval -1.00000D+00 to  1.00000D+00
+C                                        with weighted error   1.51E-17
+C                                         log weighted error  16.82
+C                               significant figures required  15.19
+C                                    decimal places required  17.27
+C
+C Series for AIP        on the interval  0.          to  1.00000D+00
+C                                        with weighted error   5.10E-17
+C                                         log weighted error  16.29
+C                               significant figures required  14.41
+C                                    decimal places required  17.06
+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   920618  Removed space from variable names.  (RWC, WRB)
+C***END PROLOGUE  AIE
+      DIMENSION AIFCS(9), AIGCS(8), AIPCS(34)
+      LOGICAL FIRST
+      SAVE AIFCS, AIGCS, AIPCS, NAIF, NAIG,
+     1 NAIP, X3SML, X32SML, XBIG, FIRST
+      DATA AIFCS( 1) /   -.0379713584 9666999750E0 /
+      DATA AIFCS( 2) /    .0591918885 3726363857E0 /
+      DATA AIFCS( 3) /    .0009862928 0577279975E0 /
+      DATA AIFCS( 4) /    .0000068488 4381907656E0 /
+      DATA AIFCS( 5) /    .0000000259 4202596219E0 /
+      DATA AIFCS( 6) /    .0000000000 6176612774E0 /
+      DATA AIFCS( 7) /    .0000000000 0010092454E0 /
+      DATA AIFCS( 8) /    .0000000000 0000012014E0 /
+      DATA AIFCS( 9) /    .0000000000 0000000010E0 /
+      DATA AIGCS( 1) /    .0181523655 8116127E0 /
+      DATA AIGCS( 2) /    .0215725631 6601076E0 /
+      DATA AIGCS( 3) /    .0002567835 6987483E0 /
+      DATA AIGCS( 4) /    .0000014265 2141197E0 /
+      DATA AIGCS( 5) /    .0000000045 7211492E0 /
+      DATA AIGCS( 6) /    .0000000000 0952517E0 /
+      DATA AIGCS( 7) /    .0000000000 0001392E0 /
+      DATA AIGCS( 8) /    .0000000000 0000001E0 /
+      DATA AIPCS( 1) /   -.0187519297 793868E0 /
+      DATA AIPCS( 2) /   -.0091443848 250055E0 /
+      DATA AIPCS( 3) /    .0009010457 337825E0 /
+      DATA AIPCS( 4) /   -.0001394184 127221E0 /
+      DATA AIPCS( 5) /    .0000273815 815785E0 /
+      DATA AIPCS( 6) /   -.0000062750 421119E0 /
+      DATA AIPCS( 7) /    .0000016064 844184E0 /
+      DATA AIPCS( 8) /   -.0000004476 392158E0 /
+      DATA AIPCS( 9) /    .0000001334 635874E0 /
+      DATA AIPCS(10) /   -.0000000420 735334E0 /
+      DATA AIPCS(11) /    .0000000139 021990E0 /
+      DATA AIPCS(12) /   -.0000000047 831848E0 /
+      DATA AIPCS(13) /    .0000000017 047897E0 /
+      DATA AIPCS(14) /   -.0000000006 268389E0 /
+      DATA AIPCS(15) /    .0000000002 369824E0 /
+      DATA AIPCS(16) /   -.0000000000 918641E0 /
+      DATA AIPCS(17) /    .0000000000 364278E0 /
+      DATA AIPCS(18) /   -.0000000000 147475E0 /
+      DATA AIPCS(19) /    .0000000000 060851E0 /
+      DATA AIPCS(20) /   -.0000000000 025552E0 /
+      DATA AIPCS(21) /    .0000000000 010906E0 /
+      DATA AIPCS(22) /   -.0000000000 004725E0 /
+      DATA AIPCS(23) /    .0000000000 002076E0 /
+      DATA AIPCS(24) /   -.0000000000 000924E0 /
+      DATA AIPCS(25) /    .0000000000 000417E0 /
+      DATA AIPCS(26) /   -.0000000000 000190E0 /
+      DATA AIPCS(27) /    .0000000000 000087E0 /
+      DATA AIPCS(28) /   -.0000000000 000040E0 /
+      DATA AIPCS(29) /    .0000000000 000019E0 /
+      DATA AIPCS(30) /   -.0000000000 000009E0 /
+      DATA AIPCS(31) /    .0000000000 000004E0 /
+      DATA AIPCS(32) /   -.0000000000 000002E0 /
+      DATA AIPCS(33) /    .0000000000 000001E0 /
+      DATA AIPCS(34) /   -.0000000000 000000E0 /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  AIE
+      IF (FIRST) THEN
+         ETA = 0.1*R1MACH(3)
+         NAIF  = INITS (AIFCS, 9, ETA)
+         NAIG  = INITS (AIGCS, 8, ETA)
+         NAIP  = INITS (AIPCS, 34, 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)
+      AIE = XM * COS(THETA)
+      RETURN
+C
+ 20   IF (X.GT.1.0) GO TO 30
+      Z = 0.0
+      IF (ABS(X).GT.X3SML) Z = X**3
+      AIE = 0.375 + (CSEVL (Z, AIFCS, NAIF) - X*(0.25 +
+     1  CSEVL (Z, AIGCS, NAIG)) )
+      IF (X.GT.X32SML) AIE = AIE * EXP(2.0*X*SQRT(X)/3.0)
+      RETURN
+C
+ 30   SQRTX = SQRT(X)
+      Z = -1.0
+      IF (X.LT.XBIG) Z = 2.0/(X*SQRTX) - 1.0
+      AIE = (.28125 + CSEVL (Z, AIPCS, NAIP))/SQRT(SQRTX)
+      RETURN
+C
+      END

slatec/albeta.f

@@ -0,0 +1,63 @@
+*DECK ALBETA
+      FUNCTION ALBETA (A, B)
+C***BEGIN PROLOGUE  ALBETA
+C***PURPOSE  Compute the natural logarithm of the complete Beta
+C            function.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C7B
+C***TYPE      SINGLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C)
+C***KEYWORDS  FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION,
+C             SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C ALBETA computes the natural log of 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  ALNGAM, ALNREL, GAMMA, 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   900727  Added EXTERNAL statement.  (WRB)
+C***END PROLOGUE  ALBETA
+      EXTERNAL GAMMA
+      SAVE SQ2PIL
+      DATA SQ2PIL / 0.9189385332 0467274 E0 /
+C***FIRST EXECUTABLE STATEMENT  ALBETA
+      P = MIN (A, B)
+      Q = MAX (A, B)
+C
+      IF (P .LE. 0.0) CALL XERMSG ('SLATEC', 'ALBETA',
+     +   'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2)
+      IF (P.GE.10.0) GO TO 30
+      IF (Q.GE.10.0) GO TO 20
+C
+C P AND Q ARE SMALL.
+C
+      ALBETA = LOG(GAMMA(P) * (GAMMA(Q)/GAMMA(P+Q)) )
+      RETURN
+C
+C P IS SMALL, BUT Q IS BIG.
+C
+ 20   CORR = R9LGMC(Q) - R9LGMC(P+Q)
+      ALBETA = ALNGAM(P) + CORR + P - P*LOG(P+Q) +
+     1  (Q-0.5)*ALNREL(-P/(P+Q))
+      RETURN
+C
+C P AND Q ARE BIG.
+C
+ 30   CORR = R9LGMC(P) + R9LGMC(Q) - R9LGMC(P+Q)
+      ALBETA = -0.5*LOG(Q) + SQ2PIL + CORR + (P-0.5)*LOG(P/(P+Q))
+     1  + Q*ALNREL(-P/(P+Q))
+      RETURN
+C
+      END

slatec/algams.f

@@ -0,0 +1,38 @@
+*DECK ALGAMS
+      SUBROUTINE ALGAMS (X, ALGAM, SGNGAM)
+C***BEGIN PROLOGUE  ALGAMS
+C***PURPOSE  Compute the logarithm of the absolute value of the Gamma
+C            function.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C7A
+C***TYPE      SINGLE PRECISION (ALGAMS-S, DLGAMS-D)
+C***KEYWORDS  ABSOLUTE VALUE OF THE LOGARITHM OF THE GAMMA FUNCTION,
+C             FNLIB, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C Evaluates the logarithm of the absolute value of the gamma
+C function.
+C     X           - input argument
+C     ALGAM       - result
+C     SGNGAM      - is set to the sign of GAMMA(X) and will
+C                   be returned at +1.0 or -1.0.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  ALNGAM
+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***END PROLOGUE  ALGAMS
+C***FIRST EXECUTABLE STATEMENT  ALGAMS
+      ALGAM = ALNGAM(X)
+      SGNGAM = 1.0
+      IF (X.GT.0.0) RETURN
+C
+      INT = MOD (-AINT(X), 2.0) + 0.1
+      IF (INT.EQ.0) SGNGAM = -1.0
+C
+      RETURN
+      END

slatec/ali.f

@@ -0,0 +1,35 @@
+*DECK ALI
+      FUNCTION ALI (X)
+C***BEGIN PROLOGUE  ALI
+C***PURPOSE  Compute the logarithmic integral.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C5
+C***TYPE      SINGLE PRECISION (ALI-S, DLI-D)
+C***KEYWORDS  FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C ALI(X) computes the logarithmic integral; i.e., the
+C integral from 0.0 to X of (1.0/ln(t))dt.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  EI, 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  ALI
+C***FIRST EXECUTABLE STATEMENT  ALI
+      IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'ALI',
+     +   'LOG INTEGRAL UNDEFINED FOR X LE 0', 1, 2)
+      IF (X .EQ. 1.0) CALL XERMSG ('SLATEC', 'ALI',
+     +   'LOG INTEGRAL UNDEFINED FOR X = 1', 2, 2)
+C
+      ALI = EI (LOG(X) )
+C
+      RETURN
+      END

slatec/alngam.f

@@ -0,0 +1,70 @@
+*DECK ALNGAM
+      FUNCTION ALNGAM (X)
+C***BEGIN PROLOGUE  ALNGAM
+C***PURPOSE  Compute the logarithm of the absolute value of the Gamma
+C            function.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C7A
+C***TYPE      SINGLE PRECISION (ALNGAM-S, DLNGAM-D, CLNGAM-C)
+C***KEYWORDS  ABSOLUTE VALUE, COMPLETE GAMMA FUNCTION, FNLIB, LOGARITHM,
+C             SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C ALNGAM(X) computes the logarithm of the absolute value of the
+C gamma function at X.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  GAMMA, R1MACH, R9LGMC, 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  ALNGAM
+      LOGICAL FIRST
+      EXTERNAL GAMMA
+      SAVE SQ2PIL, SQPI2L, PI, XMAX, DXREL, FIRST
+      DATA SQ2PIL / 0.9189385332 0467274E0/
+      DATA SQPI2L / 0.2257913526 4472743E0/
+      DATA PI     / 3.1415926535 8979324E0/
+      DATA FIRST  /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  ALNGAM
+      IF (FIRST) THEN
+         XMAX = R1MACH(2)/LOG(R1MACH(2))
+         DXREL = SQRT (R1MACH(4))
+      ENDIF
+      FIRST = .FALSE.
+C
+      Y = ABS(X)
+      IF (Y.GT.10.0) GO TO 20
+C
+C LOG (ABS (GAMMA(X))) FOR  ABS(X) .LE. 10.0
+C
+      ALNGAM = LOG (ABS (GAMMA(X)))
+      RETURN
+C
+C LOG (ABS (GAMMA(X))) FOR ABS(X) .GT. 10.0
+C
+ 20   IF (Y .GT. XMAX) CALL XERMSG ('SLATEC', 'ALNGAM',
+     +   'ABS(X) SO BIG ALNGAM OVERFLOWS', 2, 2)
+C
+      IF (X.GT.0.) ALNGAM = SQ2PIL + (X-0.5)*LOG(X) - X + R9LGMC(Y)
+      IF (X.GT.0.) RETURN
+C
+      SINPIY = ABS (SIN(PI*Y))
+      IF (SINPIY .EQ. 0.) CALL XERMSG ('SLATEC', 'ALNGAM',
+     +   'X IS A NEGATIVE INTEGER', 3, 2)
+C
+      IF (ABS((X-AINT(X-0.5))/X) .LT. DXREL) CALL XERMSG ('SLATEC',
+     +   'ALNGAM', 'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR ' //
+     +   'NEGATIVE INTEGER', 1, 1)
+C
+      ALNGAM = SQPI2L + (X-0.5)*LOG(Y) - X - LOG(SINPIY) - R9LGMC(Y)
+      RETURN
+C
+      END

slatec/alnrel.f

@@ -0,0 +1,78 @@
+*DECK ALNREL
+      FUNCTION ALNREL (X)
+C***BEGIN PROLOGUE  ALNREL
+C***PURPOSE  Evaluate ln(1+X) accurate in the sense of relative error.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C4B
+C***TYPE      SINGLE PRECISION (ALNREL-S, DLNREL-D, CLNREL-C)
+C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C ALNREL(X) evaluates ln(1+X) accurately in the sense of relative
+C error when X is very small.  This routine must be used to
+C maintain relative error accuracy whenever X is small and
+C accurately known.
+C
+C Series for ALNR       on the interval -3.75000D-01 to  3.75000D-01
+C                                        with weighted error   1.93E-17
+C                                         log weighted error  16.72
+C                               significant figures required  16.44
+C                                    decimal places required  17.40
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  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  ALNREL
+      DIMENSION ALNRCS(23)
+      LOGICAL FIRST
+      SAVE ALNRCS, NLNREL, XMIN, FIRST
+      DATA ALNRCS( 1) /   1.0378693562 743770E0 /
+      DATA ALNRCS( 2) /   -.1336430150 4908918E0 /
+      DATA ALNRCS( 3) /    .0194082491 35520563E0 /
+      DATA ALNRCS( 4) /   -.0030107551 12753577E0 /
+      DATA ALNRCS( 5) /    .0004869461 47971548E0 /
+      DATA ALNRCS( 6) /   -.0000810548 81893175E0 /
+      DATA ALNRCS( 7) /    .0000137788 47799559E0 /
+      DATA ALNRCS( 8) /   -.0000023802 21089435E0 /
+      DATA ALNRCS( 9) /    .0000004164 04162138E0 /
+      DATA ALNRCS(10) /   -.0000000735 95828378E0 /
+      DATA ALNRCS(11) /    .0000000131 17611876E0 /
+      DATA ALNRCS(12) /   -.0000000023 54670931E0 /
+      DATA ALNRCS(13) /    .0000000004 25227732E0 /
+      DATA ALNRCS(14) /   -.0000000000 77190894E0 /
+      DATA ALNRCS(15) /    .0000000000 14075746E0 /
+      DATA ALNRCS(16) /   -.0000000000 02576907E0 /
+      DATA ALNRCS(17) /    .0000000000 00473424E0 /
+      DATA ALNRCS(18) /   -.0000000000 00087249E0 /
+      DATA ALNRCS(19) /    .0000000000 00016124E0 /
+      DATA ALNRCS(20) /   -.0000000000 00002987E0 /
+      DATA ALNRCS(21) /    .0000000000 00000554E0 /
+      DATA ALNRCS(22) /   -.0000000000 00000103E0 /
+      DATA ALNRCS(23) /    .0000000000 00000019E0 /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  ALNREL
+      IF (FIRST) THEN
+         NLNREL = INITS (ALNRCS, 23, 0.1*R1MACH(3))
+         XMIN = -1.0 + SQRT(R1MACH(4))
+      ENDIF
+      FIRST = .FALSE.
+C
+      IF (X .LE. (-1.0)) CALL XERMSG ('SLATEC', 'ALNREL', 'X IS LE -1',
+     +   2, 2)
+      IF (X .LT. XMIN) CALL XERMSG ('SLATEC', 'ALNREL',
+     +   'ANSWER LT HALF PRECISION BECAUSE X TOO NEAR -1', 1, 1)
+C
+      IF (ABS(X).LE.0.375) ALNREL = X*(1. -
+     1  X*CSEVL (X/.375, ALNRCS, NLNREL))
+      IF (ABS(X).GT.0.375) ALNREL = LOG (1.0+X)
+C
+      RETURN
+      END

slatec/asinh.f

@@ -0,0 +1,74 @@
+*DECK ASINH
+      FUNCTION ASINH (X)
+C***BEGIN PROLOGUE  ASINH
+C***PURPOSE  Compute the arc hyperbolic sine.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C4C
+C***TYPE      SINGLE PRECISION (ASINH-S, DASINH-D, CASINH-C)
+C***KEYWORDS  ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB,
+C             INVERSE HYPERBOLIC SINE
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C ASINH(X) computes the arc hyperbolic sine of X.
+C
+C Series for ASNH       on the interval  0.          to  1.00000D+00
+C                                        with weighted error   2.19E-17
+C                                         log weighted error  16.66
+C                               significant figures required  15.60
+C                                    decimal places required  17.31
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  CSEVL, INITS, R1MACH
+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***END PROLOGUE  ASINH
+      DIMENSION ASNHCS(20)
+      LOGICAL FIRST
+      SAVE ALN2, ASNHCS, NTERMS, XMAX, SQEPS, FIRST
+      DATA ALN2 /0.6931471805 5994530942E0/
+      DATA ASNHCS( 1) /   -.1282003991 1738186E0 /
+      DATA ASNHCS( 2) /   -.0588117611 89951768E0 /
+      DATA ASNHCS( 3) /    .0047274654 32212481E0 /
+      DATA ASNHCS( 4) /   -.0004938363 16265361E0 /
+      DATA ASNHCS( 5) /    .0000585062 07058557E0 /
+      DATA ASNHCS( 6) /   -.0000074669 98328931E0 /
+      DATA ASNHCS( 7) /    .0000010011 69358355E0 /
+      DATA ASNHCS( 8) /   -.0000001390 35438587E0 /
+      DATA ASNHCS( 9) /    .0000000198 23169483E0 /
+      DATA ASNHCS(10) /   -.0000000028 84746841E0 /
+      DATA ASNHCS(11) /    .0000000004 26729654E0 /
+      DATA ASNHCS(12) /   -.0000000000 63976084E0 /
+      DATA ASNHCS(13) /    .0000000000 09699168E0 /
+      DATA ASNHCS(14) /   -.0000000000 01484427E0 /
+      DATA ASNHCS(15) /    .0000000000 00229037E0 /
+      DATA ASNHCS(16) /   -.0000000000 00035588E0 /
+      DATA ASNHCS(17) /    .0000000000 00005563E0 /
+      DATA ASNHCS(18) /   -.0000000000 00000874E0 /
+      DATA ASNHCS(19) /    .0000000000 00000138E0 /
+      DATA ASNHCS(20) /   -.0000000000 00000021E0 /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  ASINH
+      IF (FIRST) THEN
+         NTERMS = INITS (ASNHCS, 20, 0.1*R1MACH(3))
+         SQEPS = SQRT (R1MACH(3))
+         XMAX = 1.0/SQEPS
+      ENDIF
+      FIRST = .FALSE.
+C
+      Y = ABS(X)
+      IF (Y.GT.1.0) GO TO 20
+C
+      ASINH = X
+      IF (Y.GT.SQEPS) ASINH = X*(1.0 + CSEVL (2.*X*X-1., ASNHCS,NTERMS))
+      RETURN
+C
+ 20   IF (Y.LT.XMAX) ASINH = LOG (Y + SQRT(Y**2+1.))
+      IF (Y.GE.XMAX) ASINH = ALN2 + LOG(Y)
+      ASINH = SIGN (ASINH, X)
+C
+      RETURN
+      END

slatec/asyik.f

@@ -0,0 +1,144 @@
+*DECK ASYIK
+      SUBROUTINE ASYIK (X, FNU, KODE, FLGIK, RA, ARG, IN, Y)
+C***BEGIN PROLOGUE  ASYIK
+C***SUBSIDIARY
+C***PURPOSE  Subsidiary to BESI and BESK
+C***LIBRARY   SLATEC
+C***TYPE      SINGLE PRECISION (ASYIK-S, DASYIK-D)
+C***AUTHOR  Amos, D. E., (SNLA)
+C***DESCRIPTION
+C
+C                    ASYIK computes Bessel functions I and K
+C                  for arguments X.GT.0.0 and orders FNU.GE.35
+C                  on FLGIK = 1 and FLGIK = -1 respectively.
+C
+C                                    INPUT
+C
+C      X    - argument, X.GT.0.0E0
+C      FNU  - order of first Bessel function
+C      KODE - a parameter to indicate the scaling option
+C             KODE=1 returns Y(I)=        I/SUB(FNU+I-1)/(X), I=1,IN
+C                    or      Y(I)=        K/SUB(FNU+I-1)/(X), I=1,IN
+C                    on FLGIK = 1.0E0 or FLGIK = -1.0E0
+C             KODE=2 returns Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN
+C                    or      Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN
+C                    on FLGIK = 1.0E0 or FLGIK = -1.0E0
+C     FLGIK - selection parameter for I or K function
+C             FLGIK =  1.0E0 gives the I function
+C             FLGIK = -1.0E0 gives the K function
+C        RA - SQRT(1.+Z*Z), Z=X/FNU
+C       ARG - argument of the leading exponential
+C        IN - number of functions desired, IN=1 or 2
+C
+C                                    OUTPUT
+C
+C         Y - a vector whose first in components contain the sequence
+C
+C     Abstract
+C         ASYIK implements the uniform asymptotic expansion of
+C         the I and K Bessel functions for FNU.GE.35 and real
+C         X.GT.0.0E0. The forms are identical except for a change
+C         in sign of some of the terms. This change in sign is
+C         accomplished by means of the flag FLGIK = 1 or -1.
+C
+C***SEE ALSO  BESI, BESK
+C***ROUTINES CALLED  R1MACH
+C***REVISION HISTORY  (YYMMDD)
+C   750101  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   910408  Updated the AUTHOR section.  (WRB)
+C***END PROLOGUE  ASYIK
+C
+      INTEGER IN, J, JN, K, KK, KODE, L
+      REAL AK,AP,ARG,C, COEF,CON,ETX,FLGIK,FN, FNU,GLN,RA,S1,S2,
+     1 T, TOL, T2, X, Y, Z
+      REAL R1MACH
+      DIMENSION Y(*), C(65), CON(2)
+      SAVE CON, C
+      DATA CON(1), CON(2)  /
+     1        3.98942280401432678E-01,    1.25331413731550025E+00/
+      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
+     1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
+     2     C(19), C(20), C(21), C(22), C(23), C(24)/
+     3       -2.08333333333333E-01,        1.25000000000000E-01,
+     4        3.34201388888889E-01,       -4.01041666666667E-01,
+     5        7.03125000000000E-02,       -1.02581259645062E+00,
+     6        1.84646267361111E+00,       -8.91210937500000E-01,
+     7        7.32421875000000E-02,        4.66958442342625E+00,
+     8       -1.12070026162230E+01,        8.78912353515625E+00,
+     9       -2.36408691406250E+00,        1.12152099609375E-01,
+     1       -2.82120725582002E+01,        8.46362176746007E+01,
+     2       -9.18182415432400E+01,        4.25349987453885E+01,
+     3       -7.36879435947963E+00,        2.27108001708984E-01,
+     4        2.12570130039217E+02,       -7.65252468141182E+02,
+     5        1.05999045252800E+03,       -6.99579627376133E+02/
+      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
+     1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
+     2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
+     3        2.18190511744212E+02,       -2.64914304869516E+01,
+     4        5.72501420974731E-01,       -1.91945766231841E+03,
+     5        8.06172218173731E+03,       -1.35865500064341E+04,
+     6        1.16553933368645E+04,       -5.30564697861340E+03,
+     7        1.20090291321635E+03,       -1.08090919788395E+02,
+     8        1.72772750258446E+00,        2.02042913309661E+04,
+     9       -9.69805983886375E+04,        1.92547001232532E+05,
+     1       -2.03400177280416E+05,        1.22200464983017E+05,
+     2       -4.11926549688976E+04,        7.10951430248936E+03,
+     3       -4.93915304773088E+02,        6.07404200127348E+00,
+     4       -2.42919187900551E+05,        1.31176361466298E+06,
+     5       -2.99801591853811E+06,        3.76327129765640E+06/
+      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
+     1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
+     2     C(65)/
+     3       -2.81356322658653E+06,        1.26836527332162E+06,
+     4       -3.31645172484564E+05,        4.52187689813627E+04,
+     5       -2.49983048181121E+03,        2.43805296995561E+01,
+     6        3.28446985307204E+06,       -1.97068191184322E+07,
+     7        5.09526024926646E+07,       -7.41051482115327E+07,
+     8        6.63445122747290E+07,       -3.75671766607634E+07,
+     9        1.32887671664218E+07,       -2.78561812808645E+06,
+     1        3.08186404612662E+05,       -1.38860897537170E+04,
+     2        1.10017140269247E+02/
+C***FIRST EXECUTABLE STATEMENT  ASYIK
+      TOL = R1MACH(3)
+      TOL = MAX(TOL,1.0E-15)
+      FN = FNU
+      Z  = (3.0E0-FLGIK)/2.0E0
+      KK = INT(Z)
+      DO 50 JN=1,IN
+        IF (JN.EQ.1) GO TO 10
+        FN = FN - FLGIK
+        Z = X/FN
+        RA = SQRT(1.0E0+Z*Z)
+        GLN = LOG((1.0E0+RA)/Z)
+        ETX = KODE - 1
+        T = RA*(1.0E0-ETX) + ETX/(Z+RA)
+        ARG = FN*(T-GLN)*FLGIK
+   10   COEF = EXP(ARG)
+        T = 1.0E0/RA
+        T2 = T*T
+        T = T/FN
+        T = SIGN(T,FLGIK)
+        S2 = 1.0E0
+        AP = 1.0E0
+        L = 0
+        DO 30 K=2,11
+          L = L + 1
+          S1 = C(L)
+          DO 20 J=2,K
+            L = L + 1
+            S1 = S1*T2 + C(L)
+   20     CONTINUE
+          AP = AP*T
+          AK = AP*S1
+          S2 = S2 + AK
+          IF (MAX(ABS(AK),ABS(AP)) .LT. TOL) GO TO 40
+   30   CONTINUE
+   40   CONTINUE
+      T = ABS(T)
+      Y(JN) = S2*COEF*SQRT(T)*CON(KK)
+   50 CONTINUE
+      RETURN
+      END

slatec/asyjy.f

@@ -0,0 +1,491 @@
+*DECK ASYJY
+      SUBROUTINE ASYJY (FUNJY, X, FNU, FLGJY, IN, Y, WK, IFLW)
+C***BEGIN PROLOGUE  ASYJY
+C***SUBSIDIARY
+C***PURPOSE  Subsidiary to BESJ and BESY
+C***LIBRARY   SLATEC
+C***TYPE      SINGLE PRECISION (ASYJY-S, DASYJY-D)
+C***AUTHOR  Amos, D. E., (SNLA)
+C***DESCRIPTION
+C
+C                 ASYJY computes Bessel functions J and Y
+C               for arguments X.GT.0.0 and orders FNU.GE.35.0
+C               on FLGJY = 1 and FLGJY = -1 respectively
+C
+C                                  INPUT
+C
+C      FUNJY - external function JAIRY or YAIRY
+C          X - argument, X.GT.0.0E0
+C        FNU - order of the first Bessel function
+C      FLGJY - selection flag
+C              FLGJY =  1.0E0 gives the J function
+C              FLGJY = -1.0E0 gives the Y function
+C         IN - number of functions desired, IN = 1 or 2
+C
+C                                  OUTPUT
+C
+C         Y  - a vector whose first in components contain the sequence
+C       IFLW - a flag indicating underflow or overflow
+C                    return variables for BESJ only
+C      WK(1) = 1 - (X/FNU)**2 = W**2
+C      WK(2) = SQRT(ABS(WK(1)))
+C      WK(3) = ABS(WK(2) - ATAN(WK(2)))  or
+C              ABS(LN((1 + WK(2))/(X/FNU)) - WK(2))
+C            = ABS((2/3)*ZETA**(3/2))
+C      WK(4) = FNU*WK(3)
+C      WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3)
+C      WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3)
+C      WK(7) = FNU**(1/3)
+C
+C     Abstract
+C         ASYJY implements the uniform asymptotic expansion of
+C         the J and Y Bessel functions for FNU.GE.35 and real
+C         X.GT.0.0E0. The forms are identical except for a change
+C         in sign of some of the terms. This change in sign is
+C         accomplished by means of the flag FLGJY = 1 or -1. On
+C         FLGJY = 1 the AIRY functions AI(X) and DAI(X) are
+C         supplied by the external function JAIRY, and on
+C         FLGJY = -1 the AIRY functions BI(X) and DBI(X) are
+C         supplied by the external function YAIRY.
+C
+C***SEE ALSO  BESJ, BESY
+C***ROUTINES CALLED  I1MACH, R1MACH
+C***REVISION HISTORY  (YYMMDD)
+C   750101  DATE WRITTEN
+C   890531  Changed all specific intrinsics to generic.  (WRB)
+C   891009  Removed unreferenced variable.  (WRB)
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900328  Added TYPE section.  (WRB)
+C   910408  Updated the AUTHOR section.  (WRB)
+C***END PROLOGUE  ASYJY
+      INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1,
+     * KSTEMP, L, LR, LRP1, ISETA, ISETB
+      INTEGER I1MACH
+      REAL ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ,
+     * BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2,
+     * CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU,
+     * FN2, GAMA, PHI,  RCZ, RDEN, RELB, RFN2,  RTZ, RZDEN,
+     * SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL,
+     *  WK, X, XX, Y, Z, Z32
+      REAL R1MACH
+      DIMENSION Y(*), WK(*), C(65)
+      DIMENSION ALFA(26,4), BETA(26,5)
+      DIMENSION ALFA1(26,2), ALFA2(26,2)
+      DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1)
+      DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10)
+      DIMENSION CR(10), DR(10)
+      EQUIVALENCE (ALFA(1,1),ALFA1(1,1))
+      EQUIVALENCE (ALFA(1,3),ALFA2(1,1))
+      EQUIVALENCE (BETA(1,1),BETA1(1,1))
+      EQUIVALENCE (BETA(1,3),BETA2(1,1))
+      EQUIVALENCE (BETA(1,5),BETA3(1,1))
+      SAVE TOLS, CON1, CON2, CON548, AR, BR, C, ALFA1, ALFA2,
+     1 BETA1, BETA2, BETA3, GAMA
+      DATA TOLS            /-6.90775527898214E+00/
+      DATA CON1,CON2,CON548/
+     1 6.66666666666667E-01, 3.33333333333333E-01, 1.04166666666667E-01/
+      DATA  AR(1),  AR(2),  AR(3),  AR(4),  AR(5),  AR(6),  AR(7),
+     A      AR(8)          / 8.35503472222222E-02, 1.28226574556327E-01,
+     1 2.91849026464140E-01, 8.81627267443758E-01, 3.32140828186277E+00,
+     2 1.49957629868626E+01, 7.89230130115865E+01, 4.74451538868264E+02/
+      DATA  BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8),
+     A      BR(9), BR(10)  /-1.45833333333333E-01,-9.87413194444444E-02,
+     1-1.43312053915895E-01,-3.17227202678414E-01,-9.42429147957120E-01,
+     2-3.51120304082635E+00,-1.57272636203680E+01,-8.22814390971859E+01,
+     3-4.92355370523671E+02,-3.31621856854797E+03/
+      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
+     1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
+     2     C(19), C(20), C(21), C(22), C(23), C(24)/
+     3       -2.08333333333333E-01,        1.25000000000000E-01,
+     4        3.34201388888889E-01,       -4.01041666666667E-01,
+     5        7.03125000000000E-02,       -1.02581259645062E+00,
+     6        1.84646267361111E+00,       -8.91210937500000E-01,
+     7        7.32421875000000E-02,        4.66958442342625E+00,
+     8       -1.12070026162230E+01,        8.78912353515625E+00,
+     9       -2.36408691406250E+00,        1.12152099609375E-01,
+     A       -2.82120725582002E+01,        8.46362176746007E+01,
+     B       -9.18182415432400E+01,        4.25349987453885E+01,
+     C       -7.36879435947963E+00,        2.27108001708984E-01,
+     D        2.12570130039217E+02,       -7.65252468141182E+02,
+     E        1.05999045252800E+03,       -6.99579627376133E+02/
+      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
+     1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
+     2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
+     3        2.18190511744212E+02,       -2.64914304869516E+01,
+     4        5.72501420974731E-01,       -1.91945766231841E+03,
+     5        8.06172218173731E+03,       -1.35865500064341E+04,
+     6        1.16553933368645E+04,       -5.30564697861340E+03,
+     7        1.20090291321635E+03,       -1.08090919788395E+02,
+     8        1.72772750258446E+00,        2.02042913309661E+04,
+     9       -9.69805983886375E+04,        1.92547001232532E+05,
+     A       -2.03400177280416E+05,        1.22200464983017E+05,
+     B       -4.11926549688976E+04,        7.10951430248936E+03,
+     C       -4.93915304773088E+02,        6.07404200127348E+00,
+     D       -2.42919187900551E+05,        1.31176361466298E+06,
+     E       -2.99801591853811E+06,        3.76327129765640E+06/
+      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
+     1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
+     2     C(65)/
+     3       -2.81356322658653E+06,        1.26836527332162E+06,
+     4       -3.31645172484564E+05,        4.52187689813627E+04,
+     5       -2.49983048181121E+03,        2.43805296995561E+01,
+     6        3.28446985307204E+06,       -1.97068191184322E+07,
+     7        5.09526024926646E+07,       -7.41051482115327E+07,
+     8        6.63445122747290E+07,       -3.75671766607634E+07,
+     9        1.32887671664218E+07,       -2.78561812808645E+06,
+     A        3.08186404612662E+05,       -1.38860897537170E+04,
+     B        1.10017140269247E+02/
+      DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1),
+     1     ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1),
+     2     ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1),
+     3     ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1),
+     4     ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1),
+     5     ALFA1(26,1)     /-4.44444444444444E-03,-9.22077922077922E-04,
+     6-8.84892884892885E-05, 1.65927687832450E-04, 2.46691372741793E-04,
+     7 2.65995589346255E-04, 2.61824297061501E-04, 2.48730437344656E-04,
+     8 2.32721040083232E-04, 2.16362485712365E-04, 2.00738858762752E-04,
+     9 1.86267636637545E-04, 1.73060775917876E-04, 1.61091705929016E-04,
+     1 1.50274774160908E-04, 1.40503497391270E-04, 1.31668816545923E-04,
+     2 1.23667445598253E-04, 1.16405271474738E-04, 1.09798298372713E-04,
+     3 1.03772410422993E-04, 9.82626078369363E-05, 9.32120517249503E-05,
+     4 8.85710852478712E-05, 8.42963105715700E-05, 8.03497548407791E-05/
+      DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2),
+     1     ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2),
+     2     ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2),
+     3     ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2),
+     4     ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2),
+     5     ALFA1(26,2)     / 6.93735541354589E-04, 2.32241745182922E-04,
+     6-1.41986273556691E-05,-1.16444931672049E-04,-1.50803558053049E-04,
+     7-1.55121924918096E-04,-1.46809756646466E-04,-1.33815503867491E-04,
+     8-1.19744975684254E-04,-1.06184319207974E-04,-9.37699549891194E-05,
+     9-8.26923045588193E-05,-7.29374348155221E-05,-6.44042357721016E-05,
+     1-5.69611566009369E-05,-5.04731044303562E-05,-4.48134868008883E-05,
+     2-3.98688727717599E-05,-3.55400532972042E-05,-3.17414256609022E-05,
+     3-2.83996793904175E-05,-2.54522720634871E-05,-2.28459297164725E-05,
+     4-2.05352753106481E-05,-1.84816217627666E-05,-1.66519330021394E-05/
+      DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1),
+     1     ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1),
+     2     ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1),
+     3     ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1),
+     4     ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1),
+     5     ALFA2(26,1)     /-3.54211971457744E-04,-1.56161263945159E-04,
+     6 3.04465503594936E-05, 1.30198655773243E-04, 1.67471106699712E-04,
+     7 1.70222587683593E-04, 1.56501427608595E-04, 1.36339170977445E-04,
+     8 1.14886692029825E-04, 9.45869093034688E-05, 7.64498419250898E-05,
+     9 6.07570334965197E-05, 4.74394299290509E-05, 3.62757512005344E-05,
+     1 2.69939714979225E-05, 1.93210938247939E-05, 1.30056674793963E-05,
+     2 7.82620866744497E-06, 3.59257485819352E-06, 1.44040049814252E-07,
+     3-2.65396769697939E-06,-4.91346867098486E-06,-6.72739296091248E-06,
+     4-8.17269379678658E-06,-9.31304715093561E-06,-1.02011418798016E-05/
+      DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2),
+     1     ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2),
+     2     ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2),
+     3     ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2),
+     4     ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2),
+     5     ALFA2(26,2)     / 3.78194199201773E-04, 2.02471952761816E-04,
+     6-6.37938506318862E-05,-2.38598230603006E-04,-3.10916256027362E-04,
+     7-3.13680115247576E-04,-2.78950273791323E-04,-2.28564082619141E-04,
+     8-1.75245280340847E-04,-1.25544063060690E-04,-8.22982872820208E-05,
+     9-4.62860730588116E-05,-1.72334302366962E-05, 5.60690482304602E-06,
+     1 2.31395443148287E-05, 3.62642745856794E-05, 4.58006124490189E-05,
+     2 5.24595294959114E-05, 5.68396208545815E-05, 5.94349820393104E-05,
+     3 6.06478527578422E-05, 6.08023907788436E-05, 6.01577894539460E-05,
+     4 5.89199657344698E-05, 5.72515823777593E-05, 5.52804375585853E-05/
+      DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1),
+     1     BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1),
+     2     BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1),
+     3     BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1),
+     4     BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1),
+     5     BETA1(26,1)     / 1.79988721413553E-02, 5.59964911064388E-03,
+     6 2.88501402231133E-03, 1.80096606761054E-03, 1.24753110589199E-03,
+     7 9.22878876572938E-04, 7.14430421727287E-04, 5.71787281789705E-04,
+     8 4.69431007606482E-04, 3.93232835462917E-04, 3.34818889318298E-04,
+     9 2.88952148495752E-04, 2.52211615549573E-04, 2.22280580798883E-04,
+     1 1.97541838033063E-04, 1.76836855019718E-04, 1.59316899661821E-04,
+     2 1.44347930197334E-04, 1.31448068119965E-04, 1.20245444949303E-04,
+     3 1.10449144504599E-04, 1.01828770740567E-04, 9.41998224204238E-05,
+     4 8.74130545753834E-05, 8.13466262162801E-05, 7.59002269646219E-05/
+      DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2),
+     1     BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2),
+     2     BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2),
+     3     BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2),
+     4     BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2),
+     5     BETA1(26,2)     /-1.49282953213429E-03,-8.78204709546389E-04,
+     6-5.02916549572035E-04,-2.94822138512746E-04,-1.75463996970783E-04,
+     7-1.04008550460816E-04,-5.96141953046458E-05,-3.12038929076098E-05,
+     8-1.26089735980230E-05,-2.42892608575730E-07, 8.05996165414274E-06,
+     9 1.36507009262147E-05, 1.73964125472926E-05, 1.98672978842134E-05,
+     1 2.14463263790823E-05, 2.23954659232457E-05, 2.28967783814713E-05,
+     2 2.30785389811178E-05, 2.30321976080909E-05, 2.28236073720349E-05,
+     3 2.25005881105292E-05, 2.20981015361991E-05, 2.16418427448104E-05,
+     4 2.11507649256221E-05, 2.06388749782171E-05, 2.01165241997082E-05/
+      DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1),
+     1     BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1),
+     2     BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1),
+     3     BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1),
+     4     BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1),
+     5     BETA2(26,1)     / 5.52213076721293E-04, 4.47932581552385E-04,
+     6 2.79520653992021E-04, 1.52468156198447E-04, 6.93271105657044E-05,
+     7 1.76258683069991E-05,-1.35744996343269E-05,-3.17972413350427E-05,
+     8-4.18861861696693E-05,-4.69004889379141E-05,-4.87665447413787E-05,
+     9-4.87010031186735E-05,-4.74755620890087E-05,-4.55813058138628E-05,
+     1-4.33309644511266E-05,-4.09230193157750E-05,-3.84822638603221E-05,
+     2-3.60857167535411E-05,-3.37793306123367E-05,-3.15888560772110E-05,
+     3-2.95269561750807E-05,-2.75978914828336E-05,-2.58006174666884E-05,
+     4-2.41308356761280E-05,-2.25823509518346E-05,-2.11479656768913E-05/
+      DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2),
+     1     BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2),
+     2     BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2),
+     3     BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2),
+     4     BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2),
+     5     BETA2(26,2)     /-4.74617796559960E-04,-4.77864567147321E-04,
+     6-3.20390228067038E-04,-1.61105016119962E-04,-4.25778101285435E-05,
+     7 3.44571294294968E-05, 7.97092684075675E-05, 1.03138236708272E-04,
+     8 1.12466775262204E-04, 1.13103642108481E-04, 1.08651634848774E-04,
+     9 1.01437951597662E-04, 9.29298396593364E-05, 8.40293133016090E-05,
+     1 7.52727991349134E-05, 6.69632521975731E-05, 5.92564547323195E-05,
+     2 5.22169308826976E-05, 4.58539485165361E-05, 4.01445513891487E-05,
+     3 3.50481730031328E-05, 3.05157995034347E-05, 2.64956119950516E-05,
+     4 2.29363633690998E-05, 1.97893056664022E-05, 1.70091984636413E-05/
+      DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1),
+     1     BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1),
+     2     BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1),
+     3     BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1),
+     4     BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1),
+     5     BETA3(26,1)     / 7.36465810572578E-04, 8.72790805146194E-04,
+     6 6.22614862573135E-04, 2.85998154194304E-04, 3.84737672879366E-06,
+     7-1.87906003636972E-04,-2.97603646594555E-04,-3.45998126832656E-04,
+     8-3.53382470916038E-04,-3.35715635775049E-04,-3.04321124789040E-04,
+     9-2.66722723047613E-04,-2.27654214122820E-04,-1.89922611854562E-04,
+     1-1.55058918599094E-04,-1.23778240761874E-04,-9.62926147717644E-05,
+     2-7.25178327714425E-05,-5.22070028895634E-05,-3.50347750511901E-05,
+     3-2.06489761035552E-05,-8.70106096849767E-06, 1.13698686675100E-06,
+     4 9.16426474122779E-06, 1.56477785428873E-05, 2.08223629482467E-05/
+      DATA GAMA(1),   GAMA(2),   GAMA(3),   GAMA(4),   GAMA(5),
+     1     GAMA(6),   GAMA(7),   GAMA(8),   GAMA(9),   GAMA(10),
+     2     GAMA(11),  GAMA(12),  GAMA(13),  GAMA(14),  GAMA(15),
+     3     GAMA(16),  GAMA(17),  GAMA(18),  GAMA(19),  GAMA(20),
+     4     GAMA(21),  GAMA(22),  GAMA(23),  GAMA(24),  GAMA(25),
+     5     GAMA(26)        / 6.29960524947437E-01, 2.51984209978975E-01,
+     6 1.54790300415656E-01, 1.10713062416159E-01, 8.57309395527395E-02,
+     7 6.97161316958684E-02, 5.86085671893714E-02, 5.04698873536311E-02,
+     8 4.42600580689155E-02, 3.93720661543510E-02, 3.54283195924455E-02,
+     9 3.21818857502098E-02, 2.94646240791158E-02, 2.71581677112934E-02,
+     1 2.51768272973862E-02, 2.34570755306079E-02, 2.19508390134907E-02,
+     2 2.06210828235646E-02, 1.94388240897881E-02, 1.83810633800683E-02,
+     3 1.74293213231963E-02, 1.65685837786612E-02, 1.57865285987918E-02,
+     4 1.50729501494096E-02, 1.44193250839955E-02, 1.38184805735342E-02/
+C***FIRST EXECUTABLE STATEMENT  ASYJY
+      TA = R1MACH(3)
+      TOL = MAX(TA,1.0E-15)
+      TB = R1MACH(5)
+      JU = I1MACH(12)
+      IF(FLGJY.EQ.1.0E0) GO TO 6
+      JR = I1MACH(11)
+      ELIM = -2.303E0*TB*(JU+JR)
+      GO TO 7
+    6 CONTINUE
+      ELIM = -2.303E0*(TB*JU+3.0E0)
+    7 CONTINUE
+      FN = FNU
+      IFLW = 0
+      DO 170 JN=1,IN
+        XX = X/FN
+        WK(1) = 1.0E0 - XX*XX
+        ABW2 = ABS(WK(1))
+        WK(2) = SQRT(ABW2)
+        WK(7) = FN**CON2
+        IF (ABW2.GT.0.27750E0) GO TO 80
+C
+C     ASYMPTOTIC EXPANSION
+C     CASES NEAR X=FN, ABS(1.-(X/FN)**2).LE.0.2775
+C     COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES
+C
+C     ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES
+C
+C     KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA)
+C
+        SA = 0.0E0
+        IF (ABW2.EQ.0.0E0) GO TO 10
+        SA = TOLS/LOG(ABW2)
+   10   SB = SA
+        DO 20 I=1,5
+          AKM = MAX(SA,2.0E0)
+          KMAX(I) = INT(AKM)
+          SA = SA + SB
+   20   CONTINUE
+        KB = KMAX(5)
+        KLAST = KB - 1
+        SA = GAMA(KB)
+        DO 30 K=1,KLAST
+          KB = KB - 1
+          SA = SA*WK(1) + GAMA(KB)
+   30   CONTINUE
+        Z = WK(1)*SA
+        AZ = ABS(Z)
+        RTZ = SQRT(AZ)
+        WK(3) = CON1*AZ*RTZ
+        WK(4) = WK(3)*FN
+        WK(5) = RTZ*WK(7)
+        WK(6) = -WK(5)*WK(5)
+        IF(Z.LE.0.0E0) GO TO 35
+        IF(WK(4).GT.ELIM) GO TO 75
+        WK(6) = -WK(6)
+   35   CONTINUE
+        PHI = SQRT(SQRT(SA+SA+SA+SA))
+C
+C     B(ZETA) FOR S=0
+C
+        KB = KMAX(5)
+        KLAST = KB - 1
+        SB = BETA(KB,1)
+        DO 40 K=1,KLAST
+          KB = KB - 1
+          SB = SB*WK(1) + BETA(KB,1)
+   40   CONTINUE
+        KSP1 = 1
+        FN2 = FN*FN
+        RFN2 = 1.0E0/FN2
+        RDEN = 1.0E0
+        ASUM = 1.0E0
+        RELB = TOL*ABS(SB)
+        BSUM = SB
+        DO 60 KS=1,4
+          KSP1 = KSP1 + 1
+          RDEN = RDEN*RFN2
+C
+C     A(ZETA) AND B(ZETA) FOR S=1,2,3,4
+C
+          KSTEMP = 5 - KS
+          KB = KMAX(KSTEMP)
+          KLAST = KB - 1
+          SA = ALFA(KB,KS)
+          SB = BETA(KB,KSP1)
+          DO 50 K=1,KLAST
+            KB = KB - 1
+            SA = SA*WK(1) + ALFA(KB,KS)
+            SB = SB*WK(1) + BETA(KB,KSP1)
+   50     CONTINUE
+          TA = SA*RDEN
+          TB = SB*RDEN
+          ASUM = ASUM + TA
+          BSUM = BSUM + TB
+          IF (ABS(TA).LE.TOL .AND. ABS(TB).LE.RELB) GO TO 70
+   60   CONTINUE
+   70   CONTINUE
+        BSUM = BSUM/(FN*WK(7))
+        GO TO 160
+C
+   75   CONTINUE
+        IFLW = 1
+        RETURN
+C
+   80   CONTINUE
+        UPOL(1) = 1.0E0
+        TAU = 1.0E0/WK(2)
+        T2 = 1.0E0/WK(1)
+        IF (WK(1).GE.0.0E0) GO TO 90
+C
+C     CASES FOR (X/FN).GT.SQRT(1.2775)
+C
+        WK(3) = ABS(WK(2)-ATAN(WK(2)))
+        WK(4) = WK(3)*FN
+        RCZ = -CON1/WK(4)
+        Z32 = 1.5E0*WK(3)
+        RTZ = Z32**CON2
+        WK(5) = RTZ*WK(7)
+        WK(6) = -WK(5)*WK(5)
+        GO TO 100
+   90   CONTINUE
+C
+C     CASES FOR (X/FN).LT.SQRT(0.7225)
+C
+        WK(3) = ABS(LOG((1.0E0+WK(2))/XX)-WK(2))
+        WK(4) = WK(3)*FN
+        RCZ = CON1/WK(4)
+        IF(WK(4).GT.ELIM) GO TO 75
+        Z32 = 1.5E0*WK(3)
+        RTZ = Z32**CON2
+        WK(7) = FN**CON2
+        WK(5) = RTZ*WK(7)
+        WK(6) = WK(5)*WK(5)
+  100   CONTINUE
+        PHI = SQRT((RTZ+RTZ)*TAU)
+        TB = 1.0E0
+        ASUM = 1.0E0
+        TFN = TAU/FN
+        RDEN=1.0E0/FN
+        RFN2=RDEN*RDEN
+        RDEN=1.0E0
+        UPOL(2) = (C(1)*T2+C(2))*TFN
+        CRZ32 = CON548*RCZ
+        BSUM = UPOL(2) + CRZ32
+        RELB = TOL*ABS(BSUM)
+        AP = TFN
+        KS = 0
+        KP1 = 2
+        RZDEN = RCZ
+        L = 2
+        ISETA=0
+        ISETB=0
+        DO 140 LR=2,8,2
+C
+C     COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA)
+C
+          LRP1 = LR + 1
+          DO 120 K=LR,LRP1
+            KS = KS + 1
+            KP1 = KP1 + 1
+            L = L + 1
+            S1 = C(L)
+            DO 110 J=2,KP1
+              L = L + 1
+              S1 = S1*T2 + C(L)
+  110       CONTINUE
+            AP = AP*TFN
+            UPOL(KP1) = AP*S1
+            CR(KS) = BR(KS)*RZDEN
+            RZDEN = RZDEN*RCZ
+            DR(KS) = AR(KS)*RZDEN
+  120     CONTINUE
+          SUMA = UPOL(LRP1)
+          SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32
+          JU = LRP1
+          DO 130 JR=1,LR
+            JU = JU - 1
+            SUMA = SUMA + CR(JR)*UPOL(JU)
+            SUMB = SUMB + DR(JR)*UPOL(JU)
+  130     CONTINUE
+          RDEN=RDEN*RFN2
+          TB = -TB
+          IF (WK(1).GT.0.0E0) TB = ABS(TB)
+          IF (RDEN.LT.TOL) GO TO 131
+          ASUM = ASUM + SUMA*TB
+          BSUM = BSUM + SUMB*TB
+          GO TO 140
+  131     IF(ISETA.EQ.1) GO TO 132
+          IF(ABS(SUMA).LT.TOL) ISETA=1
+          ASUM=ASUM+SUMA*TB
+  132     IF(ISETB.EQ.1) GO TO 133
+          IF(ABS(SUMB).LT.RELB) ISETB=1
+          BSUM=BSUM+SUMB*TB
+  133     IF(ISETA.EQ.1 .AND. ISETB.EQ.1) GO TO 150
+  140   CONTINUE
+  150   TB = WK(5)
+        IF (WK(1).GT.0.0E0) TB = -TB
+        BSUM = BSUM/TB
+C
+  160   CONTINUE
+        CALL FUNJY(WK(6), WK(5), WK(4), FI, DFI)
+        TA=1.0E0/TOL
+        TB=R1MACH(1)*TA*1.0E+3
+        IF(ABS(FI).GT.TB) GO TO 165
+        FI=FI*TA
+        DFI=DFI*TA
+        PHI=PHI*TOL
+  165   CONTINUE
+        Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7)
+        FN = FN - FLGJY
+  170 CONTINUE
+      RETURN
+      END

slatec/atanh.f

@@ -0,0 +1,72 @@
+*DECK ATANH
+      FUNCTION ATANH (X)
+C***BEGIN PROLOGUE  ATANH
+C***PURPOSE  Compute the arc hyperbolic tangent.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C4C
+C***TYPE      SINGLE PRECISION (ATANH-S, DATANH-D, CATANH-C)
+C***KEYWORDS  ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS,
+C             FNLIB, INVERSE HYPERBOLIC TANGENT
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C ATANH(X) computes the arc hyperbolic tangent of X.
+C
+C Series for ATNH       on the interval  0.          to  2.50000D-01
+C                                        with weighted error   6.70E-18
+C                                         log weighted error  17.17
+C                               significant figures required  16.01
+C                                    decimal places required  17.76
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  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  ATANH
+      DIMENSION ATNHCS(15)
+      LOGICAL FIRST
+      SAVE ATNHCS, NTERMS, DXREL, SQEPS, FIRST
+      DATA ATNHCS( 1) /    .0943951023 93195492E0 /
+      DATA ATNHCS( 2) /    .0491984370 55786159E0 /
+      DATA ATNHCS( 3) /    .0021025935 22455432E0 /
+      DATA ATNHCS( 4) /    .0001073554 44977611E0 /
+      DATA ATNHCS( 5) /    .0000059782 67249293E0 /
+      DATA ATNHCS( 6) /    .0000003505 06203088E0 /
+      DATA ATNHCS( 7) /    .0000000212 63743437E0 /
+      DATA ATNHCS( 8) /    .0000000013 21694535E0 /
+      DATA ATNHCS( 9) /    .0000000000 83658755E0 /
+      DATA ATNHCS(10) /    .0000000000 05370503E0 /
+      DATA ATNHCS(11) /    .0000000000 00348665E0 /
+      DATA ATNHCS(12) /    .0000000000 00022845E0 /
+      DATA ATNHCS(13) /    .0000000000 00001508E0 /
+      DATA ATNHCS(14) /    .0000000000 00000100E0 /
+      DATA ATNHCS(15) /    .0000000000 00000006E0 /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  ATANH
+      IF (FIRST) THEN
+         NTERMS = INITS (ATNHCS, 15, 0.1*R1MACH(3))
+         DXREL = SQRT (R1MACH(4))
+         SQEPS = SQRT (3.0*R1MACH(3))
+      ENDIF
+      FIRST = .FALSE.
+C
+      Y = ABS(X)
+      IF (Y .GE. 1.0) CALL XERMSG ('SLATEC', 'ATANH', 'ABS(X) GE 1', 2,
+     +   2)
+C
+      IF (1.0-Y .LT. DXREL) CALL XERMSG ('SLATEC', 'ATANH',
+     +   'ANSWER LT HALF PRECISION BECAUSE ABS(X) TOO NEAR 1', 1, 1)
+C
+      ATANH = X
+      IF (Y.GT.SQEPS .AND. Y.LE.0.5) ATANH = X*(1.0 + CSEVL (8.*X*X-1.,
+     1  ATNHCS, NTERMS))
+      IF (Y.GT.0.5) ATANH = 0.5*LOG((1.0+X)/(1.0-X))
+C
+      RETURN
+      END

slatec/avint.f

@@ -0,0 +1,178 @@
+*DECK AVINT
+      SUBROUTINE AVINT (X, Y, N, XLO, XUP, ANS, IERR)
+C***BEGIN PROLOGUE  AVINT
+C***PURPOSE  Integrate a function tabulated at arbitrarily spaced
+C            abscissas using overlapping parabolas.
+C***LIBRARY   SLATEC
+C***CATEGORY  H2A1B2
+C***TYPE      SINGLE PRECISION (AVINT-S, DAVINT-D)
+C***KEYWORDS  INTEGRATION, QUADRATURE, TABULATED DATA
+C***AUTHOR  Jones, R. E., (SNLA)
+C***DESCRIPTION
+C
+C     Abstract
+C         AVINT integrates a function tabulated at arbitrarily spaced
+C         abscissas.  The limits of integration need not coincide
+C         with the tabulated abscissas.
+C
+C         A method of overlapping parabolas fitted to the data is used
+C         provided that there are at least 3 abscissas between the
+C         limits of integration.  AVINT also handles two special cases.
+C         If the limits of integration are equal, AVINT returns a result
+C         of zero regardless of the number of tabulated values.
+C         If there are only two function values, AVINT uses the
+C         trapezoid rule.
+C
+C     Description of Parameters
+C         The user must dimension all arrays appearing in the call list
+C              X(N), Y(N).
+C
+C         Input--
+C         X    - real array of abscissas, which must be in increasing
+C                order.
+C         Y    - real array of functional values. i.e., Y(I)=FUNC(X(I)).
+C         N    - the integer number of function values supplied.
+C                N .GE. 2 unless XLO = XUP.
+C         XLO  - real lower limit of integration.
+C         XUP  - real upper limit of integration.
+C                Must have XLO .LE. XUP.
+C
+C         Output--
+C         ANS  - computed approximate value of integral
+C         IERR - a status code
+C              --normal code
+C                =1 means the requested integration was performed.
+C              --abnormal codes
+C                =2 means XUP was less than XLO.
+C                =3 means the number of X(I) between XLO and XUP
+C                   (inclusive) was less than 3 and neither of the two
+C                   special cases described in the Abstract occurred.
+C                   No integration was performed.
+C                =4 means the restriction X(I+1) .GT. X(I) was violated.
+C                =5 means the number N of function values was .LT. 2.
+C                ANS is set to zero if IERR=2,3,4,or 5.
+C
+C     AVINT is documented completely in SC-M-69-335
+C     Original program from "Numerical Integration" by Davis &
+C     Rabinowitz.
+C     Adaptation and modifications for Sandia Mathematical Program
+C     Library by Rondall E. Jones.
+C
+C***REFERENCES  R. E. Jones, Approximate integrator of functions
+C                 tabulated at arbitrarily spaced abscissas,
+C                 Report SC-M-69-335, Sandia Laboratories, 1969.
+C***ROUTINES CALLED  XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   690901  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  AVINT
+C
+      DOUBLE PRECISION R3,RP5,SUM,SYL,SYL2,SYL3,SYU,SYU2,SYU3,X1,X2,X3
+     1,X12,X13,X23,TERM1,TERM2,TERM3,A,B,C,CA,CB,CC
+      DIMENSION X(*),Y(*)
+C***FIRST EXECUTABLE STATEMENT  AVINT
+      IERR=1
+      ANS =0.0
+      IF (XLO-XUP) 3,100,200
+    3 IF (N.LT.2) GO TO 215
+      DO 5 I=2,N
+      IF (X(I).LE.X(I-1)) GO TO 210
+      IF (X(I).GT.XUP) GO TO 6
+    5 CONTINUE
+    6 CONTINUE
+      IF (N.GE.3) GO TO 9
+C
+C     SPECIAL N=2 CASE
+      SLOPE = (Y(2)-Y(1))/(X(2)-X(1))
+      FL = Y(1) + SLOPE*(XLO-X(1))
+      FR = Y(2) + SLOPE*(XUP-X(2))
+      ANS = 0.5*(FL+FR)*(XUP-XLO)
+      RETURN
+    9 CONTINUE
+      IF (X(N-2).LT.XLO)  GO TO 205
+      IF (X(3).GT.XUP)    GO TO 205
+      I = 1
+   10 IF (X(I).GE.XLO) GO TO 15
+      I = I+1
+      GO TO 10
+   15 INLFT = I
+      I = N
+   20 IF (X(I).LE.XUP) GO TO 25
+      I = I-1
+      GO TO 20
+   25 INRT = I
+      IF ((INRT-INLFT).LT.2) GO TO 205
+      ISTART = INLFT
+      IF (INLFT.EQ.1) ISTART = 2
+      ISTOP  = INRT
+      IF (INRT.EQ.N)  ISTOP  = N-1
+C
+      R3 = 3.0D0
+      RP5= 0.5D0
+      SUM = 0.0
+      SYL = XLO
+      SYL2= SYL*SYL
+      SYL3= SYL2*SYL
+C
+      DO 50 I=ISTART,ISTOP
+      X1 = X(I-1)
+      X2 = X(I)
+      X3 = X(I+1)
+      X12 = X1-X2
+      X13 = X1-X3
+      X23 = X2-X3
+      TERM1 = DBLE(Y(I-1))/(X12*X13)
+      TERM2 =-DBLE(Y(I)) /(X12*X23)
+      TERM3 = DBLE(Y(I+1))/(X13*X23)
+      A = TERM1+TERM2+TERM3
+      B = -(X2+X3)*TERM1 - (X1+X3)*TERM2 - (X1+X2)*TERM3
+      C = X2*X3*TERM1 + X1*X3*TERM2 + X1*X2*TERM3
+      IF (I-ISTART) 30,30,35
+   30 CA = A
+      CB = B
+      CC = C
+      GO TO 40
+   35 CA = 0.5*(A+CA)
+      CB = 0.5*(B+CB)
+      CC = 0.5*(C+CC)
+   40 SYU = X2
+      SYU2= SYU*SYU
+      SYU3= SYU2*SYU
+      SUM = SUM + CA*(SYU3-SYL3)/R3  + CB*RP5*(SYU2-SYL2) + CC*(SYU-SYL)
+      CA  = A
+      CB  = B
+      CC  = C
+      SYL = SYU
+      SYL2= SYU2
+      SYL3= SYU3
+   50 CONTINUE
+      SYU = XUP
+      ANS = SUM + CA*(SYU**3-SYL3)/R3 + CB*RP5*(SYU**2-SYL2)
+     1  + CC*(SYU-SYL)
+  100 RETURN
+  200 IERR=2
+      CALL XERMSG ('SLATEC', 'AVINT',
+     +   'THE UPPER LIMIT OF INTEGRATION WAS NOT GREATER THAN THE ' //
+     +   'LOWER LIMIT.', 4, 1)
+      RETURN
+  205 IERR=3
+      CALL XERMSG ('SLATEC', 'AVINT',
+     +   'THERE WERE LESS THAN THREE FUNCTION VALUES BETWEEN THE ' //
+     +   'LIMITS OF INTEGRATION.', 4, 1)
+      RETURN
+  210 IERR=4
+      CALL XERMSG ('SLATEC', 'AVINT',
+     +   'THE ABSCISSAS WERE NOT STRICTLY INCREASING.  MUST HAVE ' //
+     +   'X(I-1) .LT. X(I) FOR ALL I.', 4, 1)
+      RETURN
+  215 IERR=5
+      CALL XERMSG ('SLATEC', 'AVINT',
+     +   'LESS THAN TWO FUNCTION VALUES WERE SUPPLIED.', 4, 1)
+      RETURN
+      END

slatec/bakvec.f

@@ -0,0 +1,105 @@
+*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

slatec/balanc.f

@@ -0,0 +1,190 @@
+*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

slatec/balbak.f

@@ -0,0 +1,101 @@
+*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

slatec/bandr.f

@@ -0,0 +1,288 @@
+*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.0E0**(-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

slatec/bandv.f

@@ -0,0 +1,352 @@
+*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

slatec/bcrh.f

@@ -0,0 +1,33 @@
+*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

slatec/bdiff.f

@@ -0,0 +1,36 @@
+*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

slatec/besi.f

@@ -0,0 +1,462 @@
+*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

slatec/besi0.f

@@ -0,0 +1,71 @@
+*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

slatec/besi0e.f

@@ -0,0 +1,129 @@
+*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

slatec/besi1.f

@@ -0,0 +1,76 @@
+*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

slatec/besi1e.f

@@ -0,0 +1,137 @@
+*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

slatec/besj.f

@@ -0,0 +1,504 @@
+*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

slatec/besj0.f

@@ -0,0 +1,136 @@
+*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

slatec/besj1.f

@@ -0,0 +1,138 @@
+*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

slatec/besk.f

@@ -0,0 +1,277 @@
+*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

slatec/besk0.f

@@ -0,0 +1,76 @@
+*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

slatec/besk0e.f

@@ -0,0 +1,119 @@
+*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

slatec/besk1.f

@@ -0,0 +1,80 @@
+*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

slatec/besk1e.f

@@ -0,0 +1,124 @@
+*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

slatec/beskes.f

@@ -0,0 +1,77 @@
+*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

slatec/besknu.f

@@ -0,0 +1,388 @@
+*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

slatec/besks.f

@@ -0,0 +1,50 @@
+*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

slatec/besy.f

@@ -0,0 +1,200 @@
+*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
+      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

slatec/besy0.f

@@ -0,0 +1,141 @@
+*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)
+      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

slatec/besy1.f

@@ -0,0 +1,145 @@
+*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
+      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

slatec/besynu.f

@@ -0,0 +1,353 @@
+*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

slatec/beta.f

@@ -0,0 +1,51 @@
+*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

slatec/betai.f

@@ -0,0 +1,118 @@
+*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

slatec/bfqad.f

@@ -0,0 +1,134 @@
+*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

slatec/bi.f

@@ -0,0 +1,130 @@
+*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

slatec/bie.f

@@ -0,0 +1,206 @@
+*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

slatec/binom.f

@@ -0,0 +1,73 @@
+*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

slatec/bint4.f

@@ -0,0 +1,238 @@
+*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

slatec/bintk.f

@@ -0,0 +1,187 @@
+*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

slatec/bisect.f

@@ -0,0 +1,284 @@
+*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

slatec/bkias.f

@@ -0,0 +1,260 @@
+*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

slatec/bkisr.f

@@ -0,0 +1,86 @@
+*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

slatec/bksol.f

@@ -0,0 +1,45 @@
+*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

slatec/blktr1.f

@@ -0,0 +1,249 @@
+*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

slatec/blktri.f

@@ -0,0 +1,264 @@
+*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

slatec/bndacc.f

@@ -0,0 +1,271 @@
+*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

slatec/bndsol.f

@@ -0,0 +1,255 @@
+*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

slatec/bnfac.f

@@ -0,0 +1,137 @@
+*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

slatec/bnslv.f

@@ -0,0 +1,79 @@
+*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

slatec/bqr.f

@@ -0,0 +1,306 @@
+*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

slatec/bsgq8.f

@@ -0,0 +1,193 @@
+*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

slatec/bskin.f

@@ -0,0 +1,351 @@
+*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

slatec/bspdoc.f

@@ -0,0 +1,296 @@
+*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

slatec/bspdr.f

@@ -0,0 +1,106 @@
+*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

slatec/bspev.f

@@ -0,0 +1,138 @@
+*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

slatec/bsplvd.f

@@ -0,0 +1,70 @@
+*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

slatec/bsplvn.f

@@ -0,0 +1,47 @@
+*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/,(DELTAM(I),I=1,20),(DELTAP(I),I=1,20)/40*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

slatec/bsppp.f

@@ -0,0 +1,95 @@
+*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

slatec/bspvd.f

@@ -0,0 +1,163 @@
+*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

slatec/bspvn.f

@@ -0,0 +1,124 @@
+*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

slatec/bsqad.f

@@ -0,0 +1,144 @@
+*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

slatec/bsrh.f

@@ -0,0 +1,33 @@
+*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

slatec/bvalu.f

@@ -0,0 +1,165 @@
+*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

slatec/bvder.f

@@ -0,0 +1,102 @@
+*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

slatec/bvpor.f

@@ -0,0 +1,294 @@
+*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

slatec/bvsup.f

@@ -0,0 +1,694 @@
+*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

slatec/c0lgmc.f

@@ -0,0 +1,42 @@
+*DECK C0LGMC
+      COMPLEX FUNCTION C0LGMC (Z)
+C***BEGIN PROLOGUE  C0LGMC
+C***PURPOSE  Evaluate (Z+0.5)*LOG((Z+1.)/Z) - 1.0 with relative
+C            accuracy.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C7A
+C***TYPE      COMPLEX (C0LGMC-C)
+C***KEYWORDS  FNLIB, GAMMA FUNCTION, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C Evaluate  (Z+0.5)*LOG((Z+1.0)/Z) - 1.0  with relative error accuracy
+C Let Q = 1.0/Z so that
+C     (Z+0.5)*LOG(1+1/Z) - 1 = (Z+0.5)*(LOG(1+Q) - Q + Q*Q/2) - Q*Q/4
+C        = (Z+0.5)*Q**3*C9LN2R(Q) - Q**2/4,
+C where  C9LN2R  is (LOG(1+Q) - Q + 0.5*Q**2) / Q**3.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  C9LN2R, R1MACH
+C***REVISION HISTORY  (YYMMDD)
+C   780401  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***END PROLOGUE  C0LGMC
+      COMPLEX Z, Q, C9LN2R
+      SAVE RBIG
+      DATA RBIG / 0.0 /
+C***FIRST EXECUTABLE STATEMENT  C0LGMC
+      IF (RBIG.EQ.0.0) RBIG = 1.0/R1MACH(3)
+C
+      CABSZ = ABS(Z)
+      IF (CABSZ.GT.RBIG) C0LGMC = -(Z+0.5)*LOG(Z) - Z
+      IF (CABSZ.GT.RBIG) RETURN
+C
+      Q = 1.0/Z
+      IF (CABSZ.LE.1.23) C0LGMC = (Z+0.5)*LOG(1.0+Q) - 1.0
+      IF (CABSZ.GT.1.23) C0LGMC = ((1.+.5*Q)*C9LN2R(Q) - .25) * Q**2
+C
+      RETURN
+      END

slatec/c1merg.f

@@ -0,0 +1,68 @@
+*DECK C1MERG
+      SUBROUTINE C1MERG (TCOS, I1, M1, I2, M2, I3)
+C***BEGIN PROLOGUE  C1MERG
+C***SUBSIDIARY
+C***PURPOSE  Merge two strings of complex numbers.  Each string is
+C            ascending by the real part.
+C***LIBRARY   SLATEC
+C***TYPE      COMPLEX (S1MERG-S, D1MERG-D, C1MERG-C, I1MERG-I)
+C***AUTHOR  (UNKNOWN)
+C***DESCRIPTION
+C
+C   This subroutine merges two ascending strings of numbers in the
+C   array TCOS.  The first string is of length M1 and starts at
+C   TCOS(I1+1).  The second string is of length M2 and starts at
+C   TCOS(I2+1).  The merged string goes into TCOS(I3+1).  The ordering
+C   is on the real part.
+C
+C***SEE ALSO  CMGNBN
+C***ROUTINES CALLED  CCOPY
+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   910408  Modified to use IF-THEN-ELSE.  Make it look like MERGE
+C           which was modified earlier due to compiler problems on
+C           the IBM RS6000.  (RWC)
+C   920130  Code name changed from CMPMRG to C1MERG.  (WRB)
+C***END PROLOGUE  C1MERG
+      INTEGER I1, I2, I3, M1, M2
+      COMPLEX TCOS(*)
+C
+      INTEGER J1, J2, J3
+C
+C***FIRST EXECUTABLE STATEMENT  C1MERG
+      IF (M1.EQ.0 .AND. M2.EQ.0) RETURN
+C
+      IF (M1.EQ.0 .AND. M2.NE.0) THEN
+         CALL CCOPY (M2, TCOS(I2+1), 1, TCOS(I3+1), 1)
+         RETURN
+      ENDIF
+C
+      IF (M1.NE.0 .AND. M2.EQ.0) THEN
+         CALL CCOPY (M1, TCOS(I1+1), 1, TCOS(I3+1), 1)
+         RETURN
+      ENDIF
+C
+      J1 = 1
+      J2 = 1
+      J3 = 1
+C
+   10 IF (REAL(TCOS(J1+I1)) .LE. REAL(TCOS(I2+J2))) THEN
+         TCOS(I3+J3) = TCOS(I1+J1)
+         J1 = J1+1
+         IF (J1 .GT. M1) THEN
+            CALL CCOPY (M2-J2+1, TCOS(I2+J2), 1, TCOS(I3+J3+1), 1)
+            RETURN
+         ENDIF
+      ELSE
+         TCOS(I3+J3) = TCOS(I2+J2)
+         J2 = J2+1
+         IF (J2 .GT. M2) THEN
+            CALL CCOPY (M1-J1+1, TCOS(I1+J1), 1, TCOS(I3+J3+1), 1)
+            RETURN
+         ENDIF
+      ENDIF
+      J3 = J3+1
+      GO TO 10
+      END

slatec/c9lgmc.f

@@ -0,0 +1,89 @@
+*DECK C9LGMC
+      COMPLEX FUNCTION C9LGMC (ZIN)
+C***BEGIN PROLOGUE  C9LGMC
+C***SUBSIDIARY
+C***PURPOSE  Compute the log gamma correction factor so that
+C            LOG(CGAMMA(Z)) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z
+C            + C9LGMC(Z).
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C7A
+C***TYPE      COMPLEX (R9LGMC-S, D9LGMC-D, C9LGMC-C)
+C***KEYWORDS  COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB,
+C             LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C Compute the LOG GAMMA correction term for large ABS(Z) when REAL(Z)
+C .GE. 0.0 and for large ABS(AIMAG(Y)) when REAL(Z) .LT. 0.0.  We find
+C C9LGMC so that
+C   LOG(Z) = 0.5*LOG(2.*PI) + (Z-0.5)*LOG(Z) - Z + C9LGMC(Z)
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  R1MACH, XERMSG
+C***REVISION HISTORY  (YYMMDD)
+C   780401  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
+C***END PROLOGUE  C9LGMC
+      COMPLEX ZIN, Z, Z2INV
+      DIMENSION BERN(11)
+      LOGICAL FIRST
+      SAVE BERN, NTERM, BOUND, XBIG, XMAX, FIRST
+      DATA BERN( 1) /    .08333333333 3333333E0   /
+      DATA BERN( 2) /   -.002777777777 7777778E0  /
+      DATA BERN( 3) /    .0007936507936 5079365E0 /
+      DATA BERN( 4) /   -.0005952380952 3809524E0 /
+      DATA BERN( 5) /    .0008417508417 5084175E0 /
+      DATA BERN( 6) /   -.001917526917 5269175E0  /
+      DATA BERN( 7) /    .006410256410 2564103E0  /
+      DATA BERN( 8) /   -.02955065359 4771242E0   /
+      DATA BERN( 9) /    .1796443723 6883057E0    /
+      DATA BERN(10) /  -1.392432216 9059011E0     /
+      DATA BERN(11) /  13.40286404 4168392E0      /
+      DATA FIRST /.TRUE./
+C***FIRST EXECUTABLE STATEMENT  C9LGMC
+      IF (FIRST) THEN
+         NTERM = -0.30*LOG(R1MACH(3))
+         BOUND = 0.1170*NTERM*(0.1*R1MACH(3))**(-1./(2*NTERM-1))
+         XBIG = 1.0/SQRT(R1MACH(3))
+         XMAX = EXP (MIN(LOG(R1MACH(2)/12.0), -LOG(12.*R1MACH(1))) )
+      ENDIF
+      FIRST = .FALSE.
+C
+      Z = ZIN
+      X = REAL (Z)
+      Y = AIMAG(Z)
+      CABSZ = ABS(Z)
+C
+      IF (X .LT. 0.0 .AND. ABS(Y) .LT. BOUND) CALL XERMSG ('SLATEC',
+     +   'C9LGMC', 'NOT VALID FOR NEGATIVE REAL(Z) AND SMALL ' //
+     +   'ABS(AIMAG(Z))', 2, 2)
+      IF (CABSZ .LT. BOUND) CALL XERMSG ('SLATEC', 'C9LGMC',
+     +   'NOT VALID FOR SMALL ABS(Z)', 3, 2)
+C
+      IF (CABSZ.GE.XMAX) GO TO 50
+C
+      IF (CABSZ.GE.XBIG) C9LGMC = 1.0/(12.0*Z)
+      IF (CABSZ.GE.XBIG) RETURN
+C
+      Z2INV = 1.0/Z**2
+      C9LGMC = (0.0, 0.0)
+      DO 40 I=1,NTERM
+        NDX = NTERM + 1 - I
+        C9LGMC = BERN(NDX) + C9LGMC*Z2INV
+ 40   CONTINUE
+C
+      C9LGMC = C9LGMC/Z
+      RETURN
+C
+ 50   C9LGMC = (0.0, 0.0)
+      CALL XERMSG ('SLATEC', 'C9LGMC', 'Z SO BIG C9LGMC UNDERFLOWS', 1,
+     +   1)
+      RETURN
+C
+      END

slatec/c9ln2r.f

@@ -0,0 +1,73 @@
+*DECK C9LN2R
+      COMPLEX FUNCTION C9LN2R (Z)
+C***BEGIN PROLOGUE  C9LN2R
+C***SUBSIDIARY
+C***PURPOSE  Evaluate LOG(1+Z) from second order relative accuracy so
+C            that  LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z).
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C4B
+C***TYPE      COMPLEX (R9LN2R-S, D9LN2R-D, C9LN2R-C)
+C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM, SECOND ORDER
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C Evaluate  LOG(1+Z)  from 2-nd order with relative error accuracy so
+C that     LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z).
+C
+C Now  LOG(1+Z) = 0.5*LOG(1+2*X+ABS(Z)**2) + I*CARG(1+Z),
+C where X = REAL(Z)  and  Y = AIMAG(Z).
+C We find
+C     Z**3 * C9LN2R(Z) = -X*ABS(Z)**2 - 0.25*ABS(Z)**4
+C        + (2*X+ABS(Z)**2)**3 * R9LN2R(2*X+ABS(Z)**2)
+C        + I * (CARG(1+Z) + (X-1)*Y)
+C The imaginary part must be evaluated carefully as
+C     (ATAN(Y/(1+X)) - Y/(1+X)) + Y/(1+X) - (1-X)*Y
+C       = (Y/(1+X))**3 * R9ATN1(Y/(1+X)) + X**2*Y/(1+X)
+C
+C Now we divide through by Z**3 carefully.  Write
+C     1/Z**3 = (X-I*Y)/ABS(Z)**3 * (1/ABS(Z)**3)
+C then   C9LN2R(Z) = ((X-I*Y)/ABS(Z))**3 * (-X/ABS(Z) - ABS(Z)/4
+C        + 0.5*((2*X+ABS(Z)**2)/ABS(Z))**3 * R9LN2R(2*X+ABS(Z)**2)
+C        + I*Y/(ABS(Z)*(1+X)) * ((X/ABS(Z))**2 +
+C          + (Y/(ABS(Z)*(1+X)))**2 * R9ATN1(Y/(1+X)) ) )
+C
+C If we let  XZ = X/ABS(Z)  and  YZ = Y/ABS(Z)  we may write
+C     C9LN2R(Z) = (XZ-I*YZ)**3 * (-XZ - ABS(Z)/4
+C        + 0.5*(2*XZ+ABS(Z))**3 * R9LN2R(2*X+ABS(Z)**2)
+C        + I*YZ/(1+X) * (XZ**2 + (YZ/(1+X))**2*R9ATN1(Y/(1+X)) ))
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  R9ATN1, R9LN2R
+C***REVISION HISTORY  (YYMMDD)
+C   780401  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   900720  Routine changed from user-callable to subsidiary.  (WRB)
+C***END PROLOGUE  C9LN2R
+      COMPLEX Z
+C***FIRST EXECUTABLE STATEMENT  C9LN2R
+      X = REAL (Z)
+      Y = AIMAG (Z)
+C
+      CABSZ = ABS(Z)
+      IF (CABSZ.GT.0.8125) GO TO 20
+C
+      C9LN2R = CMPLX (1.0/3.0, 0.0)
+      IF (CABSZ.EQ.0.0) RETURN
+C
+      XZ = X/CABSZ
+      YZ = Y/CABSZ
+C
+      ARG = 2.0*XZ + CABSZ
+      RPART = 0.5*ARG**3*R9LN2R(CABSZ*ARG) - XZ - 0.25*CABSZ
+      Y1X = YZ/(1.0+X)
+      AIPART = Y1X * (XZ**2 + Y1X**2*R9ATN1(CABSZ*Y1X) )
+C
+      C9LN2R = CMPLX(XZ,-YZ)**3 * CMPLX(RPART,AIPART)
+      RETURN
+C
+ 20   C9LN2R = (LOG(1.0+Z) - Z*(1.0-0.5*Z)) / Z**3
+      RETURN
+C
+      END

slatec/cacai.f

@@ -0,0 +1,101 @@
+*DECK CACAI
+      SUBROUTINE CACAI (Z, FNU, KODE, MR, N, Y, NZ, RL, TOL, ELIM, ALIM)
+C***BEGIN PROLOGUE  CACAI
+C***SUBSIDIARY
+C***PURPOSE  Subsidiary to CAIRY
+C***LIBRARY   SLATEC
+C***TYPE      ALL (CACAI-A, ZACAI-A)
+C***AUTHOR  Amos, D. E., (SNL)
+C***DESCRIPTION
+C
+C     CACAI APPLIES THE ANALYTIC CONTINUATION FORMULA
+C
+C         K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
+C                 MP=PI*MR*CMPLX(0.0,1.0)
+C
+C     TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
+C     HALF Z PLANE FOR USE WITH CAIRY WHERE FNU=1/3 OR 2/3 AND N=1.
+C     CACAI IS THE SAME AS CACON WITH THE PARTS FOR LARGER ORDERS AND
+C     RECURRENCE REMOVED. A RECURSIVE CALL TO CACON CAN RESULT IF CACON
+C     IS CALLED FROM CAIRY.
+C
+C***SEE ALSO  CAIRY
+C***ROUTINES CALLED  CASYI, CBKNU, CMLRI, CS1S2, CSERI, R1MACH
+C***REVISION HISTORY  (YYMMDD)
+C   830501  DATE WRITTEN
+C   910415  Prologue converted to Version 4.0 format.  (BAB)
+C***END PROLOGUE  CACAI
+      COMPLEX CSGN, CSPN, C1, C2, Y, Z, ZN, CY
+      REAL ALIM, ARG, ASCLE, AZ, CPN, DFNU, ELIM, FMR, FNU, PI, RL,
+     * SGN, SPN, TOL, YY, R1MACH
+      INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ
+      DIMENSION Y(N), CY(2)
+      DATA PI / 3.14159265358979324E0 /
+C***FIRST EXECUTABLE STATEMENT  CACAI
+      NZ = 0
+      ZN = -Z
+      AZ = ABS(Z)
+      NN = N
+      DFNU = FNU + (N-1)
+      IF (AZ.LE.2.0E0) GO TO 10
+      IF (AZ*AZ*0.25E0.GT.DFNU+1.0E0) GO TO 20
+   10 CONTINUE
+C-----------------------------------------------------------------------
+C     POWER SERIES FOR THE I FUNCTION
+C-----------------------------------------------------------------------
+      CALL CSERI(ZN, FNU, KODE, NN, Y, NW, TOL, ELIM, ALIM)
+      GO TO 40
+   20 CONTINUE
+      IF (AZ.LT.RL) GO TO 30
+C-----------------------------------------------------------------------
+C     ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION
+C-----------------------------------------------------------------------
+      CALL CASYI(ZN, FNU, KODE, NN, Y, NW, RL, TOL, ELIM, ALIM)
+      IF (NW.LT.0) GO TO 70
+      GO TO 40
+   30 CONTINUE
+C-----------------------------------------------------------------------
+C     MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION
+C-----------------------------------------------------------------------
+      CALL CMLRI(ZN, FNU, KODE, NN, Y, NW, TOL)
+      IF(NW.LT.0) GO TO 70
+   40 CONTINUE
+C-----------------------------------------------------------------------
+C     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
+C-----------------------------------------------------------------------
+      CALL CBKNU(ZN, FNU, KODE, 1, CY, NW, TOL, ELIM, ALIM)
+      IF (NW.NE.0) GO TO 70
+      FMR = MR
+      SGN = -SIGN(PI,FMR)
+      CSGN = CMPLX(0.0E0,SGN)
+      IF (KODE.EQ.1) GO TO 50
+      YY = -AIMAG(ZN)
+      CPN = COS(YY)
+      SPN = SIN(YY)
+      CSGN = CSGN*CMPLX(CPN,SPN)
+   50 CONTINUE
+C-----------------------------------------------------------------------
+C     CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
+C     WHEN FNU IS LARGE
+C-----------------------------------------------------------------------
+      INU = FNU
+      ARG = (FNU-INU)*SGN
+      CPN = COS(ARG)
+      SPN = SIN(ARG)
+      CSPN = CMPLX(CPN,SPN)
+      IF (MOD(INU,2).EQ.1) CSPN = -CSPN
+      C1 = CY(1)
+      C2 = Y(1)
+      IF (KODE.EQ.1) GO TO 60
+      IUF = 0
+      ASCLE = 1.0E+3*R1MACH(1)/TOL
+      CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF)
+      NZ = NZ + NW
+   60 CONTINUE
+      Y(1) = CSPN*C1 + CSGN*C2
+      RETURN
+   70 CONTINUE
+      NZ = -1
+      IF(NW.EQ.(-2)) NZ=-2
+      RETURN
+      END

slatec/cacon.f

@@ -0,0 +1,160 @@
+*DECK CACON
+      SUBROUTINE CACON (Z, FNU, KODE, MR, N, Y, NZ, RL, FNUL, TOL, ELIM,
+     +   ALIM)
+C***BEGIN PROLOGUE  CACON
+C***SUBSIDIARY
+C***PURPOSE  Subsidiary to CBESH and CBESK
+C***LIBRARY   SLATEC
+C***TYPE      ALL (CACON-A, ZACON-A)
+C***AUTHOR  Amos, D. E., (SNL)
+C***DESCRIPTION
+C
+C     CACON APPLIES THE ANALYTIC CONTINUATION FORMULA
+C
+C         K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
+C                 MP=PI*MR*CMPLX(0.0,1.0)
+C
+C     TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
+C     HALF Z PLANE
+C
+C***SEE ALSO  CBESH, CBESK
+C***ROUTINES CALLED  CBINU, CBKNU, CS1S2, R1MACH
+C***REVISION HISTORY  (YYMMDD)
+C   830501  DATE WRITTEN
+C   910415  Prologue converted to Version 4.0 format.  (BAB)
+C***END PROLOGUE  CACON
+      COMPLEX CK, CONE, CS, CSCL, CSCR, CSGN, CSPN, CSS, CSR, C1, C2,
+     * RZ, SC1, SC2, ST, S1, S2, Y, Z, ZN, CY
+      REAL ALIM, ARG, ASCLE, AS2, BSCLE, BRY, CPN, C1I, C1M, C1R, ELIM,
+     * FMR, FNU, FNUL, PI, RL, SGN, SPN, TOL, YY, R1MACH
+      INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ
+      DIMENSION Y(N), CY(2), CSS(3), CSR(3), BRY(3)
+      DATA PI / 3.14159265358979324E0 /
+      DATA CONE / (1.0E0,0.0E0) /
+C***FIRST EXECUTABLE STATEMENT  CACON
+      NZ = 0
+      ZN = -Z
+      NN = N
+      CALL CBINU(ZN, FNU, KODE, NN, Y, NW, RL, FNUL, TOL, ELIM, ALIM)
+      IF (NW.LT.0) GO TO 80
+C-----------------------------------------------------------------------
+C     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
+C-----------------------------------------------------------------------
+      NN = MIN(2,N)
+      CALL CBKNU(ZN, FNU, KODE, NN, CY, NW, TOL, ELIM, ALIM)
+      IF (NW.NE.0) GO TO 80
+      S1 = CY(1)
+      FMR = MR
+      SGN = -SIGN(PI,FMR)
+      CSGN = CMPLX(0.0E0,SGN)
+      IF (KODE.EQ.1) GO TO 10
+      YY = -AIMAG(ZN)
+      CPN = COS(YY)
+      SPN = SIN(YY)
+      CSGN = CSGN*CMPLX(CPN,SPN)
+   10 CONTINUE
+C-----------------------------------------------------------------------
+C     CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
+C     WHEN FNU IS LARGE
+C-----------------------------------------------------------------------
+      INU = FNU
+      ARG = (FNU-INU)*SGN
+      CPN = COS(ARG)
+      SPN = SIN(ARG)
+      CSPN = CMPLX(CPN,SPN)
+      IF (MOD(INU,2).EQ.1) CSPN = -CSPN
+      IUF = 0
+      C1 = S1
+      C2 = Y(1)
+      ASCLE = 1.0E+3*R1MACH(1)/TOL
+      IF (KODE.EQ.1) GO TO 20
+      CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF)
+      NZ = NZ + NW
+      SC1 = C1
+   20 CONTINUE
+      Y(1) = CSPN*C1 + CSGN*C2
+      IF (N.EQ.1) RETURN
+      CSPN = -CSPN
+      S2 = CY(2)
+      C1 = S2
+      C2 = Y(2)
+      IF (KODE.EQ.1) GO TO 30
+      CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF)
+      NZ = NZ + NW
+      SC2 = C1
+   30 CONTINUE
+      Y(2) = CSPN*C1 + CSGN*C2
+      IF (N.EQ.2) RETURN
+      CSPN = -CSPN
+      RZ = CMPLX(2.0E0,0.0E0)/ZN
+      CK = CMPLX(FNU+1.0E0,0.0E0)*RZ
+C-----------------------------------------------------------------------
+C     SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS
+C-----------------------------------------------------------------------
+      CSCL = CMPLX(1.0E0/TOL,0.0E0)
+      CSCR = CMPLX(TOL,0.0E0)
+      CSS(1) = CSCL
+      CSS(2) = CONE
+      CSS(3) = CSCR
+      CSR(1) = CSCR
+      CSR(2) = CONE
+      CSR(3) = CSCL
+      BRY(1) = ASCLE
+      BRY(2) = 1.0E0/ASCLE
+      BRY(3) = R1MACH(2)
+      AS2 = ABS(S2)
+      KFLAG = 2
+      IF (AS2.GT.BRY(1)) GO TO 40
+      KFLAG = 1
+      GO TO 50
+   40 CONTINUE
+      IF (AS2.LT.BRY(2)) GO TO 50
+      KFLAG = 3
+   50 CONTINUE
+      BSCLE = BRY(KFLAG)
+      S1 = S1*CSS(KFLAG)
+      S2 = S2*CSS(KFLAG)
+      CS = CSR(KFLAG)
+      DO 70 I=3,N
+        ST = S2
+        S2 = CK*S2 + S1
+        S1 = ST
+        C1 = S2*CS
+        ST = C1
+        C2 = Y(I)
+        IF (KODE.EQ.1) GO TO 60
+        IF (IUF.LT.0) GO TO 60
+        CALL CS1S2(ZN, C1, C2, NW, ASCLE, ALIM, IUF)
+        NZ = NZ + NW
+        SC1 = SC2
+        SC2 = C1
+        IF (IUF.NE.3) GO TO 60
+        IUF = -4
+        S1 = SC1*CSS(KFLAG)
+        S2 = SC2*CSS(KFLAG)
+        ST = SC2
+   60   CONTINUE
+        Y(I) = CSPN*C1 + CSGN*C2
+        CK = CK + RZ
+        CSPN = -CSPN
+        IF (KFLAG.GE.3) GO TO 70
+        C1R = REAL(C1)
+        C1I = AIMAG(C1)
+        C1R = ABS(C1R)
+        C1I = ABS(C1I)
+        C1M = MAX(C1R,C1I)
+        IF (C1M.LE.BSCLE) GO TO 70
+        KFLAG = KFLAG + 1
+        BSCLE = BRY(KFLAG)
+        S1 = S1*CS
+        S2 = ST
+        S1 = S1*CSS(KFLAG)
+        S2 = S2*CSS(KFLAG)
+        CS = CSR(KFLAG)
+   70 CONTINUE
+      RETURN
+   80 CONTINUE
+      NZ = -1
+      IF(NW.EQ.(-2)) NZ=-2
+      RETURN
+      END

slatec/cacos.f

@@ -0,0 +1,30 @@
+*DECK CACOS
+      COMPLEX FUNCTION CACOS (Z)
+C***BEGIN PROLOGUE  CACOS
+C***PURPOSE  Compute the complex arc cosine.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C4A
+C***TYPE      COMPLEX (CACOS-C)
+C***KEYWORDS  ARC COSINE, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C CACOS(Z) calculates the complex trigonometric arc cosine of Z.
+C The result is in units of radians, and the real part is in the
+C first or second quadrant.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  CASIN
+C***REVISION HISTORY  (YYMMDD)
+C   770401  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C***END PROLOGUE  CACOS
+      COMPLEX Z, CASIN
+      SAVE PI2
+      DATA PI2 /1.5707963267 9489661923E0/
+C***FIRST EXECUTABLE STATEMENT  CACOS
+      CACOS = PI2 - CASIN (Z)
+C
+      RETURN
+      END

slatec/cacosh.f

@@ -0,0 +1,29 @@
+*DECK CACOSH
+      COMPLEX FUNCTION CACOSH (Z)
+C***BEGIN PROLOGUE  CACOSH
+C***PURPOSE  Compute the arc hyperbolic cosine.
+C***LIBRARY   SLATEC (FNLIB)
+C***CATEGORY  C4C
+C***TYPE      COMPLEX (ACOSH-S, DACOSH-D, CACOSH-C)
+C***KEYWORDS  ACOSH, ARC HYPERBOLIC COSINE, ELEMENTARY FUNCTIONS, FNLIB,
+C             INVERSE HYPERBOLIC COSINE
+C***AUTHOR  Fullerton, W., (LANL)
+C***DESCRIPTION
+C
+C CACOSH(Z) calculates the complex arc hyperbolic cosine of Z.
+C
+C***REFERENCES  (NONE)
+C***ROUTINES CALLED  CACOS
+C***REVISION HISTORY  (YYMMDD)
+C   770401  DATE WRITTEN
+C   861211  REVISION DATE from Version 3.2
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C***END PROLOGUE  CACOSH
+      COMPLEX Z, CI, CACOS
+      SAVE CI
+      DATA CI /(0.,1.)/
+C***FIRST EXECUTABLE STATEMENT  CACOSH
+      CACOSH = CI*CACOS(Z)
+C
+      RETURN
+      END

slatec/cairy.f

@@ -0,0 +1,342 @@
+*DECK CAIRY
+      SUBROUTINE CAIRY (Z, ID, KODE, AI, NZ, IERR)
+C***BEGIN PROLOGUE  CAIRY
+C***PURPOSE  Compute the Airy function Ai(z) or its derivative dAi/dz
+C            for complex argument z.  A scaling option is available
+C            to help avoid underflow and overflow.
+C***LIBRARY   SLATEC
+C***CATEGORY  C10D
+C***TYPE      COMPLEX (CAIRY-C, ZAIRY-C)
+C***KEYWORDS  AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD,
+C             BESSEL FUNCTION OF ORDER TWO THIRDS
+C***AUTHOR  Amos, D. E., (SNL)
+C***DESCRIPTION
+C
+C         On KODE=1, CAIRY computes the complex Airy function Ai(z)
+C         or its derivative dAi/dz on ID=0 or ID=1 respectively. On
+C         KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz
+C         is provided to remove the exponential decay in -pi/3<arg(z)
+C         <pi/3 and the exponential growth in pi/3<abs(arg(z))<pi where
+C         zeta=(2/3)*z**(3/2).
+C
+C         While the Airy functions Ai(z) and dAi/dz are analytic in
+C         the whole z-plane, the corresponding scaled functions defined
+C         for KODE=2 have a cut along the negative real axis.
+C
+C         Input
+C           Z      - Argument of type COMPLEX
+C           ID     - Order of derivative, ID=0 or ID=1
+C           KODE   - A parameter to indicate the scaling option
+C                    KODE=1  returns
+C                            AI=Ai(z)  on ID=0
+C                            AI=dAi/dz on ID=1
+C                            at z=Z
+C                        =2  returns
+C                            AI=exp(zeta)*Ai(z)  on ID=0
+C                            AI=exp(zeta)*dAi/dz on ID=1
+C                            at z=Z where zeta=(2/3)*z**(3/2)
+C
+C         Output
+C           AI     - Result of type COMPLEX
+C           NZ     - Underflow indicator
+C                    NZ=0    Normal return
+C                    NZ=1    AI=0 due to underflow in
+C                            -pi/3<arg(Z)<pi/3 on KODE=1
+C           IERR   - Error flag
+C                    IERR=0  Normal return     - COMPUTATION COMPLETED
+C                    IERR=1  Input error       - NO COMPUTATION
+C                    IERR=2  Overflow          - NO COMPUTATION
+C                            (Re(Z) too large with KODE=1)
+C                    IERR=3  Precision warning - COMPUTATION COMPLETED
+C                            (Result has less than half precision)
+C                    IERR=4  Precision error   - NO COMPUTATION
+C                            (Result has no precision)
+C                    IERR=5  Algorithmic error - NO COMPUTATION
+C                            (Termination condition not met)
+C
+C *Long Description:
+C
+C         Ai(z) and dAi/dz are computed from K Bessel functions by
+C
+C                Ai(z) =  c*sqrt(z)*K(1/3,zeta)
+C               dAi/dz = -c*   z   *K(2/3,zeta)
+C                    c =  1/(pi*sqrt(3))
+C                 zeta =  (2/3)*z**(3/2)
+C
+C         when abs(z)>1 and from power series when abs(z)<=1.
+C
+C         In most complex variable computation, one must evaluate ele-
+C         mentary functions.  When the magnitude of Z is large, losses
+C         of significance by argument reduction occur.  Consequently, if
+C         the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR),
+C         then losses exceeding half precision are likely and an error
+C         flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF.
+C         Also, if the magnitude of ZETA is larger than U2=0.5/UR, then
+C         all significance is lost and IERR=4.  In order to use the INT
+C         function, ZETA must be further restricted not to exceed
+C         U3=I1MACH(9)=LARGEST INTEGER.  Thus, the magnitude of ZETA
+C         must be restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2,
+C         and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single
+C         precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision.
+C         This makes U2 limiting is single precision and U3 limiting
+C         in double precision.  This means that the magnitude of Z
+C         cannot exceed approximately 3.4E+4 in single precision and
+C         2.1E+6 in double precision.  This also means that one can
+C         expect to retain, in the worst cases on 32-bit machines,
+C         no digits in single precision and only 6 digits in double
+C         precision.
+C
+C         The approximate relative error in the magnitude of a complex
+C         Bessel function can be expressed as P*10**S where P=MAX(UNIT
+C         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
+C         sents the increase in error due to argument reduction in the
+C         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
+C         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
+C         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
+C         have only absolute accuracy.  This is most likely to occur
+C         when one component (in magnitude) is larger than the other by
+C         several orders of magnitude.  If one component is 10**K larger
+C         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
+C         0) significant digits; or, stated another way, when K exceeds
+C         the exponent of P, no significant digits remain in the smaller
+C         component.  However, the phase angle retains absolute accuracy
+C         because, in complex arithmetic with precision P, the smaller
+C         component will not (as a rule) decrease below P times the
+C         magnitude of the larger component. In these extreme cases,
+C         the principal phase angle is on the order of +P, -P, PI/2-P,
+C         or -PI/2+P.
+C
+C***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
+C                 matical Functions, National Bureau of Standards
+C                 Applied Mathematics Series 55, U. S. Department
+C                 of Commerce, Tenth Printing (1972) or later.
+C               2. D. E. Amos, Computation of Bessel Functions of
+C                 Complex Argument and Large Order, Report SAND83-0643,
+C                 Sandia National Laboratories, Albuquerque, NM, May
+C                 1983.
+C               3. D. E. Amos, A Subroutine Package for Bessel Functions
+C                 of a Complex Argument and Nonnegative Order, Report
+C                 SAND85-1018, Sandia National Laboratory, Albuquerque,
+C                 NM, May 1985.
+C               4. D. E. Amos, A portable package for Bessel functions
+C                 of a complex argument and nonnegative order, ACM
+C                 Transactions on Mathematical Software, 12 (September
+C                 1986), pp. 265-273.
+C
+C***ROUTINES CALLED  CACAI, CBKNU, I1MACH, R1MACH
+C***REVISION HISTORY  (YYMMDD)
+C   830501  DATE WRITTEN
+C   890801  REVISION DATE from Version 3.2
+C   910415  Prologue converted to Version 4.0 format.  (BAB)
+C   920128  Category corrected.  (WRB)
+C   920811  Prologue revised.  (DWL)
+C***END PROLOGUE  CAIRY
+      COMPLEX AI, CONE, CSQ, CY, S1, S2, TRM1, TRM2, Z, ZTA, Z3
+      REAL AA, AD, AK, ALIM, ATRM, AZ, AZ3, BK, CK, COEF, C1, C2, DIG,
+     * DK, D1, D2, ELIM, FID, FNU, RL, R1M5, SFAC, TOL, TTH, ZI, ZR,
+     * Z3I, Z3R, R1MACH, BB, ALAZ
+      INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH
+      DIMENSION CY(1)
+      DATA TTH, C1, C2, COEF /6.66666666666666667E-01,
+     * 3.55028053887817240E-01,2.58819403792806799E-01,
+     * 1.83776298473930683E-01/
+      DATA  CONE / (1.0E0,0.0E0) /
+C***FIRST EXECUTABLE STATEMENT  CAIRY
+      IERR = 0
+      NZ=0
+      IF (ID.LT.0 .OR. ID.GT.1) IERR=1
+      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
+      IF (IERR.NE.0) RETURN
+      AZ = ABS(Z)
+      TOL = MAX(R1MACH(4),1.0E-18)
+      FID = ID
+      IF (AZ.GT.1.0E0) GO TO 60
+C-----------------------------------------------------------------------
+C     POWER SERIES FOR ABS(Z).LE.1.
+C-----------------------------------------------------------------------
+      S1 = CONE
+      S2 = CONE
+      IF (AZ.LT.TOL) GO TO 160
+      AA = AZ*AZ
+      IF (AA.LT.TOL/AZ) GO TO 40
+      TRM1 = CONE
+      TRM2 = CONE
+      ATRM = 1.0E0
+      Z3 = Z*Z*Z
+      AZ3 = AZ*AA
+      AK = 2.0E0 + FID
+      BK = 3.0E0 - FID - FID
+      CK = 4.0E0 - FID
+      DK = 3.0E0 + FID + FID
+      D1 = AK*DK
+      D2 = BK*CK
+      AD = MIN(D1,D2)
+      AK = 24.0E0 + 9.0E0*FID
+      BK = 30.0E0 - 9.0E0*FID
+      Z3R = REAL(Z3)
+      Z3I = AIMAG(Z3)
+      DO 30 K=1,25
+        TRM1 = TRM1*CMPLX(Z3R/D1,Z3I/D1)
+        S1 = S1 + TRM1
+        TRM2 = TRM2*CMPLX(Z3R/D2,Z3I/D2)
+        S2 = S2 + TRM2
+        ATRM = ATRM*AZ3/AD
+        D1 = D1 + AK
+        D2 = D2 + BK
+        AD = MIN(D1,D2)
+        IF (ATRM.LT.TOL*AD) GO TO 40
+        AK = AK + 18.0E0
+        BK = BK + 18.0E0
+   30 CONTINUE
+   40 CONTINUE
+      IF (ID.EQ.1) GO TO 50
+      AI = S1*CMPLX(C1,0.0E0) - Z*S2*CMPLX(C2,0.0E0)
+      IF (KODE.EQ.1) RETURN
+      ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0)
+      AI = AI*CEXP(ZTA)
+      RETURN
+   50 CONTINUE
+      AI = -S2*CMPLX(C2,0.0E0)
+      IF (AZ.GT.TOL) AI = AI + Z*Z*S1*CMPLX(C1/(1.0E0+FID),0.0E0)
+      IF (KODE.EQ.1) RETURN
+      ZTA = Z*CSQRT(Z)*CMPLX(TTH,0.0E0)
+      AI = AI*CEXP(ZTA)
+      RETURN
+C-----------------------------------------------------------------------
+C     CASE FOR ABS(Z).GT.1.0
+C-----------------------------------------------------------------------
+   60 CONTINUE
+      FNU = (1.0E0+FID)/3.0E0
+C-----------------------------------------------------------------------
+C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
+C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
+C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
+C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
+C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
+C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
+C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
+C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
+C-----------------------------------------------------------------------
+      K1 = I1MACH(12)
+      K2 = I1MACH(13)
+      R1M5 = R1MACH(5)
+      K = MIN(ABS(K1),ABS(K2))
+      ELIM = 2.303E0*(K*R1M5-3.0E0)
+      K1 = I1MACH(11) - 1
+      AA = R1M5*K1
+      DIG = MIN(AA,18.0E0)
+      AA = AA*2.303E0
+      ALIM = ELIM + MAX(-AA,-41.45E0)
+      RL = 1.2E0*DIG + 3.0E0
+      ALAZ=ALOG(AZ)
+C-----------------------------------------------------------------------
+C     TEST FOR RANGE
+C-----------------------------------------------------------------------
+      AA=0.5E0/TOL
+      BB=I1MACH(9)*0.5E0
+      AA=MIN(AA,BB)
+      AA=AA**TTH
+      IF (AZ.GT.AA) GO TO 260
+      AA=SQRT(AA)
+      IF (AZ.GT.AA) IERR=3
+      CSQ=CSQRT(Z)
+      ZTA=Z*CSQ*CMPLX(TTH,0.0E0)
+C-----------------------------------------------------------------------
+C     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
+C-----------------------------------------------------------------------
+      IFLAG = 0
+      SFAC = 1.0E0
+      ZI = AIMAG(Z)
+      ZR = REAL(Z)
+      AK = AIMAG(ZTA)
+      IF (ZR.GE.0.0E0) GO TO 70
+      BK = REAL(ZTA)
+      CK = -ABS(BK)
+      ZTA = CMPLX(CK,AK)
+   70 CONTINUE
+      IF (ZI.NE.0.0E0) GO TO 80
+      IF (ZR.GT.0.0E0) GO TO 80
+      ZTA = CMPLX(0.0E0,AK)
+   80 CONTINUE
+      AA = REAL(ZTA)
+      IF (AA.GE.0.0E0 .AND. ZR.GT.0.0E0) GO TO 100
+      IF (KODE.EQ.2) GO TO 90
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST
+C-----------------------------------------------------------------------
+      IF (AA.GT.(-ALIM)) GO TO 90
+      AA = -AA + 0.25E0*ALAZ
+      IFLAG = 1
+      SFAC = TOL
+      IF (AA.GT.ELIM) GO TO 240
+   90 CONTINUE
+C-----------------------------------------------------------------------
+C     CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2
+C-----------------------------------------------------------------------
+      MR = 1
+      IF (ZI.LT.0.0E0) MR = -1
+      CALL CACAI(ZTA, FNU, KODE, MR, 1, CY, NN, RL, TOL, ELIM, ALIM)
+      IF (NN.LT.0) GO TO 250
+      NZ = NZ + NN
+      GO TO 120
+  100 CONTINUE
+      IF (KODE.EQ.2) GO TO 110
+C-----------------------------------------------------------------------
+C     UNDERFLOW TEST
+C-----------------------------------------------------------------------
+      IF (AA.LT.ALIM) GO TO 110
+      AA = -AA - 0.25E0*ALAZ
+      IFLAG = 2
+      SFAC = 1.0E0/TOL
+      IF (AA.LT.(-ELIM)) GO TO 180
+  110 CONTINUE
+      CALL CBKNU(ZTA, FNU, KODE, 1, CY, NZ, TOL, ELIM, ALIM)
+  120 CONTINUE
+      S1 = CY(1)*CMPLX(COEF,0.0E0)
+      IF (IFLAG.NE.0) GO TO 140
+      IF (ID.EQ.1) GO TO 130
+      AI = CSQ*S1
+      RETURN
+  130 AI = -Z*S1
+      RETURN
+  140 CONTINUE
+      S1 = S1*CMPLX(SFAC,0.0E0)
+      IF (ID.EQ.1) GO TO 150
+      S1 = S1*CSQ
+      AI = S1*CMPLX(1.0E0/SFAC,0.0E0)
+      RETURN
+  150 CONTINUE
+      S1 = -S1*Z
+      AI = S1*CMPLX(1.0E0/SFAC,0.0E0)
+      RETURN
+  160 CONTINUE
+      AA = 1.0E+3*R1MACH(1)
+      S1 = CMPLX(0.0E0,0.0E0)
+      IF (ID.EQ.1) GO TO 170
+      IF (AZ.GT.AA) S1 = CMPLX(C2,0.0E0)*Z
+      AI = CMPLX(C1,0.0E0) - S1
+      RETURN
+  170 CONTINUE
+      AI = -CMPLX(C2,0.0E0)
+      AA = SQRT(AA)
+      IF (AZ.GT.AA) S1 = Z*Z*CMPLX(0.5E0,0.0E0)
+      AI = AI + S1*CMPLX(C1,0.0E0)
+      RETURN
+  180 CONTINUE
+      NZ = 1
+      AI = CMPLX(0.0E0,0.0E0)
+      RETURN
+  240 CONTINUE
+      NZ = 0
+      IERR=2
+      RETURN
+  250 CONTINUE
+      IF(NN.EQ.(-1)) GO TO 240
+      NZ=0
+      IERR=5
+      RETURN
+  260 CONTINUE
+      IERR=4
+      NZ=0
+      RETURN
+      END