MINICERN/mathlib/gen/c/r4dp.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:01:57  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10 #if defined(CERNLIB_DOUBLE)
  11       FUNCTION C309R4(X,ETA,ZL,EPS,FCL,TPK1,ETANE0,LIMIT,ERR,NFP,
  12      1              FPMIN,FPMAX,LPR)
  13 C
  14 C ***   Evaluate CF1 = F'(ZL,ETA,X)/F(ZL,ETA,X)    (REAL)
  15 C
  16       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
  17       LOGICAL LPR,ETANE0
  18
  19       FCL=1
  20       XI=1/X
  21       PK=ZL+1
  22       PX=PK+LIMIT
  23       EK=ETA/PK
  24       F=EK+PK*XI
  25       IF(ABS(F) .LT. FPMIN) F=FPMIN
  26       D=0
  27       C=F
  28       SMALL=SQRT(FPMIN)
  29       RK2=1+EK*EK
  30 C
  31 C ***   begin CF1 loop on PK = k = lambda + 1
  32 C
  33    10 PK1=PK+1
  34       TPK1=PK+PK1
  35       IF(ETANE0) THEN
  36        EK=ETA/PK
  37        RK2=1+EK*EK
  38        TK=TPK1*(XI+EK/PK1)
  39       ELSE
  40        TK=TPK1*XI
  41       END IF
  42       C=TK-RK2/C
  43       D=TK-RK2*D
  44       IF(ABS(C) .LT. FPMIN) C=FPMIN
  45       IF(ABS(D) .LT. FPMIN) D=FPMIN
  46       D=1/D
  47       DF=D*C
  48       F=F*DF
  49       FCL=FCL*D*TPK1*XI
  50       IF(ABS(FCL) .LT. SMALL) FCL=FCL/SMALL
  51       IF(ABS(FCL) .GT. FPMAX) FCL=FCL*FPMIN
  52       PK=PK1
  53       IF(PK .LE. PX) THEN
  54        IF(ABS(DF-1) .GE. EPS) GO TO 10
  55        NFP=PK-ZL-1
  56        ERR=EPS*SQRT(REAL(NFP))
  57        C309R4=F
  58       ELSE
  59        IF(LPR) WRITE (6,1000) LIMIT,ABS(X)
  60        ERR=2
  61       END IF
  62       RETURN
  63  1000 FORMAT(1X,'***** CERN C309 WCLBES ... CF1 (REAL) HAS FAILED ',
  64      1'TO CONVERGE AFTER',I10,' ITERATIONS AS ABS(X) =',F15.0)
  65       END
  66 #endif