MINICERN/mathlib/gen/c/r5dp.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 C309R5(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)  (COMPLEX)
  15 C
  16       IMPLICIT COMPLEX*16(A-H,O-Z)
  17       LOGICAL LPR,ETANE0
  18       DOUBLE PRECISION EPS,ERR,FPMIN,FPMAX,ABSC,SMALL,PX
  19
  20
  21 #if defined(CERNLIB_QF2C)
  22 #include "defdr.inc"
  23 #endif
  24       ABSC(W)=ABS(DREAL(W))+ABS(DIMAG(W))
  25
  26       FCL=1
  27       XI=1/X
  28       PK=ZL+1
  29       PX=PK+LIMIT
  30       EK=ETA/PK
  31       F=EK+PK*XI
  32       IF(ABSC(F) .LT. FPMIN) F=FPMIN
  33       D=0
  34       C=F
  35       SMALL=SQRT(FPMIN)
  36       RK2=1+EK*EK
  37 C
  38 C ***   begin CF1 loop on PK = k = lambda + 1
  39 C
  40    10 PK1=PK+1
  41       TPK1=PK+PK1
  42       IF(ETANE0) THEN
  43        EK=ETA/PK
  44        RK2=1+EK*EK
  45        TK=TPK1*(XI+EK/PK1)
  46       ELSE
  47        TK=TPK1*XI
  48       END IF
  49       C=TK-RK2/C
  50       D=TK-RK2*D
  51       IF(ABSC(C) .LT. FPMIN) C=FPMIN
  52       IF(ABSC(D) .LT. FPMIN) D=FPMIN
  53       D=1/D
  54       DF=D*C
  55       F=F*DF
  56       FCL=FCL*D*TPK1*XI
  57       IF(ABSC(FCL) .LT. SMALL) FCL=FCL/SMALL
  58       IF(ABSC(FCL) .GT. FPMAX) FCL=FCL*FPMIN
  59       PK=PK1
  60       IF(DREAL(PK) .LE. PX) THEN
  61        IF(ABSC(DF-1) .GE. EPS) GO TO 10
  62        NFP=PK-ZL-1
  63        ERR=EPS*SQRT(REAL(NFP))
  64        C309R5=F
  65       ELSE
  66        IF(LPR) WRITE (6,1000) LIMIT,ABS(X)
  67        ERR=2
  68       END IF
  69       RETURN
  70  1000 FORMAT(1X,'***** CERN C309 WCLBES ... CF1 (COMPLEX) HAS FAILED ',
  71      1'TO CONVERGE AFTER',I10,' ITERATIONS AS ABS(X) =',F15.0)
  72       END
  73 #endif