MINICERN/mathlib/gen/c/ferfr64.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:02  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10 #if !defined(CERNLIB_DOUBLE)
  11       FUNCTION RFERDR(X,K)
  12 #endif
  13 #if defined(CERNLIB_DOUBLE)
  14       FUNCTION DFERDR(X,K)
  15 #include "gen/imp64.inc"
  16 #endif
  17       CHARACTER NAME*(*)
  18       CHARACTER*80 ERRTXT
  19 #if !defined(CERNLIB_DOUBLE)
  20       PARAMETER (NAME = 'RFERDR')
  21 #endif
  22 #if defined(CERNLIB_DOUBLE)
  23       PARAMETER (NAME = 'FRERDR/DFERDR')
  24 #endif
  25
  26       DIMENSION P1(5),P2(5),P3(5),P4(5),P5(5),P6(5),P7(5),P8(5),P9(5)
  27       DIMENSION Q1(5),Q2(5),Q3(5),Q4(5),Q5(5),Q6(5),Q7(5),Q8(5),Q9(5)
  28
  29       DATA C1 /1.77245 38509 05516 03D0/
  30       DATA C2 /0.88622 69254 52758 01D0/
  31       DATA C3 /1.32934 03881 79137 02D0/
  32       DATA C4 /0.66666 66666 66666 67D0/
  33       DATA C5 /0.40000 00000 00000 00D0/
  34
  35       DATA P1
  36      1/-1.25331 41288 20D+0, -1.72366 35577 01D+0, -6.55904 57292 58D-1,
  37      2 -6.34228 31976 82D-2, -1.48838 31061 16D-5/
  38       DATA Q1
  39      1/+1.00000 00000 00D+0, +2.19178 09259 80D+0, +1.60581 29554 06D+0,
  40      2 +4.44366 95274 81D-1, +3.62423 22881 12D-2/
  41       DATA P2
  42      1/-3.13328 53055 70D-1, -4.16187 38522 93D-1, -1.50220 84005 88D-1,
  43      2 -1.33957 93751 73D-2, -1.51335 07001 38D-5/
  44       DATA Q2
  45      1/+1.00000 00000 00D+0, +1.87260 86759 02D+0, +1.14520 44465 78D+0,
  46      2 +2.57022 55875 73D-1, +1.63990 25435 68D-2/
  47       DATA P3
  48      1/-2.34996 39854 06D-1, -2.92737 36375 47D-1, -9.88309 75887 38D-2,
  49      2 -8.25138 63795 51D-3, -1.87438 41532 23D-5/
  50       DATA Q3
  51      1/+1.00000 00000 00D+0, +1.60859 71091 46D+0, +8.27528 95308 80D-1,
  52      2 +1.52232 23828 50D-1, +7.69512 04750 64D-3/
  53       DATA P4
  54      1/+1.07381 27694D+0, +5.60033 03660D+0, +3.68822 11270D+0,
  55      2 +1.17433 92816D+0, +2.36419 35527D-1/
  56       DATA Q4
  57      1/+1.00000 00000D+0, +4.60318 40667D+0, +4.30759 10674D-1,
  58      2 +4.21511 32145D-1, +1.18326 01601D-2/
  59       DATA P5
  60      1/+6.78176 62666 0D-1, +6.33124 01791 0D-1, +2.94479 65177 2D-1,
  61      2 +8.01320 71141 9D-2, +1.33918 21294 0D-2/
  62       DATA Q5
  63      1/+1.00000 00000 0D+0, +1.43740 40039 7D-1, +7.08662 14845 0D-2,
  64      2 +2.34579 49473 5D-3, -1.29449 92883 5D-5/
  65       DATA P6
  66      1/+1.15302 13402D+0, +1.05915 58972D+0, +4.68988 03095D-1,
  67      2 +1.18829 08784D-1, +1.94387 55787D-2/
  68       DATA Q6
  69      1/+1.00000 00000D+0, +3.73489 53841D-2, +2.32484 58137D-2,
  70      2 -1.37667 70874D-3, +4.64663 92781D-5/
  71       DATA P7
  72      1/-8.22255 9330D-1, -3.62036 9345D+1, -3.01538 5410D+3,
  73      2 -7.04987 1579D+4, -5.69814 5924D+4/
  74       DATA Q7
  75      1/+1.00000 0000D+0, +3.93568 9841D+1, +3.56875 6266D+3,
  76      2 +4.18189 3625D+4, +3.38513 8907D+5/
  77       DATA P8
  78      1/+8.22449 97626D-1, +2.00463 03393D+1, +1.82680 93446D+3,
  79      2 +1.22265 30374D+4, +1.40407 50092D+5/
  80       DATA Q8
  81      1/+1.00000 00000D+0, +2.34862 07659D+1, +2.20134 83743D+3,
  82      1 +1.14426 73596D+4, +1.65847 15900D+5/
  83       DATA P9
  84      1/+2.46740 02368 4D+0, +2.19167 58236 8D+2, +1.23829 37907 5D+4,
  85      2 +2.20667 72496 8D+5, +8.49442 92003 4D+5/
  86       DATA Q9
  87      1/+1.00000 00000 0D+0, +8.91125 14061 9D+1, +5.04575 66966 7D+3,
  88      2 +9.09075 94630 4D+4, +3.89960 91564 1D+5/
  89
  90       IF(K .EQ. -1) THEN
  91        IF(X .LE. 1) THEN
  92         Y=EXP(X)
  93         H=Y*(C1+Y*
  94      1       (P1(1)+Y*(P1(2)+Y*(P1(3)+Y*(P1(4)+Y*P1(5)))))/
  95      2       (Q1(1)+Y*(Q1(2)+Y*(Q1(3)+Y*(Q1(4)+Y*Q1(5))))))
  96        ELSE IF(X .LE. 4) THEN
  97         H=(P4(1)+X*(P4(2)+X*(P4(3)+X*(P4(4)+X*P4(5)))))/
  98      1         (Q4(1)+X*(Q4(2)+X*(Q4(3)+X*(Q4(4)+X*Q4(5)))))
  99        ELSE
 100         Y=1/X**2
 101         H=SQRT(X)*(2+Y*
 102      1       (P7(1)+Y*(P7(2)+Y*(P7(3)+Y*(P7(4)+Y*P7(5)))))/
 103      2       (Q7(1)+Y*(Q7(2)+Y*(Q7(3)+Y*(Q7(4)+Y*Q7(5))))))
 104        END IF
 105       ELSE IF(K .EQ. 1) THEN
 106        IF(X .LE. 1) THEN
 107         Y=EXP(X)
 108         H=Y*(C2+Y*
 109      1       (P2(1)+Y*(P2(2)+Y*(P2(3)+Y*(P2(4)+Y*P2(5)))))/
 110      2       (Q2(1)+Y*(Q2(2)+Y*(Q2(3)+Y*(Q2(4)+Y*Q2(5))))))
 111        ELSE IF(X .LE. 4) THEN
 112         H=(P5(1)+X*(P5(2)+X*(P5(3)+X*(P5(4)+X*P5(5)))))/
 113      1         (Q5(1)+X*(Q5(2)+X*(Q5(3)+X*(Q5(4)+X*Q5(5)))))
 114        ELSE
 115         Y=1/X**2
 116         H=X*SQRT(X)*(C4+Y*
 117      1       (P8(1)+Y*(P8(2)+Y*(P8(3)+Y*(P8(4)+Y*P8(5)))))/
 118      2       (Q8(1)+Y*(Q8(2)+Y*(Q8(3)+Y*(Q8(4)+Y*Q8(5))))))
 119        END IF
 120       ELSE IF(K .EQ. 3) THEN
 121        IF(X .LE. 1) THEN
 122         Y=EXP(X)
 123         H=Y*(C3+Y*
 124      1       (P3(1)+Y*(P3(2)+Y*(P3(3)+Y*(P3(4)+Y*P3(5)))))/
 125      2       (Q3(1)+Y*(Q3(2)+Y*(Q3(3)+Y*(Q3(4)+Y*Q3(5))))))
 126        ELSE IF(X .LE. 4) THEN
 127         H=(P6(1)+X*(P6(2)+X*(P6(3)+X*(P6(4)+X*P6(5)))))/
 128      1         (Q6(1)+X*(Q6(2)+X*(Q6(3)+X*(Q6(4)+X*Q6(5)))))
 129        ELSE
 130         Y=1/X**2
 131         H=X**2*SQRT(X)*(C5+Y*
 132      1       (P9(1)+Y*(P9(2)+Y*(P9(3)+Y*(P9(4)+Y*P9(5)))))/
 133      2       (Q9(1)+Y*(Q9(2)+Y*(Q9(3)+Y*(Q9(4)+Y*Q9(5))))))
 134        END IF
 135       ELSE
 136        H=0
 137        WRITE(ERRTXT,101) K
 138        CALL MTLPRT(NAME,'C323.1',ERRTXT)
 139       END IF
 140 #if defined(CERNLIB_DOUBLE)
 141       DFERDR=H
 142 #endif
 143 #if !defined(CERNLIB_DOUBLE)
 144       RFERDR=H
 145 #endif
 146       RETURN
 147   101 FORMAT('INCORRECT K = ',I5)
 148       END