Fcalva/OpenLibm
1
0
Fork 0
mirror of https://git.planet-casio.com/Lephenixnoir/OpenLibm.git synced 2024-12-29 13:03:42 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

Remove slatec since we do not use it.

Browse source
This commit is contained in:
Viral B. Shah 2013-04-25 10:17:37 +05:30
parent c9cf16d2de
commit 740f901b48
1446 changed files with 0 additions and 306811 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
slatec/Make.files
View file

@ -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

71
slatec/aaaaaa.f
View file

@ -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

39
slatec/acosh.f
View file

@ -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

90
slatec/ai.f
View file

@ -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

133
slatec/aie.f
View file

@ -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

63
slatec/albeta.f
View file

@ -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

38
slatec/algams.f
View file

@ -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

35
slatec/ali.f
View file

@ -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

70
slatec/alngam.f
View file

@ -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

78
slatec/alnrel.f
View file

@ -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

74
slatec/asinh.f
View file

@ -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

144
slatec/asyik.f
View file

@ -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

491
slatec/asyjy.f
View file

@ -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

72
slatec/atanh.f
View file

@ -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

178
slatec/avint.f
View file

@ -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

105
slatec/bakvec.f
View file

@ -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

190
slatec/balanc.f
View file

@ -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

101
slatec/balbak.f
View file

@ -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

288
slatec/bandr.f
View file

@ -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

352
slatec/bandv.f
View file

@ -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

33
slatec/bcrh.f
View file

@ -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

36
slatec/bdiff.f
View file

@ -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

462
slatec/besi.f
View file

@ -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

71
slatec/besi0.f
View file

@ -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

129
slatec/besi0e.f
View file

@ -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

76
slatec/besi1.f
View file

@ -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

137
slatec/besi1e.f
View file

@ -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

504
slatec/besj.f
View file

@ -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

136
slatec/besj0.f
View file

@ -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

138
slatec/besj1.f
View file

@ -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

277
slatec/besk.f
View file

@ -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

76
slatec/besk0.f
View file

@ -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

119
slatec/besk0e.f
View file

@ -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

80
slatec/besk1.f
View file

@ -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

124
slatec/besk1e.f
View file

@ -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

77
slatec/beskes.f
View file

@ -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

388
slatec/besknu.f
View file

@ -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

50
slatec/besks.f
View file

@ -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

200
slatec/besy.f
View file

@ -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

141
slatec/besy0.f
View file

@ -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

145
slatec/besy1.f
View file

@ -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

353
slatec/besynu.f
View file

@ -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

51
slatec/beta.f
View file

@ -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

118
slatec/betai.f
View file

@ -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

134
slatec/bfqad.f
View file

@ -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

130
slatec/bi.f
View file

@ -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

206
slatec/bie.f
View file

@ -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

73
slatec/binom.f
View file

@ -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

238
slatec/bint4.f
View file

@ -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

187
slatec/bintk.f
View file

@ -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

284
slatec/bisect.f
View file

@ -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

260
slatec/bkias.f
View file

@ -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

86
slatec/bkisr.f
View file

@ -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

45
slatec/bksol.f
View file

@ -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

249
slatec/blktr1.f
View file

@ -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

264
slatec/blktri.f
View file

@ -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

271
slatec/bndacc.f
View file

@ -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

255
slatec/bndsol.f
View file

@ -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

137
slatec/bnfac.f
View file

@ -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

79
slatec/bnslv.f
View file

@ -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

306
slatec/bqr.f
View file

@ -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

193
slatec/bsgq8.f
View file

@ -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

351
slatec/bskin.f
View file

@ -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

296
slatec/bspdoc.f
View file

@ -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

106
slatec/bspdr.f
View file

@ -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

138
slatec/bspev.f
View file

@ -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

70
slatec/bsplvd.f
View file

@ -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

47
slatec/bsplvn.f
View file

@ -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

95
slatec/bsppp.f
View file

@ -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

163
slatec/bspvd.f
View file

@ -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

124
slatec/bspvn.f
View file

@ -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

144
slatec/bsqad.f
View file

@ -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

33
slatec/bsrh.f
View file

@ -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

165
slatec/bvalu.f
View file

@ -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

102
slatec/bvder.f
View file

@ -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

294
slatec/bvpor.f
View file

@ -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

694
slatec/bvsup.f
View file

@ -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

42
slatec/c0lgmc.f
View file

@ -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

68
slatec/c1merg.f
View file

@ -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

89
slatec/c9lgmc.f
View file

@ -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

73
slatec/c9ln2r.f
View file

@ -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

101
slatec/cacai.f
View file

@ -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

160
slatec/cacon.f
View file

@ -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

30
slatec/cacos.f
View file

@ -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

29
slatec/cacosh.f
View file

@ -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

342
slatec/cairy.f
View file

@ -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

31
slatec/carg.f
View file

@ -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

66
slatec/casin.f
View file

@ -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

29
slatec/casinh.f
View file

@ -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

136
slatec/casyi.f
View file

@ -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

76
slatec/catan.f
View file

@ -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

47
slatec/catan2.f
View file

@ -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

29
slatec/catanh.f
View file

@ -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

73
slatec/caxpy.f
View file

@ -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

108
slatec/cbabk2.f
View file

@ -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

207
slatec/cbal.f
View file

@ -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

331
slatec/cbesh.f
View file

@ -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

261
slatec/cbesi.f
View file

@ -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

259
slatec/cbesj.f
View file

@ -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

281
slatec/cbesk.f
View file

@ -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

Some files were not shown because too many files have changed in this diff Show more