mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
277 lines
8.4 KiB
Fortran
277 lines
8.4 KiB
Fortran
*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
|