[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / d / gauss128.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1996/04/01 15:02:13  mclareni
* Mathlib gen
*
*
#include "gen/pilot.h"
#if defined(CERNLIB_QUAD)
#if defined(CERNLIB_DOUBLE)
      FUNCTION QGAUSS(F,A,B,EPS)

C     QGAUSS FOR IBM AND ALIKE
#endif
#if !defined(CERNLIB_DOUBLE)
      FUNCTION DGAUSS(F,A,B,EPS)

C     DGAUSS FOR CRAY AND ALIKE
#endif
#include "gen/imp128.inc"
      CHARACTER NAME*(*)
#if defined(CERNLIB_DOUBLE)
      PARAMETER (NAME = 'QGAUSS')
#endif
#if !defined(CERNLIB_DOUBLE)
      PARAMETER (NAME = 'DGAUSS')
#endif
      DIMENSION W(12),X(12)

      PARAMETER (Z1 = 1, HF = Z1/2, CST = 5*Z1/1000)

      DATA X
#if defined(CERNLIB_DOUBLE)
     1        /0.96028 98564 97536 23168 35608 68569 47Q0,
     2         0.79666 64774 13626 73959 15539 36475 83Q0,
     3         0.52553 24099 16328 98581 77390 49189 25Q0,
     4         0.18343 46424 95649 80493 94761 42360 18Q0,
     5         0.98940 09349 91649 93259 61541 73450 33Q0,
     6         0.94457 50230 73232 57607 79884 15534 61Q0,
     7         0.86563 12023 87831 74388 04678 97712 39Q0,
     8         0.75540 44083 55003 03389 51011 94847 44Q0,
     9         0.61787 62444 02643 74844 66717 64048 79Q0,
     A         0.45801 67776 57227 38634 24194 42983 58Q0,
     B         0.28160 35507 79258 91323 04605 01460 50Q0,
     C         0.95012 50983 76374 40185 31933 54249 58Q-1/

      DATA W
     1        /0.10122 85362 90376 25915 25313 54309 96Q0,
     2         0.22238 10344 53374 47054 43559 94426 24Q0,
     3         0.31370 66458 77887 28733 79622 01986 60Q0,
     4         0.36268 37833 78361 98296 51504 49277 20Q0,
     5         0.27152 45941 17540 94851 78057 24560 18Q-1,
     6         0.62253 52393 86478 92862 84383 69943 78Q-1,
     7         0.95158 51168 24927 84809 92510 76022 46Q-1,
     8         0.12462 89712 55533 87205 24762 82192 02Q0,
     9         0.14959 59888 16576 73208 15017 30547 48Q0,
     A         0.16915 65193 95002 53818 93120 79030 36Q0,
     B         0.18260 34150 44923 58886 67636 67969 22Q0,
     C         0.18945 06104 55068 49628 53967 23208 28Q0/
#endif
#if !defined(CERNLIB_DOUBLE)
     1        /0.96028 98564 97536 23168 35608 68569 47D0,
     2         0.79666 64774 13626 73959 15539 36475 83D0,
     3         0.52553 24099 16328 98581 77390 49189 25D0,
     4         0.18343 46424 95649 80493 94761 42360 18D0,
     5         0.98940 09349 91649 93259 61541 73450 33D0,
     6         0.94457 50230 73232 57607 79884 15534 61D0,
     7         0.86563 12023 87831 74388 04678 97712 39D0,
     8         0.75540 44083 55003 03389 51011 94847 44D0,
     9         0.61787 62444 02643 74844 66717 64048 79D0,
     A         0.45801 67776 57227 38634 24194 42983 58D0,
     B         0.28160 35507 79258 91323 04605 01460 50D0,
     C         0.95012 50983 76374 40185 31933 54249 58D-1/

      DATA W
     1        /0.10122 85362 90376 25915 25313 54309 96D0,
     2         0.22238 10344 53374 47054 43559 94426 24D0,
     3         0.31370 66458 77887 28733 79622 01986 60D0,
     4         0.36268 37833 78361 98296 51504 49277 20D0,
     5         0.27152 45941 17540 94851 78057 24560 18D-1,
     6         0.62253 52393 86478 92862 84383 69943 78D-1,
     7         0.95158 51168 24927 84809 92510 76022 46D-1,
     8         0.12462 89712 55533 87205 24762 82192 02D0,
     9         0.14959 59888 16576 73208 15017 30547 48D0,
     A         0.16915 65193 95002 53818 93120 79030 36D0,
     B         0.18260 34150 44923 58886 67636 67969 22D0,
     C         0.18945 06104 55068 49628 53967 23208 28D0/
#endif

      H=0
      IF(B .EQ. A) GO TO 99
      CONST=CST/ABS(B-A)
      BB=A
    1 AA=BB
      BB=B
    2 C1=HF*(BB+AA)
      C2=HF*(BB-AA)
      S8=0
      DO 3 I = 1,4
      U=C2*X(I)
    3 S8=S8+W(I)*(F(C1+U)+F(C1-U))
      S16=0
      DO 4 I = 5,12
      U=C2*X(I)
    4 S16=S16+W(I)*(F(C1+U)+F(C1-U))
      S16=C2*S16
      IF(ABS(S16-C2*S8) .LE. EPS*(1+ABS(S16))) THEN
       H=H+S16
       IF(BB .NE. B) GO TO 1
      ELSE
       BB=C1
       IF(1+CONST*ABS(C2) .NE. 1) GO TO 2
       H=0
       CALL MTLPRT(NAME,'D103.1','TOO HIGH ACCURACY REQUIRED')
       GO TO 99
      END IF
#if !defined(CERNLIB_DOUBLE)
   99 DGAUSS=H
#endif
#if defined(CERNLIB_DOUBLE)
   99 QGAUSS=H
#endif
      RETURN
      END
#endif
Commit	Line	Data
fe4da5cc	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-C2S8) .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