Remove slatec since we do not use it.

slatec/Make.files

@@ -1,6 +0,0 @@
-$(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 \
-	xermsg.f fdump.f j4save.f xercnt.f xerhlt.f xerprn.f xersve.f xgetua.f
-

slatec/aaaaaa.f

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

slatec/carg.f

@@ -1,31 +0,0 @@
-*DECK CARG
-      FUNCTION CARG (Z)
-C***BEGIN PROLOGUE  CARG
-C***PURPOSE  Compute the argument of a complex number.
-C***LIBRARY   SLATEC (FNLIB)
-C***CATEGORY  A4A
-C***TYPE      COMPLEX (CARG-C)
-C***KEYWORDS  ARGUMENT OF A COMPLEX NUMBER, ELEMENTARY FUNCTIONS, FNLIB
-C***AUTHOR  Fullerton, W., (LANL)
-C***DESCRIPTION
-C
-C CARG(Z) calculates the argument of the complex number Z.  Note
-C that CARG returns a real result.  If Z = X+iY, then CARG is ATAN(Y/X),
-C except when both X and Y are zero, in which case the result
-C will be zero.
-C
-C***REFERENCES  (NONE)
-C***ROUTINES CALLED  (NONE)
-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  CARG
-      COMPLEX Z
-C***FIRST EXECUTABLE STATEMENT  CARG
-      CARG = 0.0
-      IF (REAL(Z).NE.0. .OR. AIMAG(Z).NE.0.) CARG =
-     1  ATAN2 (AIMAG(Z), REAL(Z))
-C
-      RETURN
-      END

slatec/casin.f

@@ -1,66 +0,0 @@
-*DECK CASIN
-      COMPLEX FUNCTION CASIN (ZINP)
-C***BEGIN PROLOGUE  CASIN
-C***PURPOSE  Compute the complex arc sine.
-C***LIBRARY   SLATEC (FNLIB)
-C***CATEGORY  C4A
-C***TYPE      COMPLEX (CASIN-C)
-C***KEYWORDS  ARC SINE, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
-C***AUTHOR  Fullerton, W., (LANL)
-C***DESCRIPTION
-C
-C CASIN(ZINP) calculates the complex trigonometric arc sine of ZINP.
-C The result is in units of radians, and the real part is in the first
-C or fourth quadrant.
-C
-C***REFERENCES  (NONE)
-C***ROUTINES CALLED  R1MACH
-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  CASIN
-      COMPLEX ZINP, Z, Z2, SQZP1, CI
-      LOGICAL FIRST
-      SAVE PI2, PI, CI, NTERMS, RMIN, FIRST
-      DATA PI2 /1.5707963267 9489661923E0/
-      DATA PI /3.1415926535 8979324E0/
-      DATA CI /(0.,1.)/
-      DATA FIRST /.TRUE./
-C***FIRST EXECUTABLE STATEMENT  CASIN
-      IF (FIRST) THEN
-C NTERMS = LOG(EPS)/LOG(RMAX)  WHERE RMAX = 0.1
-         NTERMS = -0.4343*LOG(R1MACH(3))
-         RMIN = SQRT (6.0*R1MACH(3))
-      ENDIF
-      FIRST = .FALSE.
-C
-      Z = ZINP
-      R = ABS (Z)
-      IF (R.GT.0.1) GO TO 30
-C
-      CASIN = Z
-      IF (R.LT.RMIN) RETURN
-C
-      CASIN = (0.0, 0.0)
-      Z2 = Z*Z
-      DO 20 I=1,NTERMS
-        TWOI = 2*(NTERMS-I) + 1
-        CASIN = 1.0/TWOI + TWOI*CASIN*Z2/(TWOI+1.0)
- 20   CONTINUE
-      CASIN = Z*CASIN
-      RETURN
-C
- 30   IF (REAL(ZINP).LT.0.0) Z = -ZINP
-C
-      SQZP1 = SQRT (Z+1.0)
-      IF (AIMAG(SQZP1).LT.0.) SQZP1 = -SQZP1
-      CASIN = PI2 - CI * LOG (Z + SQZP1*SQRT(Z-1.0))
-C
-      IF (REAL(CASIN).GT.PI2) CASIN = PI - CASIN
-      IF (REAL(CASIN).LE.(-PI2)) CASIN = -PI - CASIN
-      IF (REAL(ZINP).LT.0.) CASIN = -CASIN
-C
-      RETURN
-      END

slatec/casinh.f

@@ -1,29 +0,0 @@
-*DECK CASINH
-      COMPLEX FUNCTION CASINH (Z)
-C***BEGIN PROLOGUE  CASINH
-C***PURPOSE  Compute the arc hyperbolic sine.
-C***LIBRARY   SLATEC (FNLIB)
-C***CATEGORY  C4C
-C***TYPE      COMPLEX (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 CASINH(Z) calculates the complex arc hyperbolic sine of Z.
-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  CASINH
-      COMPLEX Z, CI, CASIN
-      SAVE CI
-      DATA CI /(0.,1.)/
-C***FIRST EXECUTABLE STATEMENT  CASINH
-      CASINH = -CI*CASIN (CI*Z)
-C
-      RETURN
-      END

slatec/casyi.f

@@ -1,136 +0,0 @@
-*DECK CASYI
-      SUBROUTINE CASYI (Z, FNU, KODE, N, Y, NZ, RL, TOL, ELIM, ALIM)
-C***BEGIN PROLOGUE  CASYI
-C***SUBSIDIARY
-C***PURPOSE  Subsidiary to CBESI and CBESK
-C***LIBRARY   SLATEC
-C***TYPE      ALL (CASYI-A, ZASYI-A)
-C***AUTHOR  Amos, D. E., (SNL)
-C***DESCRIPTION
-C
-C     CASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY
-C     MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE ABS(Z) IN THE
-C     REGION ABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN.
-C     NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1.
-C
-C***SEE ALSO  CBESI, CBESK
-C***ROUTINES CALLED  R1MACH
-C***REVISION HISTORY  (YYMMDD)
-C   830501  DATE WRITTEN
-C   910415  Prologue converted to Version 4.0 format.  (BAB)
-C***END PROLOGUE  CASYI
-      COMPLEX AK1, CK, CONE, CS1, CS2, CZ, CZERO, DK, EZ, P1, RZ, S2,
-     * Y, Z
-      REAL AA, ACZ, AEZ, AK, ALIM, ARG, ARM, ATOL, AZ, BB, BK, DFNU,
-     * DNU2, ELIM, FDN, FNU, PI, RL, RTPI, RTR1, S, SGN, SQK, TOL, X,
-     * YY, R1MACH
-      INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ
-      DIMENSION Y(N)
-      DATA PI, RTPI  /3.14159265358979324E0 , 0.159154943091895336E0 /
-      DATA CZERO, CONE / (0.0E0,0.0E0), (1.0E0,0.0E0) /
-C***FIRST EXECUTABLE STATEMENT  CASYI
-      NZ = 0
-      AZ = ABS(Z)
-      X = REAL(Z)
-      ARM = 1.0E+3*R1MACH(1)
-      RTR1 = SQRT(ARM)
-      IL = MIN(2,N)
-      DFNU = FNU + (N-IL)
-C-----------------------------------------------------------------------
-C     OVERFLOW TEST
-C-----------------------------------------------------------------------
-      AK1 = CMPLX(RTPI,0.0E0)/Z
-      AK1 = CSQRT(AK1)
-      CZ = Z
-      IF (KODE.EQ.2) CZ = Z - CMPLX(X,0.0E0)
-      ACZ = REAL(CZ)
-      IF (ABS(ACZ).GT.ELIM) GO TO 80
-      DNU2 = DFNU + DFNU
-      KODED = 1
-      IF ((ABS(ACZ).GT.ALIM) .AND. (N.GT.2)) GO TO 10
-      KODED = 0
-      AK1 = AK1*CEXP(CZ)
-   10 CONTINUE
-      FDN = 0.0E0
-      IF (DNU2.GT.RTR1) FDN = DNU2*DNU2
-      EZ = Z*CMPLX(8.0E0,0.0E0)
-C-----------------------------------------------------------------------
-C     WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE
-C     FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE
-C     EXPANSION FOR THE IMAGINARY PART.
-C-----------------------------------------------------------------------
-      AEZ = 8.0E0*AZ
-      S = TOL/AEZ
-      JL = RL+RL + 2
-      YY = AIMAG(Z)
-      P1 = CZERO
-      IF (YY.EQ.0.0E0) GO TO 20
-C-----------------------------------------------------------------------
-C     CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF
-C     SIGNIFICANCE WHEN FNU OR N IS LARGE
-C-----------------------------------------------------------------------
-      INU = FNU
-      ARG = (FNU-INU)*PI
-      INU = INU + N - IL
-      AK = -SIN(ARG)
-      BK = COS(ARG)
-      IF (YY.LT.0.0E0) BK = -BK
-      P1 = CMPLX(AK,BK)
-      IF (MOD(INU,2).EQ.1) P1 = -P1
-   20 CONTINUE
-      DO 50 K=1,IL
-        SQK = FDN - 1.0E0
-        ATOL = S*ABS(SQK)
-        SGN = 1.0E0
-        CS1 = CONE
-        CS2 = CONE
-        CK = CONE
-        AK = 0.0E0
-        AA = 1.0E0
-        BB = AEZ
-        DK = EZ
-        DO 30 J=1,JL
-          CK = CK*CMPLX(SQK,0.0E0)/DK
-          CS2 = CS2 + CK
-          SGN = -SGN
-          CS1 = CS1 + CK*CMPLX(SGN,0.0E0)
-          DK = DK + EZ
-          AA = AA*ABS(SQK)/BB
-          BB = BB + AEZ
-          AK = AK + 8.0E0
-          SQK = SQK - AK
-          IF (AA.LE.ATOL) GO TO 40
-   30   CONTINUE
-        GO TO 90
-   40   CONTINUE
-        S2 = CS1
-        IF (X+X.LT.ELIM) S2 = S2 + P1*CS2*CEXP(-Z-Z)
-        FDN = FDN + 8.0E0*DFNU + 4.0E0
-        P1 = -P1
-        M = N - IL + K
-        Y(M) = S2*AK1
-   50 CONTINUE
-      IF (N.LE.2) RETURN
-      NN = N
-      K = NN - 2
-      AK = K
-      RZ = (CONE+CONE)/Z
-      IB = 3
-      DO 60 I=IB,NN
-        Y(K) = CMPLX(AK+FNU,0.0E0)*RZ*Y(K+1) + Y(K+2)
-        AK = AK - 1.0E0
-        K = K - 1
-   60 CONTINUE
-      IF (KODED.EQ.0) RETURN
-      CK = CEXP(CZ)
-      DO 70 I=1,NN
-        Y(I) = Y(I)*CK
-   70 CONTINUE
-      RETURN
-   80 CONTINUE
-      NZ = -1
-      RETURN
-   90 CONTINUE
-      NZ=-2
-      RETURN
-      END

slatec/catan.f

@@ -1,76 +0,0 @@
-*DECK CATAN
-      COMPLEX FUNCTION CATAN (Z)
-C***BEGIN PROLOGUE  CATAN
-C***PURPOSE  Compute the complex arc tangent.
-C***LIBRARY   SLATEC (FNLIB)
-C***CATEGORY  C4A
-C***TYPE      COMPLEX (CATAN-C)
-C***KEYWORDS  ARC TANGENT, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
-C***AUTHOR  Fullerton, W., (LANL)
-C***DESCRIPTION
-C
-C CATAN(Z) calculates the complex trigonometric arc tangent of Z.
-C The result is in units of radians, and the real part is in the first
-C or fourth quadrant.
-C
-C***REFERENCES  (NONE)
-C***ROUTINES CALLED  R1MACH, XERMSG
-C***REVISION HISTORY  (YYMMDD)
-C   770801  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  CATAN
-      COMPLEX Z, Z2
-      LOGICAL FIRST
-      SAVE PI2, NTERMS, SQEPS, RMIN, RMAX, FIRST
-      DATA PI2 / 1.5707963267 9489661923E0 /
-      DATA FIRST /.TRUE./
-C***FIRST EXECUTABLE STATEMENT  CATAN
-      IF (FIRST) THEN
-C NTERMS = LOG(EPS)/LOG(RBND) WHERE RBND = 0.1
-         NTERMS = -0.4343*LOG(R1MACH(3)) + 1.0
-         SQEPS = SQRT(R1MACH(4))
-         RMIN = SQRT (3.0*R1MACH(3))
-         RMAX = 1.0/R1MACH(3)
-      ENDIF
-      FIRST = .FALSE.
-C
-      R = ABS(Z)
-      IF (R.GT.0.1) GO TO 30
-C
-      CATAN = Z
-      IF (R.LT.RMIN) RETURN
-C
-      CATAN = (0.0, 0.0)
-      Z2 = Z*Z
-      DO 20 I=1,NTERMS
-        TWOI = 2*(NTERMS-I) + 1
-        CATAN = 1.0/TWOI - Z2*CATAN
- 20   CONTINUE
-      CATAN = Z*CATAN
-      RETURN
-C
- 30   IF (R.GT.RMAX) GO TO 50
-      X = REAL(Z)
-      Y = AIMAG(Z)
-      R2 = R*R
-      IF (R2 .EQ. 1.0 .AND. X .EQ. 0.0) CALL XERMSG ('SLATEC', 'CATAN',
-     +   'Z IS +I OR -I', 2, 2)
-      IF (ABS(R2-1.0).GT.SQEPS) GO TO 40
-      IF (ABS(CMPLX(1.0, 0.0)+Z*Z) .LT. SQEPS) CALL XERMSG ('SLATEC',
-     +   'CATAN', 'ANSWER LT HALF PRECISION, Z**2 CLOSE TO -1', 1, 1)
-C
- 40   XANS = 0.5*ATAN2(2.0*X, 1.0-R2)
-      YANS = 0.25*LOG((R2+2.0*Y+1.0)/(R2-2.0*Y+1.0))
-      CATAN = CMPLX (XANS, YANS)
-      RETURN
-C
- 50   CATAN = CMPLX (PI2, 0.)
-      IF (REAL(Z).LT.0.0) CATAN = CMPLX(-PI2,0.0)
-      RETURN
-C
-      END

slatec/catan2.f

@@ -1,47 +0,0 @@
-*DECK CATAN2
-      COMPLEX FUNCTION CATAN2 (CSN, CCS)
-C***BEGIN PROLOGUE  CATAN2
-C***PURPOSE  Compute the complex arc tangent in the proper quadrant.
-C***LIBRARY   SLATEC (FNLIB)
-C***CATEGORY  C4A
-C***TYPE      COMPLEX (CATAN2-C)
-C***KEYWORDS  ARC TANGENT, ELEMENTARY FUNCTIONS, FNLIB, POLAR ANGEL,
-C             QUADRANT, TRIGONOMETRIC
-C***AUTHOR  Fullerton, W., (LANL)
-C***DESCRIPTION
-C
-C CATAN2(CSN,CCS) calculates the complex trigonometric arc
-C tangent of the ratio CSN/CCS and returns a result whose real
-C part is in the correct quadrant (within a multiple of 2*PI).  The
-C result is in units of radians and the real part is between -PI
-C and +PI.
-C
-C***REFERENCES  (NONE)
-C***ROUTINES CALLED  CATAN, 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  CATAN2
-      COMPLEX CSN, CCS, CATAN
-      SAVE PI
-      DATA PI / 3.1415926535 8979323846E0 /
-C***FIRST EXECUTABLE STATEMENT  CATAN2
-      IF (ABS(CCS).EQ.0.) GO TO 10
-C
-      CATAN2 = CATAN (CSN/CCS)
-      IF (REAL(CCS).LT.0.) CATAN2 = CATAN2 + PI
-      IF (REAL(CATAN2).GT.PI) CATAN2 = CATAN2 - 2.0*PI
-      RETURN
-C
- 10   IF (ABS(CSN) .EQ. 0.) CALL XERMSG ('SLATEC', 'CATAN2',
-     +   'CALLED WITH BOTH ARGUMENTS ZERO', 1, 2)
-C
-      CATAN2 = CMPLX (SIGN(0.5*PI,REAL(CSN)), 0.0)
-C
-      RETURN
-      END

slatec/catanh.f

@@ -1,29 +0,0 @@
-*DECK CATANH
-      COMPLEX FUNCTION CATANH (Z)
-C***BEGIN PROLOGUE  CATANH
-C***PURPOSE  Compute the arc hyperbolic tangent.
-C***LIBRARY   SLATEC (FNLIB)
-C***CATEGORY  C4C
-C***TYPE      COMPLEX (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 CATANH(Z) calculates the complex arc hyperbolic tangent of Z.
-C
-C***REFERENCES  (NONE)
-C***ROUTINES CALLED  CATAN
-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  CATANH
-      COMPLEX Z, CI, CATAN
-      SAVE CI
-      DATA CI /(0.,1.)/
-C***FIRST EXECUTABLE STATEMENT  CATANH
-      CATANH = -CI*CATAN(CI*Z)
-C
-      RETURN
-      END

slatec/caxpy.f

@@ -1,73 +0,0 @@
-*DECK CAXPY
-      SUBROUTINE CAXPY (N, CA, CX, INCX, CY, INCY)
-C***BEGIN PROLOGUE  CAXPY
-C***PURPOSE  Compute a constant times a vector plus a vector.
-C***LIBRARY   SLATEC (BLAS)
-C***CATEGORY  D1A7
-C***TYPE      COMPLEX (SAXPY-S, DAXPY-D, CAXPY-C)
-C***KEYWORDS  BLAS, LINEAR ALGEBRA, TRIAD, VECTOR
-C***AUTHOR  Lawson, C. L., (JPL)
-C           Hanson, R. J., (SNLA)
-C           Kincaid, D. R., (U. of Texas)
-C           Krogh, F. T., (JPL)
-C***DESCRIPTION
-C
-C                B L A S  Subprogram
-C    Description of Parameters
-C
-C     --Input--
-C        N  number of elements in input vector(s)
-C       CA  complex scalar multiplier
-C       CX  complex vector with N elements
-C     INCX  storage spacing between elements of CX
-C       CY  complex vector with N elements
-C     INCY  storage spacing between elements of CY
-C
-C     --Output--
-C       CY  complex result (unchanged if N .LE. 0)
-C
-C     Overwrite complex CY with complex  CA*CX + CY.
-C     For I = 0 to N-1, replace  CY(LY+I*INCY) with CA*CX(LX+I*INCX) +
-C       CY(LY+I*INCY),
-C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
-C     defined in a similar way using INCY.
-C
-C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
-C                 Krogh, Basic linear algebra subprograms for Fortran
-C                 usage, Algorithm No. 539, Transactions on Mathematical
-C                 Software 5, 3 (September 1979), pp. 308-323.
-C***ROUTINES CALLED  (NONE)
-C***REVISION HISTORY  (YYMMDD)
-C   791001  DATE WRITTEN
-C   861211  REVISION DATE from Version 3.2
-C   891214  Prologue converted to Version 4.0 format.  (BAB)
-C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
-C   920501  Reformatted the REFERENCES section.  (WRB)
-C   920801  Removed variable CANORM.  (RWC, WRB)
-C***END PROLOGUE  CAXPY
-      COMPLEX CX(*), CY(*), CA
-C***FIRST EXECUTABLE STATEMENT  CAXPY
-      IF (N.LE.0 .OR. CA.EQ.(0.0E0,0.0E0)) RETURN
-      IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 20
-C
-C     Code for unequal or nonpositive increments.
-C
-      KX = 1
-      KY = 1
-      IF (INCX .LT. 0) KX = 1+(1-N)*INCX
-      IF (INCY .LT. 0) KY = 1+(1-N)*INCY
-      DO 10 I = 1,N
-        CY(KY) = CY(KY) + CA*CX(KX)
-        KX = KX + INCX
-        KY = KY + INCY
-   10 CONTINUE
-      RETURN
-C
-C     Code for equal, positive, non-unit increments.
-C
-   20 NS = N*INCX
-      DO 30 I = 1,NS,INCX
-        CY(I) = CA*CX(I) + CY(I)
-   30 CONTINUE
-      RETURN
-      END

slatec/cbabk2.f

@@ -1,108 +0,0 @@
-*DECK CBABK2
-      SUBROUTINE CBABK2 (NM, N, LOW, IGH, SCALE, M, ZR, ZI)
-C***BEGIN PROLOGUE  CBABK2
-C***PURPOSE  Form the eigenvectors of a complex general matrix from the
-C            eigenvectors of matrix output from CBAL.
-C***LIBRARY   SLATEC (EISPACK)
-C***CATEGORY  D4C4
-C***TYPE      COMPLEX (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
-C     CBABK2, which is a complex version of 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 COMPLEX GENERAL
-C     matrix by back transforming those of the corresponding
-C     balanced matrix determined by  CBAL.
-C
-C     On INPUT
-C
-C        NM must be set to the row dimension of the two-dimensional
-C          array parameters, ZR and ZI, as declared in the calling
-C          program dimension statement.  NM is an INTEGER variable.
-C
-C        N is the order of the matrix Z=(ZR,ZI).  N is an INTEGER
-C          variable.  N must be less than or equal to NM.
-C
-C        LOW and IGH are INTEGER variables determined by  CBAL.
-C
-C        SCALE contains information determining the permutations and
-C          scaling factors used by  CBAL.  SCALE is a one-dimensional
-C          REAL array, dimensioned SCALE(N).
-C
-C        M is the number of eigenvectors to be back transformed.
-C          M is an INTEGER variable.
-C
-C        ZR and ZI contain the real and imaginary parts, respectively,
-C          of the eigenvectors to be back transformed in their first
-C          M columns.  ZR and ZI are two-dimensional REAL arrays,
-C          dimensioned ZR(NM,M) and ZI(NM,M).
-C
-C     On OUTPUT
-C
-C        ZR and ZI contain the real and imaginary parts,
-C          respectively, of the transformed eigenvectors
-C          in their 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  CBABK2
-C
-      INTEGER I,J,K,M,N,II,NM,IGH,LOW
-      REAL SCALE(*),ZR(NM,*),ZI(NM,*)
-      REAL S
-C
-C***FIRST EXECUTABLE STATEMENT  CBABK2
-      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
-            ZR(I,J) = ZR(I,J) * S
-            ZI(I,J) = ZI(I,J) * S
-  100    CONTINUE
-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 = ZR(I,J)
-            ZR(I,J) = ZR(K,J)
-            ZR(K,J) = S
-            S = ZI(I,J)
-            ZI(I,J) = ZI(K,J)
-            ZI(K,J) = S
-  130    CONTINUE
-C
-  140 CONTINUE
-C
-  200 RETURN
-      END

slatec/cbal.f

@@ -1,207 +0,0 @@
-*DECK CBAL
-      SUBROUTINE CBAL (NM, N, AR, AI, LOW, IGH, SCALE)
-C***BEGIN PROLOGUE  CBAL
-C***PURPOSE  Balance a complex general matrix and isolate eigenvalues
-C            whenever possible.
-C***LIBRARY   SLATEC (EISPACK)
-C***CATEGORY  D4C1A
-C***TYPE      COMPLEX (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
-C     CBALANCE, which is a complex version of 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 COMPLEX 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 parameters, AR and AI, as declared in the calling
-C          program dimension statement.  NM is an INTEGER variable.
-C
-C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
-C          variable.  N must be less than or equal to NM.
-C
-C        AR and AI contain the real and imaginary parts,
-C          respectively, of the complex matrix to be balanced.
-C          AR and AI are two-dimensional REAL arrays, dimensioned
-C          AR(NM,N) and AI(NM,N).
-C
-C     On OUTPUT
-C
-C        AR and AI contain the real and imaginary parts,
-C          respectively, of the balanced matrix.
-C
-C        LOW and IGH are two INTEGER variables such that AR(I,J)
-C          and AI(I,J) are 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 CBALANCE appears in
-C     CBAL  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  CBAL
-C
-      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
-      REAL AR(NM,*),AI(NM,*),SCALE(*)
-      REAL C,F,G,R,S,B2,RADIX
-      LOGICAL NOCONV
-C
-C     THE FOLLOWING PORTABLE VALUE OF RADIX WORKS WELL ENOUGH
-C     FOR ALL MACHINES WHOSE BASE IS A POWER OF TWO.
-C
-C***FIRST EXECUTABLE STATEMENT  CBAL
-      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 = AR(I,J)
-         AR(I,J) = AR(I,M)
-         AR(I,M) = F
-         F = AI(I,J)
-         AI(I,J) = AI(I,M)
-         AI(I,M) = F
-   30 CONTINUE
-C
-      DO 40 I = K, N
-         F = AR(J,I)
-         AR(J,I) = AR(M,I)
-         AR(M,I) = F
-         F = AI(J,I)
-         AI(J,I) = AI(M,I)
-         AI(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 (AR(J,I) .NE. 0.0E0 .OR. AI(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 (AR(I,J) .NE. 0.0E0 .OR. AI(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(AR(J,I)) + ABS(AI(J,I))
-            R = R + ABS(AR(I,J)) + ABS(AI(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
-            AR(I,J) = AR(I,J) * G
-            AI(I,J) = AI(I,J) * G
-  250    CONTINUE
-C
-         DO 260 J = 1, L
-            AR(J,I) = AR(J,I) * F
-            AI(J,I) = AI(J,I) * F
-  260    CONTINUE
-C
-  270 CONTINUE
-C
-      IF (NOCONV) GO TO 190
-C
-  280 LOW = K
-      IGH = L
-      RETURN
-      END

slatec/cbesh.f

@@ -1,331 +0,0 @@
-*DECK CBESH
-      SUBROUTINE CBESH (Z, FNU, KODE, M, N, CY, NZ, IERR)
-C***BEGIN PROLOGUE  CBESH
-C***PURPOSE  Compute a sequence of the Hankel functions H(m,a,z)
-C            for superscript m=1 or 2, real nonnegative orders a=b,
-C            b+1,... where b>0, and nonzero complex argument z.  A
-C            scaling option is available to help avoid overflow.
-C***LIBRARY   SLATEC
-C***CATEGORY  C10A4
-C***TYPE      COMPLEX (CBESH-C, ZBESH-C)
-C***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
-C             BESSEL FUNCTIONS OF THE THIRD KIND, H BESSEL FUNCTIONS,
-C             HANKEL FUNCTIONS
-C***AUTHOR  Amos, D. E., (SNL)
-C***DESCRIPTION
-C
-C         On KODE=1, CBESH computes an N member sequence of complex
-C         Hankel (Bessel) functions CY(L)=H(M,FNU+L-1,Z) for super-
-C         script M=1 or 2, real nonnegative orders FNU+L-1, L=1,...,
-C         N, and complex nonzero Z in the cut plane -pi<arg(Z)<=pi.
-C         On KODE=2, CBESH returns the scaled functions
-C
-C            CY(L) = H(M,FNU+L-1,Z)*exp(-(3-2*M)*Z*i),  i**2=-1
-C
-C         which removes the exponential behavior in both the upper
-C         and lower half planes.  Definitions and notation are found
-C         in the NBS Handbook of Mathematical Functions (Ref. 1).
-C
-C         Input
-C           Z      - Nonzero argument of type COMPLEX
-C           FNU    - Initial order of type REAL, FNU>=0
-C           KODE   - A parameter to indicate the scaling option
-C                    KODE=1  returns
-C                            CY(L)=H(M,FNU+L-1,Z), L=1,...,N
-C                        =2  returns
-C                            CY(L)=H(M,FNU+L-1,Z)*exp(-(3-2M)*Z*i),
-C                            L=1,...,N
-C           M      - Superscript of Hankel function, M=1 or 2
-C           N      - Number of terms in the sequence, N>=1
-C
-C         Output
-C           CY     - Result vector of type COMPLEX
-C           NZ     - Number of underflows set to zero
-C                    NZ=0    Normal return
-C                    NZ>0    CY(L)=0 for NZ values of L (if M=1 and
-C                            Im(Z)>0 or if M=2 and Im(Z)<0, then
-C                            CY(L)=0 for L=1,...,NZ; in the com-
-C                            plementary half planes, the underflows
-C                            may not be in an uninterrupted sequence)
-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                            (abs(Z) too small and/or FNU+N-1
-C                            too large)
-C                    IERR=3  Precision warning - COMPUTATION COMPLETED
-C                            (Result has half precision or less
-C                            because abs(Z) or FNU+N-1 is large)
-C                    IERR=4  Precision error   - NO COMPUTATION
-C                            (Result has no precision because
-C                            abs(Z) or FNU+N-1 is too large)
-C                    IERR=5  Algorithmic error - NO COMPUTATION
-C                            (Termination condition not met)
-C
-C *Long Description:
-C
-C         The computation is carried out by the formula
-C
-C            H(m,a,z) = (1/t)*exp(-a*t)*K(a,z*exp(-t))
-C                   t = (3-2*m)*i*pi/2
-C
-C         where the K Bessel function is computed as described in the
-C         prologue to CBESK.
-C
-C         Exponential decay of H(m,a,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(-(3-2*m)*z*i) removes the exponential behavior in the
-C         whole z plane as z goes to infinity.
-C
-C         For negative orders, the formula
-C
-C            H(m,-a,z) = H(m,a,z)*exp((3-2*m)*a*pi*i)
-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=R1MACH(4)=UNIT ROUNDOFF.  Also,
-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
-C         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
-C         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
-C         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
-C         makes U2 limiting in single precision and U3 limiting in
-C         double precision.  This means that one can expect to retain,
-C         in the worst cases on IEEE machines, no digits in single pre-
-C         cision and only 6 digits in double precision.  Similar con-
-C         siderations hold for other machines.
-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, Report SAND83-0086, Sandia National
-C                 Laboratories, Albuquerque, NM, May 1983.
-C               3. 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               4. 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               5. 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  CACON, CBKNU, CBUNK, CUOIK, 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  CBESH
-C
-      COMPLEX CY, Z, ZN, ZT, CSGN
-      REAL AA, ALIM, ALN, ARG, AZ, CPN, DIG, ELIM, FMM, FN, FNU, FNUL,
-     * HPI, RHPI, RL, R1M5, SGN, SPN, TOL, UFL, XN, XX, YN, YY, R1MACH,
-     * BB, ASCLE, RTOL, ATOL
-      INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M,
-     * MM, MR, N, NN, NUF, NW, NZ, I1MACH
-      DIMENSION CY(N)
-C
-      DATA HPI /1.57079632679489662E0/
-C
-C***FIRST EXECUTABLE STATEMENT  CBESH
-      NZ=0
-      XX = REAL(Z)
-      YY = AIMAG(Z)
-      IERR = 0
-      IF (XX.EQ.0.0E0 .AND. YY.EQ.0.0E0) IERR=1
-      IF (FNU.LT.0.0E0) 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 = MAX(R1MACH(4),1.0E-18)
-      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)
-      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
-      RL = 1.2E0*DIG + 3.0E0
-      FN = FNU + (NN-1)
-      MM = 3 - M - M
-      FMM = MM
-      ZN = Z*CMPLX(0.0E0,-FMM)
-      XN = REAL(ZN)
-      YN = AIMAG(ZN)
-      AZ = ABS(Z)
-C-----------------------------------------------------------------------
-C     TEST FOR RANGE
-C-----------------------------------------------------------------------
-      AA = 0.5E0/TOL
-      BB=I1MACH(9)*0.5E0
-      AA=MIN(AA,BB)
-      IF(AZ.GT.AA) GO TO 240
-      IF(FN.GT.AA) GO TO 240
-      AA=SQRT(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 = R1MACH(1)*1.0E+3
-      IF (AZ.LT.UFL) GO TO 220
-      IF (FNU.GT.FNUL) GO TO 90
-      IF (FN.LE.1.0E0) GO TO 70
-      IF (FN.GT.2.0E0) GO TO 60
-      IF (AZ.GT.TOL) GO TO 70
-      ARG = 0.5E0*AZ
-      ALN = -FN*ALOG(ARG)
-      IF (ALN.GT.ELIM) GO TO 220
-      GO TO 70
-   60 CONTINUE
-      CALL CUOIK(ZN, FNU, KODE, 2, NN, CY, NUF, TOL, ELIM, ALIM)
-      IF (NUF.LT.0) GO TO 220
-      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 130
-   70 CONTINUE
-      IF ((XN.LT.0.0E0) .OR. (XN.EQ.0.0E0 .AND. YN.LT.0.0E0 .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 CBKNU(ZN, FNU, KODE, NN, CY, NZ, TOL, ELIM, ALIM)
-      GO TO 110
-C-----------------------------------------------------------------------
-C     LEFT HALF PLANE COMPUTATION
-C-----------------------------------------------------------------------
-   80 CONTINUE
-      MR = -MM
-      CALL CACON(ZN, FNU, KODE, MR, NN, CY, NW, RL, FNUL, TOL, ELIM,
-     * ALIM)
-      IF (NW.LT.0) GO TO 230
-      NZ=NW
-      GO TO 110
-   90 CONTINUE
-C-----------------------------------------------------------------------
-C     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL
-C-----------------------------------------------------------------------
-      MR = 0
-      IF ((XN.GE.0.0E0) .AND. (XN.NE.0.0E0 .OR. YN.GE.0.0E0 .OR.
-     * M.NE.2)) GO TO 100
-      MR = -MM
-      IF (XN.EQ.0.0E0 .AND. YN.LT.0.0E0) ZN = -ZN
-  100 CONTINUE
-      CALL CBUNK(ZN, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM)
-      IF (NW.LT.0) GO TO 230
-      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 = SIGN(HPI,-FMM)
-C-----------------------------------------------------------------------
-C     CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
-C     WHEN FNU IS LARGE
-C-----------------------------------------------------------------------
-      INU = FNU
-      INUH = INU/2
-      IR = INU - 2*INUH
-      ARG = (FNU-(INU-IR))*SGN
-      RHPI = 1.0E0/SGN
-      CPN = RHPI*COS(ARG)
-      SPN = RHPI*SIN(ARG)
-C     ZN = CMPLX(-SPN,CPN)
-      CSGN = CMPLX(-SPN,CPN)
-C     IF (MOD(INUH,2).EQ.1) ZN = -ZN
-      IF (MOD(INUH,2).EQ.1) CSGN = -CSGN
-      ZT = CMPLX(0.0E0,-FMM)
-      RTOL = 1.0E0/TOL
-      ASCLE = UFL*RTOL
-      DO 120 I=1,NN
-C       CY(I) = CY(I)*ZN
-C       ZN = ZN*ZT
-        ZN=CY(I)
-        AA=REAL(ZN)
-        BB=AIMAG(ZN)
-        ATOL=1.0E0
-        IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 125
-          ZN = ZN*CMPLX(RTOL,0.0E0)
-          ATOL = TOL
-  125   CONTINUE
-        ZN = ZN*CSGN
-        CY(I) = ZN*CMPLX(ATOL,0.0E0)
-        CSGN = CSGN*ZT
-  120 CONTINUE
-      RETURN
-  130 CONTINUE
-      IF (XN.LT.0.0E0) GO TO 220
-      RETURN
-  220 CONTINUE
-      IERR=2
-      NZ=0
-      RETURN
-  230 CONTINUE
-      IF(NW.EQ.(-1)) GO TO 220
-      NZ=0
-      IERR=5
-      RETURN
-  240 CONTINUE
-      NZ=0
-      IERR=4
-      RETURN
-      END

slatec/cbesi.f

@@ -1,261 +0,0 @@
-*DECK CBESI
-      SUBROUTINE CBESI (Z, FNU, KODE, N, CY, NZ, IERR)
-C***BEGIN PROLOGUE  CBESI
-C***PURPOSE  Compute a sequence of the Bessel functions I(a,z) for
-C            complex argument z and real nonnegative orders a=b,b+1,
-C            b+2,... where b>0.  A scaling option is available to
-C            help avoid overflow.
-C***LIBRARY   SLATEC
-C***CATEGORY  C10B4
-C***TYPE      COMPLEX (CBESI-C, ZBESI-C)
-C***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT, I BESSEL FUNCTIONS,
-C             MODIFIED BESSEL FUNCTIONS
-C***AUTHOR  Amos, D. E., (SNL)
-C***DESCRIPTION
-C
-C         On KODE=1, CBESI computes an N-member sequence of complex
-C         Bessel functions CY(L)=I(FNU+L-1,Z) for real nonnegative
-C         orders FNU+L-1, L=1,...,N and complex Z in the cut plane
-C         -pi<arg(Z)<=pi.  On KODE=2, CBESI returns the scaled functions
-C
-C            CY(L) = exp(-abs(X))*I(FNU+L-1,Z), L=1,...,N and X=Re(Z)
-C
-C         which removes the exponential growth in both the left and
-C         right half-planes as Z goes to infinity.
-C
-C         Input
-C           Z      - Argument of type COMPLEX
-C           FNU    - Initial order of type REAL, FNU>=0
-C           KODE   - A parameter to indicate the scaling option
-C                    KODE=1  returns
-C                            CY(L)=I(FNU+L-1,Z), L=1,...,N
-C                        =2  returns
-C                            CY(L)=exp(-abs(X))*I(FNU+L-1,Z), L=1,...,N
-C                            where X=Re(Z)
-C           N      - Number of terms in the sequence, N>=1
-C
-C         Output
-C           CY     - Result vector of type COMPLEX
-C           NZ     - Number of underflows set to zero
-C                    NZ=0    Normal return
-C                    NZ>0    CY(L)=0, L=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
-C                            (Re(Z) too large on KODE=1)
-C                    IERR=3  Precision warning - COMPUTATION COMPLETED
-C                            (Result has half precision or less
-C                            because abs(Z) or FNU+N-1 is large)
-C                    IERR=4  Precision error   - NO COMPUTATION
-C                            (Result has no precision because
-C                            abs(Z) or FNU+N-1 is too large)
-C                    IERR=5  Algorithmic error - NO COMPUTATION
-C                            (Termination condition not met)
-C
-C *Long Description:
-C
-C         The computation of I(a,z) is carried out by the power series
-C         for small abs(z), the asymptotic expansion for large abs(z),
-C         the Miller algorithm normalized by the Wronskian and a
-C         Neumann series for intermediate magnitudes of z, and the
-C         uniform asymptotic expansions for I(a,z) and J(a,z) for
-C         large orders a.  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(a,z*exp(t)) = exp(t*a)*I(a,z), Re(z)>0
-C                        t = i*pi or -i*pi
-C
-C         For negative orders, the formula
-C
-C            I(-a,z) = I(a,z) + (2/pi)*sin(pi*a)*K(a,z)
-C
-C         can be used.  However, for large orders close to integers the
-C         the function changes radically.  When a is a large positive
-C         integer, the magnitude of I(-a,z)=I(a,z) is a large
-C         negative power of ten. But when a is not an integer,
-C         K(a,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 a. Here,
-C         large means a>abs(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=R1MACH(4)=UNIT ROUNDOFF.  Also,
-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
-C         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
-C         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
-C         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
-C         makes U2 limiting in single precision and U3 limiting in
-C         double precision.  This means that one can expect to retain,
-C         in the worst cases on IEEE machines, no digits in single pre-
-C         cision and only 6 digits in double precision.  Similar con-
-C         siderations hold for other machines.
-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, Report SAND83-0086, Sandia National
-C                 Laboratories, Albuquerque, NM, May 1983.
-C               3. 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               4. 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               5. 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  CBINU, 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  CBESI
-      COMPLEX CONE, CSGN, CY, Z, ZN
-      REAL AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, S1, S2,
-     * TOL, XX, YY, R1MACH, AZ, FN, BB, ASCLE, RTOL, ATOL
-      INTEGER I, IERR, INU, K, KODE, K1, K2, N, NN, NZ, I1MACH
-      DIMENSION CY(N)
-      DATA PI /3.14159265358979324E0/
-      DATA CONE / (1.0E0,0.0E0) /
-C
-C***FIRST EXECUTABLE STATEMENT  CBESI
-      IERR = 0
-      NZ=0
-      IF (FNU.LT.0.0E0) IERR=1
-      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
-      IF (N.LT.1) IERR=1
-      IF (IERR.NE.0) RETURN
-      XX = REAL(Z)
-      YY = AIMAG(Z)
-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 = MAX(R1MACH(4),1.0E-18)
-      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
-      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
-      AZ = ABS(Z)
-C-----------------------------------------------------------------------
-C     TEST FOR RANGE
-C-----------------------------------------------------------------------
-      AA = 0.5E0/TOL
-      BB=I1MACH(9)*0.5E0
-      AA=MIN(AA,BB)
-      IF(AZ.GT.AA) GO TO 140
-      FN=FNU+(N-1)
-      IF(FN.GT.AA) GO TO 140
-      AA=SQRT(AA)
-      IF(AZ.GT.AA) IERR=3
-      IF(FN.GT.AA) IERR=3
-      ZN = Z
-      CSGN = CONE
-      IF (XX.GE.0.0E0) GO TO 40
-      ZN = -Z
-C-----------------------------------------------------------------------
-C     CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
-C     WHEN FNU IS LARGE
-C-----------------------------------------------------------------------
-      INU = FNU
-      ARG = (FNU-INU)*PI
-      IF (YY.LT.0.0E0) ARG = -ARG
-      S1 = COS(ARG)
-      S2 = SIN(ARG)
-      CSGN = CMPLX(S1,S2)
-      IF (MOD(INU,2).EQ.1) CSGN = -CSGN
-   40 CONTINUE
-      CALL CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM)
-      IF (NZ.LT.0) GO TO 120
-      IF (XX.GE.0.0E0) RETURN
-C-----------------------------------------------------------------------
-C     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE
-C-----------------------------------------------------------------------
-      NN = N - NZ
-      IF (NN.EQ.0) RETURN
-      RTOL = 1.0E0/TOL
-      ASCLE = R1MACH(1)*RTOL*1.0E+3
-      DO 50 I=1,NN
-C       CY(I) = CY(I)*CSGN
-        ZN=CY(I)
-        AA=REAL(ZN)
-        BB=AIMAG(ZN)
-        ATOL=1.0E0
-        IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55
-          ZN = ZN*CMPLX(RTOL,0.0E0)
-          ATOL = TOL
-   55   CONTINUE
-        ZN = ZN*CSGN
-        CY(I) = ZN*CMPLX(ATOL,0.0E0)
-        CSGN = -CSGN
-   50 CONTINUE
-      RETURN
-  120 CONTINUE
-      IF(NZ.EQ.(-2)) GO TO 130
-      NZ = 0
-      IERR=2
-      RETURN
-  130 CONTINUE
-      NZ=0
-      IERR=5
-      RETURN
-  140 CONTINUE
-      NZ=0
-      IERR=4
-      RETURN
-      END

slatec/cbesj.f

@@ -1,259 +0,0 @@
-*DECK CBESJ
-      SUBROUTINE CBESJ (Z, FNU, KODE, N, CY, NZ, IERR)
-C***BEGIN PROLOGUE  CBESJ
-C***PURPOSE  Compute a sequence of the Bessel functions J(a,z) for
-C            complex argument z and real nonnegative orders a=b,b+1,
-C            b+2,... where b>0.  A scaling option is available to
-C            help avoid overflow.
-C***LIBRARY   SLATEC
-C***CATEGORY  C10A4
-C***TYPE      COMPLEX (CBESJ-C, ZBESJ-C)
-C***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
-C             BESSEL FUNCTIONS OF THE FIRST KIND, J BESSEL FUNCTIONS
-C***AUTHOR  Amos, D. E., (SNL)
-C***DESCRIPTION
-C
-C         On KODE=1, CBESJ computes an N member sequence of complex
-C         Bessel functions CY(L)=J(FNU+L-1,Z) for real nonnegative
-C         orders FNU+L-1, L=1,...,N and complex Z in the cut plane
-C         -pi<arg(Z)<=pi.  On KODE=2, CBESJ returns the scaled functions
-C
-C            CY(L) = exp(-abs(Y))*J(FNU+L-1,Z),  L=1,...,N and Y=Im(Z)
-C
-C         which remove the exponential growth in both the upper and
-C         lower half planes as Z goes to infinity.  Definitions and
-C         notation are found in the NBS Handbook of Mathematical
-C         Functions (Ref. 1).
-C
-C         Input
-C           Z      - Argument of type COMPLEX
-C           FNU    - Initial order of type REAL, FNU>=0
-C           KODE   - A parameter to indicate the scaling option
-C                    KODE=1  returns
-C                            CY(L)=J(FNU+L-1,Z), L=1,...,N
-C                        =2  returns
-C                            CY(L)=J(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N
-C                            where Y=Im(Z)
-C           N      - Number of terms in the sequence, N>=1
-C
-C         Output
-C           CY     - Result vector of type COMPLEX
-C           NZ     - Number of underflows set to zero
-C                    NZ=0    Normal return
-C                    NZ>0    CY(L)=0, L=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
-C                            (Im(Z) too large on KODE=1)
-C                    IERR=3  Precision warning - COMPUTATION COMPLETED
-C                            (Result has half precision or less
-C                            because abs(Z) or FNU+N-1 is large)
-C                    IERR=4  Precision error   - NO COMPUTATION
-C                            (Result has no precision because
-C                            abs(Z) or FNU+N-1 is too large)
-C                    IERR=5  Algorithmic error - NO COMPUTATION
-C                            (Termination condition not met)
-C
-C *Long Description:
-C
-C         The computation is carried out by the formulae
-C
-C            J(a,z) = exp( a*pi*i/2)*I(a,-i*z),  Im(z)>=0
-C
-C            J(a,z) = exp(-a*pi*i/2)*I(a, i*z),  Im(z)<0
-C
-C         where the I Bessel function is computed as described in the
-C         prologue to CBESI.
-C
-C         For negative orders, the formula
-C
-C            J(-a,z) = J(a,z)*cos(a*pi) - Y(a,z)*sin(a*pi)
-C
-C         can be used.  However, for large orders close to integers, the
-C         the function changes radically.  When a is a large positive
-C         integer, the magnitude of J(-a,z)=J(a,z)*cos(a*pi) is a
-C         large negative power of ten.  But when a is not an integer,
-C         Y(a,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 a.  Here,
-C         large means a>abs(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=R1MACH(4)=UNIT ROUNDOFF.  Also,
-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
-C         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
-C         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
-C         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
-C         makes U2 limiting in single precision and U3 limiting in
-C         double precision.  This means that one can expect to retain,
-C         in the worst cases on IEEE machines, no digits in single pre-
-C         cision and only 6 digits in double precision.  Similar con-
-C         siderations hold for other machines.
-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, Report SAND83-0086, Sandia National
-C                 Laboratories, Albuquerque, NM, May 1983.
-C               3. 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               4. 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               5. 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  CBINU, 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  CBESJ
-C
-      COMPLEX CI, CSGN, CY, Z, ZN
-      REAL AA, ALIM, ARG, DIG, ELIM, FNU, FNUL, HPI, RL, R1, R1M5, R2,
-     * TOL, YY, R1MACH, AZ, FN, BB, ASCLE, RTOL, ATOL
-      INTEGER I, IERR, INU, INUH, IR, KODE, K1, K2, N, NL, NZ, I1MACH, K
-      DIMENSION CY(N)
-      DATA HPI /1.57079632679489662E0/
-C
-C***FIRST EXECUTABLE STATEMENT  CBESJ
-      IERR = 0
-      NZ=0
-      IF (FNU.LT.0.0E0) 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 = MAX(R1MACH(4),1.0E-18)
-      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
-      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
-      CI = CMPLX(0.0E0,1.0E0)
-      YY = AIMAG(Z)
-      AZ = ABS(Z)
-C-----------------------------------------------------------------------
-C     TEST FOR RANGE
-C-----------------------------------------------------------------------
-      AA = 0.5E0/TOL
-      BB=I1MACH(9)*0.5E0
-      AA=MIN(AA,BB)
-      FN=FNU+(N-1)
-      IF(AZ.GT.AA) GO TO 140
-      IF(FN.GT.AA) GO TO 140
-      AA=SQRT(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-----------------------------------------------------------------------
-      INU = FNU
-      INUH = INU/2
-      IR = INU - 2*INUH
-      ARG = (FNU-(INU-IR))*HPI
-      R1 = COS(ARG)
-      R2 = SIN(ARG)
-      CSGN = CMPLX(R1,R2)
-      IF (MOD(INUH,2).EQ.1) CSGN = -CSGN
-C-----------------------------------------------------------------------
-C     ZN IS IN THE RIGHT HALF PLANE
-C-----------------------------------------------------------------------
-      ZN = -Z*CI
-      IF (YY.GE.0.0E0) GO TO 40
-      ZN = -ZN
-      CSGN = CONJG(CSGN)
-      CI = CONJG(CI)
-   40 CONTINUE
-      CALL CBINU(ZN, FNU, KODE, N, CY, NZ, RL, FNUL, TOL, ELIM, ALIM)
-      IF (NZ.LT.0) GO TO 120
-      NL = N - NZ
-      IF (NL.EQ.0) RETURN
-      RTOL = 1.0E0/TOL
-      ASCLE = R1MACH(1)*RTOL*1.0E+3
-      DO 50 I=1,NL
-C       CY(I)=CY(I)*CSGN
-        ZN=CY(I)
-        AA=REAL(ZN)
-        BB=AIMAG(ZN)
-        ATOL=1.0E0
-        IF (MAX(ABS(AA),ABS(BB)).GT.ASCLE) GO TO 55
-          ZN = ZN*CMPLX(RTOL,0.0E0)
-          ATOL = TOL
-   55   CONTINUE
-        ZN = ZN*CSGN
-        CY(I) = ZN*CMPLX(ATOL,0.0E0)
-        CSGN = CSGN*CI
-   50 CONTINUE
-      RETURN
-  120 CONTINUE
-      IF(NZ.EQ.(-2)) GO TO 130
-      NZ = 0
-      IERR = 2
-      RETURN
-  130 CONTINUE
-      NZ=0
-      IERR=5
-      RETURN
-  140 CONTINUE
-      NZ=0
-      IERR=4
-      RETURN
-      END

slatec/cbesk.f

@@ -1,281 +0,0 @@
-*DECK CBESK
-      SUBROUTINE CBESK (Z, FNU, KODE, N, CY, NZ, IERR)
-C***BEGIN PROLOGUE  CBESK
-C***PURPOSE  Compute a sequence of the Bessel functions K(a,z) for
-C            complex argument z and real nonnegative orders a=b,b+1,
-C            b+2,... where b>0.  A scaling option is available to
-C            help avoid overflow.
-C***LIBRARY   SLATEC
-C***CATEGORY  C10B4
-C***TYPE      COMPLEX (CBESK-C, ZBESK-C)
-C***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT, K BESSEL FUNCTIONS,
-C             MODIFIED BESSEL FUNCTIONS
-C***AUTHOR  Amos, D. E., (SNL)
-C***DESCRIPTION
-C
-C         On KODE=1, CBESK computes an N member sequence of complex
-C         Bessel functions CY(L)=K(FNU+L-1,Z) for real nonnegative
-C         orders FNU+L-1, L=1,...,N and complex Z.NE.0 in the cut
-C         plane -pi<arg(Z)<=pi.  On KODE=2, CBESJ returns the scaled
-C         functions
-C
-C            CY(L) = exp(Z)*K(FNU+L-1,Z),  L=1,...,N
-C
-C         which remove the exponential growth in both the left and
-C         right half planes as Z goes to infinity.  Definitions and
-C         notation are found in the NBS Handbook of Mathematical
-C         Functions (Ref. 1).
-C
-C         Input
-C           Z      - Nonzero argument of type COMPLEX
-C           FNU    - Initial order of type REAL, FNU>=0
-C           KODE   - A parameter to indicate the scaling option
-C                    KODE=1  returns
-C                            CY(L)=K(FNU+L-1,Z), L=1,...,N
-C                        =2  returns
-C                            CY(L)=K(FNU+L-1,Z)*EXP(Z), L=1,...,N
-C           N      - Number of terms in the sequence, N>=1
-C
-C         Output
-C           CY     - Result vector of type COMPLEX
-C           NZ     - Number of underflows set to zero
-C                    NZ=0    Normal return
-C                    NZ>0    CY(L)=0 for NZ values of L (if Re(Z)>0
-C                            then CY(L)=0 for L=1,...,NZ; in the
-C                            complementary half plane the underflows
-C                            may not be in an uninterrupted sequence)
-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                            (abs(Z) too small and/or FNU+N-1
-C                            too large)
-C                    IERR=3  Precision warning - COMPUTATION COMPLETED
-C                            (Result has half precision or less
-C                            because abs(Z) or FNU+N-1 is large)
-C                    IERR=4  Precision error   - NO COMPUTATION
-C                            (Result has no precision because
-C                            abs(Z) or FNU+N-1 is too large)
-C                    IERR=5  Algorithmic error - NO COMPUTATION
-C                            (Termination condition not met)
-C
-C *Long Description:
-C
-C         Equations of the reference are implemented to compute K(a,z)
-C         for small orders a and a+1 in the right half plane Re(z)>=0.
-C         Forward recurrence generates higher orders.  The formula
-C
-C            K(a,z*exp((t)) = exp(-t)*K(a,z) - t*I(a,z),  Re(z)>0
-C                         t = i*pi or -i*pi
-C
-C         continues K to the left half plane.
-C
-C         For large orders, K(a,z) is computed by means of its uniform
-C         asymptotic expansion.
-C
-C         For negative orders, the formula
-C
-C            K(-a,z) = K(a,z)
-C
-C         can be used.
-C
-C         CBESK assumes that a significant digit sinh 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=R1MACH(4)=UNIT ROUNDOFF.  Also,
-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
-C         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
-C         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
-C         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
-C         makes U2 limiting in single precision and U3 limiting in
-C         double precision.  This means that one can expect to retain,
-C         in the worst cases on IEEE machines, no digits in single pre-
-C         cision and only 6 digits in double precision.  Similar con-
-C         siderations hold for other machines.
-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, Report SAND83-0086, Sandia National
-C                 Laboratories, Albuquerque, NM, May 1983.
-C               3. 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               4. 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               5. 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  CACON, CBKNU, CBUNK, CUOIK, 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  CBESK
-C
-      COMPLEX CY, Z
-      REAL AA, ALIM, ALN, ARG, AZ, DIG, ELIM, FN, FNU, FNUL, RL, R1M5,
-     * TOL, UFL, XX, YY, R1MACH, BB
-      INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH
-      DIMENSION CY(N)
-C***FIRST EXECUTABLE STATEMENT  CBESK
-      IERR = 0
-      NZ=0
-      XX = REAL(Z)
-      YY = AIMAG(Z)
-      IF (YY.EQ.0.0E0 .AND. XX.EQ.0.0E0) IERR=1
-      IF (FNU.LT.0.0E0) 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 = MAX(R1MACH(4),1.0E-18)
-      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)
-      FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0)
-      RL = 1.2E0*DIG + 3.0E0
-      AZ = ABS(Z)
-      FN = FNU + (NN-1)
-C-----------------------------------------------------------------------
-C     TEST FOR RANGE
-C-----------------------------------------------------------------------
-      AA = 0.5E0/TOL
-      BB=I1MACH(9)*0.5E0
-      AA=MIN(AA,BB)
-      IF(AZ.GT.AA) GO TO 210
-      IF(FN.GT.AA) GO TO 210
-      AA=SQRT(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 = EXP(-ELIM)
-      UFL = R1MACH(1)*1.0E+3
-      IF (AZ.LT.UFL) GO TO 180
-      IF (FNU.GT.FNUL) GO TO 80
-      IF (FN.LE.1.0E0) GO TO 60
-      IF (FN.GT.2.0E0) GO TO 50
-      IF (AZ.GT.TOL) GO TO 60
-      ARG = 0.5E0*AZ
-      ALN = -FN*ALOG(ARG)
-      IF (ALN.GT.ELIM) GO TO 180
-      GO TO 60
-   50 CONTINUE
-      CALL CUOIK(Z, FNU, KODE, 2, NN, CY, 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 (XX.LT.0.0E0) GO TO 70
-C-----------------------------------------------------------------------
-C     RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0.
-C-----------------------------------------------------------------------
-      CALL CBKNU(Z, FNU, KODE, NN, CY, 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 (YY.LT.0.0E0) MR = -1
-      CALL CACON(Z, FNU, KODE, MR, NN, CY, 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 (XX.GE.0.0E0) GO TO 90
-      MR = 1
-      IF (YY.LT.0.0E0) MR = -1
-   90 CONTINUE
-      CALL CBUNK(Z, FNU, KODE, MR, NN, CY, NW, TOL, ELIM, ALIM)
-      IF (NW.LT.0) GO TO 200
-      NZ = NZ + NW
-      RETURN
-  100 CONTINUE
-      IF (XX.LT.0.0E0) 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
-  210 CONTINUE
-      NZ=0
-      IERR=4
-      RETURN
-      END