src/numerical/slatec/fortran/zkscl.f

   1 *DECK ZKSCL
   2       SUBROUTINE ZKSCL (ZRR, ZRI, FNU, N, YR, YI, NZ, RZR, RZI, ASCLE,
   3      +   TOL, ELIM)
   4 C***BEGIN PROLOGUE  ZKSCL
   5 C***SUBSIDIARY
   6 C***PURPOSE  Subsidiary to ZBESK
   7 C***LIBRARY   SLATEC
   8 C***TYPE      ALL (CKSCL-A, ZKSCL-A)
   9 C***AUTHOR  Amos, D. E., (SNL)
  10 C***DESCRIPTION
  11 C
  12 C     SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE
  13 C     ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN
  14 C     RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL.
  15 C
  16 C***SEE ALSO  ZBESK
  17 C***ROUTINES CALLED  ZABS, ZLOG, ZUCHK
  18 C***REVISION HISTORY  (YYMMDD)
  19 C   830501  DATE WRITTEN
  20 C   910415  Prologue converted to Version 4.0 format.  (BAB)
  21 C   930122  Added ZLOG to EXTERNAL statement.  (RWC)
  22 C***END PROLOGUE  ZKSCL
  23 C     COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM
  24       DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI,
  25      * CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I,
  26      * S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS,
  27      * ZDR, ZDI, CELMR, ELM, HELIM, ALAS
  28       INTEGER I, IC, IDUM, KK, N, NN, NW, NZ
  29       DIMENSION YR(N), YI(N), CYR(2), CYI(2)
  30       EXTERNAL ZABS, ZLOG
  31       DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 /
  32 C***FIRST EXECUTABLE STATEMENT  ZKSCL
  33       NZ = 0
  34       IC = 0
  35       NN = MIN(2,N)
  36       DO 10 I=1,NN
  37         S1R = YR(I)
  38         S1I = YI(I)
  39         CYR(I) = S1R
  40         CYI(I) = S1I
  41         AS = ZABS(S1R,S1I)
  42         ACS = -ZRR + LOG(AS)
  43         NZ = NZ + 1
  44         YR(I) = ZEROR
  45         YI(I) = ZEROI
  46         IF (ACS.LT.(-ELIM)) GO TO 10
  47         CALL ZLOG(S1R, S1I, CSR, CSI, IDUM)
  48         CSR = CSR - ZRR
  49         CSI = CSI - ZRI
  50         STR = EXP(CSR)/TOL
  51         CSR = STR*COS(CSI)
  52         CSI = STR*SIN(CSI)
  53         CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL)
  54         IF (NW.NE.0) GO TO 10
  55         YR(I) = CSR
  56         YI(I) = CSI
  57         IC = I
  58         NZ = NZ - 1
  59    10 CONTINUE
  60       IF (N.EQ.1) RETURN
  61       IF (IC.GT.1) GO TO 20
  62       YR(1) = ZEROR
  63       YI(1) = ZEROI
  64       NZ = 2
  65    20 CONTINUE
  66       IF (N.EQ.2) RETURN
  67       IF (NZ.EQ.0) RETURN
  68       FN = FNU + 1.0D0
  69       CKR = FN*RZR
  70       CKI = FN*RZI
  71       S1R = CYR(1)
  72       S1I = CYI(1)
  73       S2R = CYR(2)
  74       S2I = CYI(2)
  75       HELIM = 0.5D0*ELIM
  76       ELM = EXP(-ELIM)
  77       CELMR = ELM
  78       ZDR = ZRR
  79       ZDI = ZRI
  80 C
  81 C     FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF
  82 C     S2 GETS LARGER THAN EXP(ELIM/2)
  83 C
  84       DO 30 I=3,N
  85         KK = I
  86         CSR = S2R
  87         CSI = S2I
  88         S2R = CKR*CSR - CKI*CSI + S1R
  89         S2I = CKI*CSR + CKR*CSI + S1I
  90         S1R = CSR
  91         S1I = CSI
  92         CKR = CKR + RZR
  93         CKI = CKI + RZI
  94         AS = ZABS(S2R,S2I)
  95         ALAS = LOG(AS)
  96         ACS = -ZDR + ALAS
  97         NZ = NZ + 1
  98         YR(I) = ZEROR
  99         YI(I) = ZEROI
 100         IF (ACS.LT.(-ELIM)) GO TO 25
 101         CALL ZLOG(S2R, S2I, CSR, CSI, IDUM)
 102         CSR = CSR - ZDR
 103         CSI = CSI - ZDI
 104         STR = EXP(CSR)/TOL
 105         CSR = STR*COS(CSI)
 106         CSI = STR*SIN(CSI)
 107         CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL)
 108         IF (NW.NE.0) GO TO 25
 109         YR(I) = CSR
 110         YI(I) = CSI
 111         NZ = NZ - 1
 112         IF (IC.EQ.KK-1) GO TO 40
 113         IC = KK
 114         GO TO 30
 115    25   CONTINUE
 116         IF(ALAS.LT.HELIM) GO TO 30
 117         ZDR = ZDR - ELIM
 118         S1R = S1R*CELMR
 119         S1I = S1I*CELMR
 120         S2R = S2R*CELMR
 121         S2I = S2I*CELMR
 122    30 CONTINUE
 123       NZ = N
 124       IF(IC.EQ.N) NZ=N-1
 125       GO TO 45
 126    40 CONTINUE
 127       NZ = KK - 2
 128    45 CONTINUE
 129       DO 50 I=1,NZ
 130         YR(I) = ZEROR
 131         YI(I) = ZEROI
 132    50 CONTINUE
 133       RETURN
 134       END