mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
112 lines
2.8 KiB
Fortran
112 lines
2.8 KiB
Fortran
*DECK CKSCL
|
|
SUBROUTINE CKSCL (ZR, FNU, N, Y, NZ, RZ, ASCLE, TOL, ELIM)
|
|
C***BEGIN PROLOGUE CKSCL
|
|
C***SUBSIDIARY
|
|
C***PURPOSE Subsidiary to CBKNU, CUNK1 and CUNK2
|
|
C***LIBRARY SLATEC
|
|
C***TYPE ALL (CKSCL-A, ZKSCL-A)
|
|
C***AUTHOR Amos, D. E., (SNL)
|
|
C***DESCRIPTION
|
|
C
|
|
C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE
|
|
C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN
|
|
C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL.
|
|
C
|
|
C***SEE ALSO CBKNU, CUNK1, CUNK2
|
|
C***ROUTINES CALLED CUCHK
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C ?????? DATE WRITTEN
|
|
C 910415 Prologue converted to Version 4.0 format. (BAB)
|
|
C***END PROLOGUE CKSCL
|
|
COMPLEX CK, CS, CY, CZERO, RZ, S1, S2, Y, ZR, ZD, CELM
|
|
REAL AA, ASCLE, ACS, AS, CSI, CSR, ELIM, FN, FNU, TOL, XX, ZRI,
|
|
* ELM, ALAS, HELIM
|
|
INTEGER I, IC, K, KK, N, NN, NW, NZ
|
|
DIMENSION Y(N), CY(2)
|
|
DATA CZERO / (0.0E0,0.0E0) /
|
|
C***FIRST EXECUTABLE STATEMENT CUCHK
|
|
NZ = 0
|
|
IC = 0
|
|
XX = REAL(ZR)
|
|
NN = MIN(2,N)
|
|
DO 10 I=1,NN
|
|
S1 = Y(I)
|
|
CY(I) = S1
|
|
AS = ABS(S1)
|
|
ACS = -XX + ALOG(AS)
|
|
NZ = NZ + 1
|
|
Y(I) = CZERO
|
|
IF (ACS.LT.(-ELIM)) GO TO 10
|
|
CS = -ZR + CLOG(S1)
|
|
CSR = REAL(CS)
|
|
CSI = AIMAG(CS)
|
|
AA = EXP(CSR)/TOL
|
|
CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI))
|
|
CALL CUCHK(CS, NW, ASCLE, TOL)
|
|
IF (NW.NE.0) GO TO 10
|
|
Y(I) = CS
|
|
NZ = NZ - 1
|
|
IC = I
|
|
10 CONTINUE
|
|
IF (N.EQ.1) RETURN
|
|
IF (IC.GT.1) GO TO 20
|
|
Y(1) = CZERO
|
|
NZ = 2
|
|
20 CONTINUE
|
|
IF (N.EQ.2) RETURN
|
|
IF (NZ.EQ.0) RETURN
|
|
FN = FNU + 1.0E0
|
|
CK = CMPLX(FN,0.0E0)*RZ
|
|
S1 = CY(1)
|
|
S2 = CY(2)
|
|
HELIM = 0.5E0*ELIM
|
|
ELM = EXP(-ELIM)
|
|
CELM = CMPLX(ELM,0.0E0)
|
|
ZRI =AIMAG(ZR)
|
|
ZD = ZR
|
|
C
|
|
C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF
|
|
C S2 GETS LARGER THAN EXP(ELIM/2)
|
|
C
|
|
DO 30 I=3,N
|
|
KK = I
|
|
CS = S2
|
|
S2 = CK*S2 + S1
|
|
S1 = CS
|
|
CK = CK + RZ
|
|
AS = ABS(S2)
|
|
ALAS = ALOG(AS)
|
|
ACS = -XX + ALAS
|
|
NZ = NZ + 1
|
|
Y(I) = CZERO
|
|
IF (ACS.LT.(-ELIM)) GO TO 25
|
|
CS = -ZD + CLOG(S2)
|
|
CSR = REAL(CS)
|
|
CSI = AIMAG(CS)
|
|
AA = EXP(CSR)/TOL
|
|
CS = CMPLX(AA,0.0E0)*CMPLX(COS(CSI),SIN(CSI))
|
|
CALL CUCHK(CS, NW, ASCLE, TOL)
|
|
IF (NW.NE.0) GO TO 25
|
|
Y(I) = CS
|
|
NZ = NZ - 1
|
|
IF (IC.EQ.(KK-1)) GO TO 40
|
|
IC = KK
|
|
GO TO 30
|
|
25 CONTINUE
|
|
IF(ALAS.LT.HELIM) GO TO 30
|
|
XX = XX-ELIM
|
|
S1 = S1*CELM
|
|
S2 = S2*CELM
|
|
ZD = CMPLX(XX,ZRI)
|
|
30 CONTINUE
|
|
NZ = N
|
|
IF(IC.EQ.N) NZ=N-1
|
|
GO TO 45
|
|
40 CONTINUE
|
|
NZ = KK - 2
|
|
45 CONTINUE
|
|
DO 50 K=1,NZ
|
|
Y(K) = CZERO
|
|
50 CONTINUE
|
|
RETURN
|
|
END
|