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