This commit was generated by cvs2svn to compensate for changes in r2,
[u/mrichter/AliRoot.git] / 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