Fcalva/OpenLibm
1
0
Fork 0
mirror of https://git.planet-casio.com/Lephenixnoir/OpenLibm.git synced 2025-01-01 06:23:39 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions
OpenLibm/slatec/cbknu.f
Viral B. Shah c977aa998f Add Makefile.extras to build libopenlibm-extras. 
Replace amos with slatec
2012-12-31 16:37:05 -05:00

466 lines
14 KiB
Fortran
Raw Blame History

*DECK CBKNU
SUBROUTINE CBKNU (Z, FNU, KODE, N, Y, NZ, TOL, ELIM, ALIM)
C***BEGIN PROLOGUE CBKNU
C***SUBSIDIARY
C***PURPOSE Subsidiary to CAIRY, CBESH, CBESI and CBESK
C***LIBRARY SLATEC
C***TYPE ALL (CBKNU-A, ZBKNU-A)
C***AUTHOR Amos, D. E., (SNL)
C***DESCRIPTION
C
C CBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE
C
C***SEE ALSO CAIRY, CBESH, CBESI, CBESK
C***ROUTINES CALLED CKSCL, CSHCH, CUCHK, GAMLN, I1MACH, R1MACH
C***REVISION HISTORY (YYMMDD)
C 830501 DATE WRITTEN
C 910415 Prologue converted to Version 4.0 format. (BAB)
C***END PROLOGUE CBKNU
C
COMPLEX CCH, CK, COEF, CONE, CRSC, CS, CSCL, CSH, CSR, CSS, CTWO,
* CZ, CZERO, F, FMU, P, PT, P1, P2, Q, RZ, SMU, ST, S1, S2, Y, Z,
* ZD, CELM, CY
REAL AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, CC, DNU,
* DNU2, ELIM, ETEST, FC, FHS, FK, FKS, FNU, FPI, G1, G2, HPI, PI,
* P2I, P2M, P2R, RK, RTHPI, R1, S, SPI, TM, TOL, TTH, T1, T2, XX,
* YY, GAMLN, R1MACH, HELIM, ELM, XD, YD, ALAS, AS
INTEGER I, IDUM, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N,
* NZ, I1MACH, NW, J, IC, INUB
DIMENSION BRY(3), CC(8), CSS(3), CSR(3), Y(N), CY(2)
C
DATA KMAX / 30 /
DATA R1 / 2.0E0 /
DATA CZERO,CONE,CTWO /(0.0E0,0.0E0),(1.0E0,0.0E0),(2.0E0,0.0E0)/
C
DATA PI, RTHPI, SPI ,HPI, FPI, TTH /
1 3.14159265358979324E0, 1.25331413731550025E0,
2 1.90985931710274403E0, 1.57079632679489662E0,
3 1.89769999331517738E0, 6.66666666666666666E-01/
C
DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/
1 5.77215664901532861E-01, -4.20026350340952355E-02,
2 -4.21977345555443367E-02, 7.21894324666309954E-03,
3 -2.15241674114950973E-04, -2.01348547807882387E-05,
4 1.13302723198169588E-06, 6.11609510448141582E-09/
C
C***FIRST EXECUTABLE STATEMENT CBKNU
XX = REAL(Z)
YY = AIMAG(Z)
CAZ = ABS(Z)
CSCL = CMPLX(1.0E0/TOL,0.0E0)
CRSC = CMPLX(TOL,0.0E0)
CSS(1) = CSCL
CSS(2) = CONE
CSS(3) = CRSC
CSR(1) = CRSC
CSR(2) = CONE
CSR(3) = CSCL
BRY(1) = 1.0E+3*R1MACH(1)/TOL
BRY(2) = 1.0E0/BRY(1)
BRY(3) = R1MACH(2)
NZ = 0
IFLAG = 0
KODED = KODE
RZ = CTWO/Z
INU = FNU+0.5E0
DNU = FNU - INU
IF (ABS(DNU).EQ.0.5E0) GO TO 110
DNU2 = 0.0E0
IF (ABS(DNU).GT.TOL) DNU2 = DNU*DNU
IF (CAZ.GT.R1) GO TO 110
C-----------------------------------------------------------------------
C SERIES FOR ABS(Z).LE.R1
C-----------------------------------------------------------------------
FC = 1.0E0
SMU = CLOG(RZ)
FMU = SMU*CMPLX(DNU,0.0E0)
CALL CSHCH(FMU, CSH, CCH)
IF (DNU.EQ.0.0E0) GO TO 10
FC = DNU*PI
FC = FC/SIN(FC)
SMU = CSH*CMPLX(1.0E0/DNU,0.0E0)
10 CONTINUE
A2 = 1.0E0 + DNU
C-----------------------------------------------------------------------
C GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU)
C-----------------------------------------------------------------------
T2 = EXP(-GAMLN(A2,IDUM))
T1 = 1.0E0/(T2*FC)
IF (ABS(DNU).GT.0.1E0) GO TO 40
C-----------------------------------------------------------------------
C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
C-----------------------------------------------------------------------
AK = 1.0E0
S = CC(1)
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 = 0.5E0*(T1+T2)*FC
G1 = G1*FC
F = CMPLX(G1,0.0E0)*CCH + SMU*CMPLX(G2,0.0E0)
PT = CEXP(FMU)
P = CMPLX(0.5E0/T2,0.0E0)*PT
Q = CMPLX(0.5E0/T1,0.0E0)/PT
S1 = F
S2 = P
AK = 1.0E0
A1 = 1.0E0
CK = CONE
BK = 1.0E0 - DNU2
IF (INU.GT.0 .OR. N.GT.1) GO TO 80
C-----------------------------------------------------------------------
C GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1
C-----------------------------------------------------------------------
IF (CAZ.LT.TOL) GO TO 70
CZ = Z*Z*CMPLX(0.25E0,0.0E0)
T1 = 0.25E0*CAZ*CAZ
60 CONTINUE
F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0)
P = P*CMPLX(1.0E0/(AK-DNU),0.0E0)
Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0)
RK = 1.0E0/AK
CK = CK*CZ*CMPLX(RK,0.0)
S1 = S1 + CK*F
A1 = A1*T1*RK
BK = BK + AK + AK + 1.0E0
AK = AK + 1.0E0
IF (A1.GT.TOL) GO TO 60
70 CONTINUE
Y(1) = S1
IF (KODED.EQ.1) RETURN
Y(1) = S1*CEXP(Z)
RETURN
C-----------------------------------------------------------------------
C GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE
C-----------------------------------------------------------------------
80 CONTINUE
IF (CAZ.LT.TOL) GO TO 100
CZ = Z*Z*CMPLX(0.25E0,0.0E0)
T1 = 0.25E0*CAZ*CAZ
90 CONTINUE
F = (F*CMPLX(AK,0.0E0)+P+Q)*CMPLX(1.0E0/BK,0.0E0)
P = P*CMPLX(1.0E0/(AK-DNU),0.0E0)
Q = Q*CMPLX(1.0E0/(AK+DNU),0.0E0)
RK = 1.0E0/AK
CK = CK*CZ*CMPLX(RK,0.0E0)
S1 = S1 + CK*F
S2 = S2 + CK*(P-F*CMPLX(AK,0.0E0))
A1 = A1*T1*RK
BK = BK + AK + AK + 1.0E0
AK = AK + 1.0E0
IF (A1.GT.TOL) GO TO 90
100 CONTINUE
KFLAG = 2
BK = REAL(SMU)
A1 = FNU + 1.0E0
AK = A1*ABS(BK)
IF (AK.GT.ALIM) KFLAG = 3
P2 = S2*CSS(KFLAG)
S2 = P2*RZ
S1 = S1*CSS(KFLAG)
IF (KODED.EQ.1) GO TO 210
F = CEXP(Z)
S1 = S1*F
S2 = S2*F
GO TO 210
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
C-----------------------------------------------------------------------
110 CONTINUE
COEF = CMPLX(RTHPI,0.0E0)/CSQRT(Z)
KFLAG = 2
IF (KODED.EQ.2) GO TO 120
IF (XX.GT.ALIM) GO TO 290
C BLANK LINE
A1 = EXP(-XX)*REAL(CSS(KFLAG))
PT = CMPLX(A1,0.0E0)*CMPLX(COS(YY),-SIN(YY))
COEF = COEF*PT
120 CONTINUE
IF (ABS(DNU).EQ.0.5E0) GO TO 300
C-----------------------------------------------------------------------
C MILLER ALGORITHM FOR ABS(Z).GT.R1
C-----------------------------------------------------------------------
AK = COS(PI*DNU)
AK = ABS(AK)
IF (AK.EQ.0.0E0) GO TO 300
FHS = ABS(0.25E0-DNU2)
IF (FHS.EQ.0.0E0) GO TO 300
C-----------------------------------------------------------------------
C COMPUTE R2=F(E). IF ABS(Z).GE.R2, USE FORWARD RECURRENCE TO
C DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON
C 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(11))=
C TOL WHERE B IS THE BASE OF THE ARITHMETIC.
C-----------------------------------------------------------------------
T1 = (I1MACH(11)-1)*R1MACH(5)*3.321928094E0
T1 = MAX(T1,12.0E0)
T1 = MIN(T1,60.0E0)
T2 = TTH*T1 - 6.0E0
IF (XX.NE.0.0E0) GO TO 130
T1 = HPI
GO TO 140
130 CONTINUE
T1 = ATAN(YY/XX)
T1 = ABS(T1)
140 CONTINUE
IF (T2.GT.CAZ) GO TO 170
C-----------------------------------------------------------------------
C FORWARD RECURRENCE LOOP WHEN ABS(Z).GE.R2
C-----------------------------------------------------------------------
ETEST = AK/(PI*CAZ*TOL)
FK = 1.0E0
IF (ETEST.LT.1.0E0) GO TO 180
FKS = 2.0E0
RK = CAZ + CAZ + 2.0E0
A1 = 0.0E0
A2 = 1.0E0
DO 150 I=1,KMAX
AK = FHS/FKS
BK = RK/(FK+1.0E0)
TM = A2
A2 = BK*A2 - AK*A1
A1 = TM
RK = RK + 2.0E0
FKS = FKS + FK + FK + 2.0E0
FHS = FHS + FK + FK
FK = FK + 1.0E0
TM = ABS(A2)*FK
IF (ETEST.LT.TM) GO TO 160
150 CONTINUE
GO TO 310
160 CONTINUE
FK = FK + SPI*T1*SQRT(T2/CAZ)
FHS = ABS(0.25E0-DNU2)
GO TO 180
170 CONTINUE
C-----------------------------------------------------------------------
C COMPUTE BACKWARD INDEX K FOR ABS(Z).LT.R2
C-----------------------------------------------------------------------
A2 = SQRT(CAZ)
AK = FPI*AK/(TOL*SQRT(A2))
AA = 3.0E0*T1/(1.0E0+CAZ)
BB = 14.7E0*T1/(28.0E0+CAZ)
AK = (ALOG(AK)+CAZ*COS(AA)/(1.0E0+0.008E0*CAZ))/COS(BB)
FK = 0.12125E0*AK*AK/CAZ + 1.5E0
180 CONTINUE
K = FK
C-----------------------------------------------------------------------
C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM
C-----------------------------------------------------------------------
FK = K
FKS = FK*FK
P1 = CZERO
P2 = CMPLX(TOL,0.0E0)
CS = P2
DO 190 I=1,K
A1 = FKS - FK
A2 = (FKS+FK)/(A1+FHS)
RK = 2.0E0/(FK+1.0E0)
T1 = (FK+XX)*RK
T2 = YY*RK
PT = P2
P2 = (P2*CMPLX(T1,T2)-P1)*CMPLX(A2,0.0E0)
P1 = PT
CS = CS + P2
FKS = A1 - FK + 1.0E0
FK = FK - 1.0E0
190 CONTINUE
C-----------------------------------------------------------------------
C COMPUTE (P2/CS)=(P2/ABS(CS))*(CONJG(CS)/ABS(CS)) FOR BETTER
C SCALING
C-----------------------------------------------------------------------
TM = ABS(CS)
PT = CMPLX(1.0E0/TM,0.0E0)
S1 = PT*P2
CS = CONJG(CS)*PT
S1 = COEF*S1*CS
IF (INU.GT.0 .OR. N.GT.1) GO TO 200
ZD = Z
IF(IFLAG.EQ.1) GO TO 270
GO TO 240
200 CONTINUE
C-----------------------------------------------------------------------
C COMPUTE P1/P2=(P1/ABS(P2)*CONJG(P2)/ABS(P2) FOR SCALING
C-----------------------------------------------------------------------
TM = ABS(P2)
PT = CMPLX(1.0E0/TM,0.0E0)
P1 = PT*P1
P2 = CONJG(P2)*PT
PT = P1*P2
S2 = S1*(CONE+(CMPLX(DNU+0.5E0,0.0E0)-PT)/Z)
C-----------------------------------------------------------------------
C FORWARD RECURSION ON THE THREE TERM RECURSION RELATION WITH
C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3
C-----------------------------------------------------------------------
210 CONTINUE
CK = CMPLX(DNU+1.0E0,0.0E0)*RZ
IF (N.EQ.1) INU = INU - 1
IF (INU.GT.0) GO TO 220
IF (N.EQ.1) S1=S2
ZD = Z
IF(IFLAG.EQ.1) GO TO 270
GO TO 240
220 CONTINUE
INUB = 1
IF (IFLAG.EQ.1) GO TO 261
225 CONTINUE
P1 = CSR(KFLAG)
ASCLE = BRY(KFLAG)
DO 230 I=INUB,INU
ST = S2
S2 = CK*S2 + S1
S1 = ST
CK = CK + RZ
IF (KFLAG.GE.3) GO TO 230
P2 = S2*P1
P2R = REAL(P2)
P2I = AIMAG(P2)
P2R = ABS(P2R)
P2I = ABS(P2I)
P2M = MAX(P2R,P2I)
IF (P2M.LE.ASCLE) GO TO 230
KFLAG = KFLAG + 1
ASCLE = BRY(KFLAG)
S1 = S1*P1
S2 = P2
S1 = S1*CSS(KFLAG)
S2 = S2*CSS(KFLAG)
P1 = CSR(KFLAG)
230 CONTINUE
IF (N.EQ.1) S1 = S2
240 CONTINUE
Y(1) = S1*CSR(KFLAG)
IF (N.EQ.1) RETURN
Y(2) = S2*CSR(KFLAG)
IF (N.EQ.2) RETURN
KK = 2
250 CONTINUE
KK = KK + 1
IF (KK.GT.N) RETURN
P1 = CSR(KFLAG)
ASCLE = BRY(KFLAG)
DO 260 I=KK,N
P2 = S2
S2 = CK*S2 + S1
S1 = P2
CK = CK + RZ
P2 = S2*P1
Y(I) = P2
IF (KFLAG.GE.3) GO TO 260
P2R = REAL(P2)
P2I = AIMAG(P2)
P2R = ABS(P2R)
P2I = ABS(P2I)
P2M = MAX(P2R,P2I)
IF (P2M.LE.ASCLE) GO TO 260
KFLAG = KFLAG + 1
ASCLE = BRY(KFLAG)
S1 = S1*P1
S2 = P2
S1 = S1*CSS(KFLAG)
S2 = S2*CSS(KFLAG)
P1 = CSR(KFLAG)
260 CONTINUE
RETURN
C-----------------------------------------------------------------------
C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW
C-----------------------------------------------------------------------
261 CONTINUE
HELIM = 0.5E0*ELIM
ELM = EXP(-ELIM)
CELM = CMPLX(ELM,0.0)
ASCLE = BRY(1)
ZD = Z
XD = XX
YD = YY
IC = -1
J = 2
DO 262 I=1,INU
ST = S2
S2 = CK*S2+S1
S1 = ST
CK = CK+RZ
AS = ABS(S2)
ALAS = ALOG(AS)
P2R = -XD+ALAS
IF(P2R.LT.(-ELIM)) GO TO 263
P2 = -ZD+CLOG(S2)
P2R = REAL(P2)
P2I = AIMAG(P2)
P2M = EXP(P2R)/TOL
P1 = CMPLX(P2M,0.0E0)*CMPLX(COS(P2I),SIN(P2I))
CALL CUCHK(P1,NW,ASCLE,TOL)
IF(NW.NE.0) GO TO 263
J=3-J
CY(J) = P1
IF(IC.EQ.(I-1)) GO TO 264
IC = I
GO TO 262
263 CONTINUE
IF(ALAS.LT.HELIM) GO TO 262
XD = XD-ELIM
S1 = S1*CELM
S2 = S2*CELM
ZD = CMPLX(XD,YD)
262 CONTINUE
IF(N.EQ.1) S1 = S2
GO TO 270
264 CONTINUE
KFLAG = 1
INUB = I+1
S2 = CY(J)
J = 3 - J
S1 = CY(J)
IF(INUB.LE.INU) GO TO 225
IF(N.EQ.1) S1 = S2
GO TO 240
270 CONTINUE
Y(1) = S1
IF (N.EQ.1) GO TO 280
Y(2) = S2
280 CONTINUE
ASCLE = BRY(1)
CALL CKSCL(ZD, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM)
INU = N - NZ
IF (INU.LE.0) RETURN
KK = NZ + 1
S1 = Y(KK)
Y(KK) = S1*CSR(1)
IF (INU.EQ.1) RETURN
KK = NZ + 2
S2 = Y(KK)
Y(KK) = S2*CSR(1)
IF (INU.EQ.2) RETURN
T2 = FNU + (KK-1)
CK = CMPLX(T2,0.0E0)*RZ
KFLAG = 1
GO TO 250
290 CONTINUE
C-----------------------------------------------------------------------
C SCALE BY EXP(Z), IFLAG = 1 CASES
C-----------------------------------------------------------------------
KODED = 2
IFLAG = 1
KFLAG = 2
GO TO 120
C-----------------------------------------------------------------------
C FNU=HALF ODD INTEGER CASE, DNU=-0.5
C-----------------------------------------------------------------------
300 CONTINUE
S1 = COEF
S2 = COEF
GO TO 210
310 CONTINUE
NZ=-2
RETURN
END
Reference in a new issue View git blame Copy permalink