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