MINICERN/mathlib/gen/d/gauss128.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.1  1996/04/01 15:02:13  mclareni
   6 * Mathlib gen
   7 *
   8 *
   9 #include "gen/pilot.h"
  10 #if defined(CERNLIB_QUAD)
  11 #if defined(CERNLIB_DOUBLE)
  12       FUNCTION QGAUSS(F,A,B,EPS)
  13
  14 C     QGAUSS FOR IBM AND ALIKE
  15 #endif
  16 #if !defined(CERNLIB_DOUBLE)
  17       FUNCTION DGAUSS(F,A,B,EPS)
  18
  19 C     DGAUSS FOR CRAY AND ALIKE
  20 #endif
  21 #include "gen/imp128.inc"
  22       CHARACTER NAME*(*)
  23 #if defined(CERNLIB_DOUBLE)
  24       PARAMETER (NAME = 'QGAUSS')
  25 #endif
  26 #if !defined(CERNLIB_DOUBLE)
  27       PARAMETER (NAME = 'DGAUSS')
  28 #endif
  29       DIMENSION W(12),X(12)
  30
  31       PARAMETER (Z1 = 1, HF = Z1/2, CST = 5*Z1/1000)
  32
  33       DATA X
  34 #if defined(CERNLIB_DOUBLE)
  35      1        /0.96028 98564 97536 23168 35608 68569 47Q0,
  36      2         0.79666 64774 13626 73959 15539 36475 83Q0,
  37      3         0.52553 24099 16328 98581 77390 49189 25Q0,
  38      4         0.18343 46424 95649 80493 94761 42360 18Q0,
  39      5         0.98940 09349 91649 93259 61541 73450 33Q0,
  40      6         0.94457 50230 73232 57607 79884 15534 61Q0,
  41      7         0.86563 12023 87831 74388 04678 97712 39Q0,
  42      8         0.75540 44083 55003 03389 51011 94847 44Q0,
  43      9         0.61787 62444 02643 74844 66717 64048 79Q0,
  44      A         0.45801 67776 57227 38634 24194 42983 58Q0,
  45      B         0.28160 35507 79258 91323 04605 01460 50Q0,
  46      C         0.95012 50983 76374 40185 31933 54249 58Q-1/
  47
  48       DATA W
  49      1        /0.10122 85362 90376 25915 25313 54309 96Q0,
  50      2         0.22238 10344 53374 47054 43559 94426 24Q0,
  51      3         0.31370 66458 77887 28733 79622 01986 60Q0,
  52      4         0.36268 37833 78361 98296 51504 49277 20Q0,
  53      5         0.27152 45941 17540 94851 78057 24560 18Q-1,
  54      6         0.62253 52393 86478 92862 84383 69943 78Q-1,
  55      7         0.95158 51168 24927 84809 92510 76022 46Q-1,
  56      8         0.12462 89712 55533 87205 24762 82192 02Q0,
  57      9         0.14959 59888 16576 73208 15017 30547 48Q0,
  58      A         0.16915 65193 95002 53818 93120 79030 36Q0,
  59      B         0.18260 34150 44923 58886 67636 67969 22Q0,
  60      C         0.18945 06104 55068 49628 53967 23208 28Q0/
  61 #endif
  62 #if !defined(CERNLIB_DOUBLE)
  63      1        /0.96028 98564 97536 23168 35608 68569 47D0,
  64      2         0.79666 64774 13626 73959 15539 36475 83D0,
  65      3         0.52553 24099 16328 98581 77390 49189 25D0,
  66      4         0.18343 46424 95649 80493 94761 42360 18D0,
  67      5         0.98940 09349 91649 93259 61541 73450 33D0,
  68      6         0.94457 50230 73232 57607 79884 15534 61D0,
  69      7         0.86563 12023 87831 74388 04678 97712 39D0,
  70      8         0.75540 44083 55003 03389 51011 94847 44D0,
  71      9         0.61787 62444 02643 74844 66717 64048 79D0,
  72      A         0.45801 67776 57227 38634 24194 42983 58D0,
  73      B         0.28160 35507 79258 91323 04605 01460 50D0,
  74      C         0.95012 50983 76374 40185 31933 54249 58D-1/
  75
  76       DATA W
  77      1        /0.10122 85362 90376 25915 25313 54309 96D0,
  78      2         0.22238 10344 53374 47054 43559 94426 24D0,
  79      3         0.31370 66458 77887 28733 79622 01986 60D0,
  80      4         0.36268 37833 78361 98296 51504 49277 20D0,
  81      5         0.27152 45941 17540 94851 78057 24560 18D-1,
  82      6         0.62253 52393 86478 92862 84383 69943 78D-1,
  83      7         0.95158 51168 24927 84809 92510 76022 46D-1,
  84      8         0.12462 89712 55533 87205 24762 82192 02D0,
  85      9         0.14959 59888 16576 73208 15017 30547 48D0,
  86      A         0.16915 65193 95002 53818 93120 79030 36D0,
  87      B         0.18260 34150 44923 58886 67636 67969 22D0,
  88      C         0.18945 06104 55068 49628 53967 23208 28D0/
  89 #endif
  90
  91       H=0
  92       IF(B .EQ. A) GO TO 99
  93       CONST=CST/ABS(B-A)
  94       BB=A
  95     1 AA=BB
  96       BB=B
  97     2 C1=HF*(BB+AA)
  98       C2=HF*(BB-AA)
  99       S8=0
 100       DO 3 I = 1,4
 101       U=C2*X(I)
 102     3 S8=S8+W(I)*(F(C1+U)+F(C1-U))
 103       S16=0
 104       DO 4 I = 5,12
 105       U=C2*X(I)
 106     4 S16=S16+W(I)*(F(C1+U)+F(C1-U))
 107       S16=C2*S16
 108       IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN
 109        H=H+S16
 110        IF(BB .NE. B) GO TO 1
 111       ELSE
 112        BB=C1
 113        IF(1+CONST*ABS(C2) .NE. 1) GO TO 2
 114        H=0
 115        CALL MTLPRT(NAME,'D103.1','TOO HIGH ACCURACY REQUIRED')
 116        GO TO 99
 117       END IF
 118 #if !defined(CERNLIB_DOUBLE)
 119    99 DGAUSS=H
 120 #endif
 121 #if defined(CERNLIB_DOUBLE)
 122    99 QGAUSS=H
 123 #endif
 124       RETURN
 125       END
 126 #endif