ckscl.f
112 lines
| 2.8 KiB
| text/x-fortran
|
FortranFixedLexer
| r1601 | *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 | ||||
