MINICERN/mathlib/gen/c/trdz.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:01:59  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10       SUBROUTINE TRDZ
  11 #include "legbl.inc"
  12      1,EP
  13      2,       RGAM,CDIGAM
  14      3,EP2,PIE,ZZS2,AA,BB,CC,FAC,SUM,ADD
  15 C*NS 2,CLOGOK,RGAM,CDIGAM
  16 C   TRDZ  EXPECTS GR SET=CLOGOK(2.0*ZZ,NFRIG,2)
  17       K=REAL(VV+1.0)
  18       EK=K
  19       EP=VV+0.5-EK
  20       ZZS2=Z2/4.0
  21       KK=K-1
  22       SUM=0.0
  23       IF(K)9,9,10
  24    10 B=0.5
  25       C=1.0
  26       FAC=RGAM(VV,B,C)*EXP(VV*GR)
  27       SUM=FAC
  28       IF(KK)9,11,12
  29    12 AA=-VV-2.0
  30       BB=-VV-0.5
  31       DO 2 I=1,KK
  32       BB=BB+1.0
  33       AA=AA+2.0
  34       FAC=FAC*(1.0+AA)*AA*ZZS2/(BB*I)
  35       SUM=SUM+FAC
  36       IF(CRIT(SUM,FAC,ACC))51,2,2
  37     2 CONTINUE
  38       GOTO 11
  39     9 SUM=0.0
  40    51 CONTINUE
  41    11 PIE=PI*EP
  42       EP2=EP/2.0
  43       A=EK
  44       B=0.5-EP
  45       C=1.0
  46       BB=0.0
  47       FAC=-(1.0-PIE**2/3.0)*RGAM(A,B,C)*RGAM(C,BB,-EP)
  48      1                 / (PI*EXP((2.0*EK-VV)*GR))
  49       A=EK+0.5
  50       B=1.0-EP2
  51       C=EK+1.0+EP2
  52       ADD=2.*CDIGAM(A)-CDIGAM(B)-CDIGAM(C)-2.0*GR
  53       GR=FAC*ADD*(1.0+EP2*ADD)
  54       SUM=SUM+GR
  55       AA=EK-1.5-EP
  56       BB=-EP
  57       CC=EK
  58       DO 22 I=1,50
  59       AA=AA+2.0
  60       BB=BB+1.0
  61       CC=CC+1.0
  62       FAC=FAC*(1.0+AA)*AA*ZZS2/(BB*CC)
  63       ADD=ADD+2.0/(A+1.0)+2.0/A-1.0/B-1.0/C
  64       A=A+2.0
  65       B=B+1.0
  66       C=C+1.0
  67       GR=FAC*ADD*(1.0+EP2*ADD)
  68       SUM=SUM+GR
  69       IF(CRIT(SUM,GR,ACC))52,22,22
  70    22 CONTINUE
  71       NCVG=NCVG+4
  72    52 PP=SUM/PISR
  73       RETURN
  74       END