MINICERN/mathlib/gen/c/r1dp.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:01:56  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10 #if defined(CERNLIB_DOUBLE)
  11       FUNCTION C309R1(X,ETA,ZL,PM,EPS,LIMIT,ERR,NPQ,ACC8,ACCH,
  12      1             LPR,ACCUR,DELL)
  13 C
  14 C                                    (omega)        (omega)
  15 C *** Evaluate  CF2  = p + PM.q  =  H   (ETA,X)' / H   (ETA,X)
  16 C                                    ZL             ZL
  17 C     where PM = omega.i
  18 C
  19       IMPLICIT COMPLEX*16(A-H,O-Z)
  20       LOGICAL LPR
  21       DOUBLE PRECISION EPS,ERR,ACC8,ACCH,ACCUR,TA,RK
  22       DOUBLE PRECISION ABSC,HALF
  23
  24       PARAMETER(HALF = 1D0/2D0)
  25
  26 #if defined(CERNLIB_QF2C)
  27 #include "defdr.inc"
  28 #endif
  29       ABSC(W)=ABS(DREAL(W))+ABS(DIMAG(W))
  30
  31       TA=LIMIT+LIMIT
  32       ETAP=ETA*PM
  33       XI=1/X
  34       WI=ETAP+ETAP
  35       RK=0
  36       PQ=(1-ETA*XI)*PM
  37       AA=-(ETA*ETA+ZL*ZL+ZL)+ETAP
  38       BB=2*(X-ETA+PM)
  39       RL=XI*PM
  40       IF(ABSC(BB) .LT. ACCH) THEN
  41        RL=RL*AA/(AA+RK+WI)
  42        PQ=PQ+RL*(BB+PM+PM)
  43        AA=AA+2*(RK+1+WI)
  44        BB=BB+4*PM
  45        RK=RK+4
  46       END IF
  47       DD=1/BB
  48       DL=AA*DD*RL
  49    10 PQ=PQ+DL
  50       RK=RK+2
  51       AA=AA+RK+WI
  52       BB=BB+PM+PM
  53       DD=1/(AA*DD+BB)
  54       DL=DL*(BB*DD-1)
  55       ERR=ABSC(DL)/ABSC(PQ)
  56       IF(ERR .GE. MAX(EPS,ACC8*RK*HALF) .AND. RK .LE. TA) GO TO 10
  57 C
  58       NPQ=HALF*RK
  59       C309R1=PQ+DL
  60       IF(LPR .AND. NPQ .GE. LIMIT-1 .AND. ERR .GT. ACCUR)
  61      1 WRITE(6,1000) INT(DIMAG(PM)),NPQ,ERR,ZL+DELL
  62       RETURN
  63  1000 FORMAT(1X,'***** CERN C309 WCLBES ... ',
  64      2 'CF2(',I2,') NOT CONVERGED FULLY IN ',I7,' ITERATIONS'/1X,27X,
  65      3 'ERROR IN IRREGULAR SOLUTION =',1P,D11.2,' AT ZL = ',2F8.3)
  66       END
  67 #endif