MINICERN/mathlib/gen/g/coedis.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:47  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE COEDIS(RKA,BE2,I,J)
  11 C
  12 C     COEDIS COMPUTES THE ENDPOINTS T- AND T+ OF THE SUPPORT OF
  13 C     DISVAV(X,0).IT ALSO COMPUTES THE FOURIER COEFFICIENTS OF DISVAV(X,
  14 C
  15       COMMON /VAVILI/ T0,T1,T,OMEGA
  16       COMMON /VAVILO/ A(155),B(155),N
  17       COMMON /FORFCN/ SS,LFCN
  18       DIMENSION XP(8),XQ(6)
  19       DATA E,PI,RG /5E-4, 3.1415926535898, 0.5772156649015/
  20       DATA  XP
  21      + /9.29, 2.47, 0.89, 0.36, 0.15, 0.07, 0.03, 0.02/
  22       DATA  XQ
  23      + /0.012, 0.03, 0.08, 0.26, 0.87, 3.83/
  24 C
  25       LU=ABS(J)
  26       IF (RKA .LT. 0.01 .OR. RKA .GT. 10.0) GOTO 6
  27       IF (BE2 .LT. 0.0  .OR. BE2 .GT.  1.0) GOTO 8
  28 C
  29       Z=1.-BE2*(1.-RG)-LOG(E)/RKA
  30       T0=(LOG(E)/RKA-(1.+BE2*RG)-Z*LOG(RKA)-(Z+BE2)*(LOG(Z)
  31      1  +EXPINT(Z))+EXP(-Z))/Z
  32       DO 1 L = 1,8
  33       IF(RKA .GE. XP(L)) GO TO 11
  34     1 CONTINUE
  35       L=9
  36    11 P=-L-0.5
  37       DO 2 L = 1,6
  38       IF(RKA .LE. XQ(L)) GO TO 22
  39     2 CONTINUE
  40       L=7
  41    22 Q=L-7.5
  42       LFCN=3
  43       CALL VAVZRO(P,Q,X,RKA,BE2,LU)
  44       T1=(LOG(E)/RKA-(1.+BE2*RG))/X-LOG(RKA)-(1.+BE2/X)*(LOG(ABS(X))
  45      1  +EXPINT(X))+EXP(-X)/X
  46 C
  47       IF(J .GT. 0) WRITE(J,10) T0,T1
  48       T=T1-T0
  49       OMEGA=2.0*PI/T
  50       LFCN=1
  51       CALL VAVZRO(5.,155.,X,RKA,BE2,LU)
  52       N=X+1.
  53 C
  54       D=EXP(RKA*(1.+BE2*(RG-LOG(RKA))))
  55       A(N)=0.
  56       IF(I .EQ. 0) A(N)=OMEGA/PI
  57       N1=N-1
  58       Q=-1.
  59 C
  60       DO 3 K = 1,N1
  61       L=N-K
  62       X=OMEGA*K
  63       X1=X/RKA
  64       C1=LOG(X)-COSINT(X1)
  65       C2=SININT(X1)
  66       C3=SIN(X1)
  67       C4=COS(X1)
  68       F1=RKA*(BE2*C1-C4)-X*C2
  69       F2=X*C1+RKA*(C3+BE2*C2)+T0*X
  70       D1=Q*D*EXP(F1)/PI
  71       HS=D1*SIN(F2)
  72       HC=D1*COS(F2)
  73       IF(I .EQ. 0) GO TO 4
  74       A(L)=HS/K
  75       B(L)=HC/K
  76       A(N)=A(N)-2.0*Q*A(L)
  77       GO TO 3
  78     4 A(L)=HC*OMEGA
  79       B(L)=-HS*OMEGA
  80     3 Q=-Q
  81       RETURN
  82 C
  83     6 WRITE(LU,7) RKA
  84       RETURN
  85 C
  86     8 WRITE(LU,9) BE2
  87     7 FORMAT(/10X,'KAPPA ='  ,E10.3,' - OUT OF RANGE')
  88     9 FORMAT(/10X,'BETA**2 =',E10.3,' - OUT OF RANGE')
  89    10 FORMAT(10X,'T- =',F8.3,10X,'T+ =',F8.3)
  90       RETURN
  91 C
  92       END