Mercurial > octave-nkf

annotate liboctave/cruft/quadpack/qk15i.f @ 20595:c1a6c31ac29a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
eliminate more simple uses of error_state * ov-classdef.cc: Eliminate simple uses of error_state.
author John W. Eaton <jwe@octave.org>
date Tue, 06 Oct 2015 00:20:02 -0400
parents 648dabbb4c6b
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
7793
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
1 subroutine qk15i(f,boun,inf,a,b,result,abserr,resabs,resasc,ierr)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
2 c***begin prologue qk15i
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
3 c***date written 800101 (yymmdd)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
4 c***revision date 830518 (yymmdd)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
5 c***category no. h2a3a2,h2a4a2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
6 c***keywords 15-point transformed gauss-kronrod rules
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
7 c***author piessens,robert,appl. math. & progr. div. - k.u.leuven
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
8 c de doncker,elise,appl. math. & progr. div. - k.u.leuven
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
9 c***purpose the original (infinite integration range is mapped
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
10 c onto the interval (0,1) and (a,b) is a part of (0,1).
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
11 c it is the purpose to compute
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
12 c i = integral of transformed integrand over (a,b),
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
13 c j = integral of abs(transformed integrand) over (a,b).
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
14 c***description
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
15 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
16 c integration rule
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
17 c standard fortran subroutine
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
18 c real version
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
19 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
20 c parameters
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
21 c on entry
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
22 c f - subroutine f(x,ierr,result) defining the integrand
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
23 c function f(x). the actual name for f needs to be
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
24 c declared e x t e r n a l in the calling program.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
25 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
26 c boun - real
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
27 c finite bound of original integration
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
28 c range (set to zero if inf = +2)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
29 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
30 c inf - integer
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
31 c if inf = -1, the original interval is
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
32 c (-infinity,bound),
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
33 c if inf = +1, the original interval is
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
34 c (bound,+infinity),
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
35 c if inf = +2, the original interval is
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
36 c (-infinity,+infinity) and
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
37 c the integral is computed as the sum of two
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
38 c integrals, one over (-infinity,0) and one over
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
39 c (0,+infinity).
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
40 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
41 c a - real
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
42 c lower limit for integration over subrange
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
43 c of (0,1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
44 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
45 c b - real
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
46 c upper limit for integration over subrange
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
47 c of (0,1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
48 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
49 c on return
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
50 c result - real
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
51 c approximation to the integral i
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
52 c result is computed by applying the 15-point
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
53 c kronrod rule(resk) obtained by optimal addition
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
54 c of abscissae to the 7-point gauss rule(resg).
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
55 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
56 c abserr - real
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
57 c estimate of the modulus of the absolute error,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
58 c which should equal or exceed abs(i-result)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
59 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
60 c resabs - real
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
61 c approximation to the integral j
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
62 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
63 c resasc - real
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
64 c approximation to the integral of
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
65 c abs((transformed integrand)-i/(b-a)) over (a,b)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
66 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
67 c***references (none)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
68 c***routines called r1mach
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
69 c***end prologue qk15i
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
70 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
71 real a,absc,absc1,absc2,abserr,b,boun,centr,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
72 * dinf,r1mach,epmach,fc,fsum,fval1,fval2,fvalt,fv1,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
73 * fv2,hlgth,resabs,resasc,resg,resk,reskh,result,tabsc1,tabsc2,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
74 * uflow,wg,wgk,xgk
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
75 integer inf,j,min0
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
76 external f
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
77 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
78 dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
79 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
80 c the abscissae and weights are supplied for the interval
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
81 c (-1,1). because of symmetry only the positive abscissae and
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
82 c their corresponding weights are given.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
83 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
84 c xgk - abscissae of the 15-point kronrod rule
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
85 c xgk(2), xgk(4), ... abscissae of the 7-point
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
86 c gauss rule
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
87 c xgk(1), xgk(3), ... abscissae which are optimally
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
88 c added to the 7-point gauss rule
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
89 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
90 c wgk - weights of the 15-point kronrod rule
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
91 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
92 c wg - weights of the 7-point gauss rule, corresponding
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
93 c to the abscissae xgk(2), xgk(4), ...
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
94 c wg(1), wg(3), ... are set to zero.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
95 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
96 data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7),
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
97 * xgk(8)/
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
98 * 0.9914553711208126e+00, 0.9491079123427585e+00,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
99 * 0.8648644233597691e+00, 0.7415311855993944e+00,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
100 * 0.5860872354676911e+00, 0.4058451513773972e+00,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
101 * 0.2077849550078985e+00, 0.0000000000000000e+00/
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
102 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
103 data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7),
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
104 * wgk(8)/
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
105 * 0.2293532201052922e-01, 0.6309209262997855e-01,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
106 * 0.1047900103222502e+00, 0.1406532597155259e+00,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
107 * 0.1690047266392679e+00, 0.1903505780647854e+00,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
108 * 0.2044329400752989e+00, 0.2094821410847278e+00/
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
109 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
110 data wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
111 * 0.0000000000000000e+00, 0.1294849661688697e+00,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
112 * 0.0000000000000000e+00, 0.2797053914892767e+00,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
113 * 0.0000000000000000e+00, 0.3818300505051189e+00,
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
114 * 0.0000000000000000e+00, 0.4179591836734694e+00/
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
115 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
116 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
117 c list of major variables
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
118 c -----------------------
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
119 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
120 c centr - mid point of the interval
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
121 c hlgth - half-length of the interval
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
122 c absc* - abscissa
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
123 c tabsc* - transformed abscissa
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
124 c fval* - function value
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
125 c resg - result of the 7-point gauss formula
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
126 c resk - result of the 15-point kronrod formula
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
127 c reskh - approximation to the mean value of the transformed
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
128 c integrand over (a,b), i.e. to i/(b-a)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
129 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
130 c machine dependent constants
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
131 c ---------------------------
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
132 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
133 c epmach is the largest relative spacing.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
134 c uflow is the smallest positive magnitude.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
135 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
136 c***first executable statement qk15i
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
137 epmach = r1mach(4)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
138 uflow = r1mach(1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
139 dinf = min0(1,inf)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
140 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
141 centr = 0.5e+00*(a+b)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
142 hlgth = 0.5e+00*(b-a)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
143 tabsc1 = boun+dinf*(0.1e+01-centr)/centr
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
144 call f(tabsc1, ierr, fval1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
145 if (ierr.lt.0) return
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
146 if(inf.eq.2) then
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
147 call f(-tabsc1, ierr, fval1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
148 if (ierr.lt.0) return
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
149 fval1 = fval1 + fvalt
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
150 endif
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
151 fc = (fval1/centr)/centr
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
152 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
153 c compute the 15-point kronrod approximation to
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
154 c the integral, and estimate the error.
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
155 c
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
156 resg = wg(8)*fc
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
157 resk = wgk(8)*fc
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
158 resabs = abs(resk)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
159 do 10 j=1,7
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
160 absc = hlgth*xgk(j)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
161 absc1 = centr-absc
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
162 absc2 = centr+absc
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
163 tabsc1 = boun+dinf*(0.1e+01-absc1)/absc1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
164 tabsc2 = boun+dinf*(0.1e+01-absc2)/absc2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
165 call f(tabsc1, ierr, fval1)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
166 if (ierr.lt.0) return
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
167 call f(tabsc2, ierr, fval2)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
168 if (ierr.lt.0) return
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
169 if(inf.eq.2) then
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
170 call f(-tabsc1,ierr,fvalt)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
171 if (ierr.lt.0) return
7807
d4565e812948 Removed semicolons at end of lines 172 and 177
Thomas Treichl <Thomas.Treichl@gmx.net>
parents: 7793
diff changeset
172 fval1 = fval1 + fvalt
7793
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
173 endif
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
174 if(inf.eq.2) then
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
175 call f(-tabsc2,ierr,fvalt)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
176 if (ierr.lt.0) return
7807
d4565e812948 Removed semicolons at end of lines 172 and 177
Thomas Treichl <Thomas.Treichl@gmx.net>
parents: 7793
diff changeset
177 fval2 = fval2 + fvalt
7793
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
178 endif
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
179 fval1 = (fval1/absc1)/absc1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
180 fval2 = (fval2/absc2)/absc2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
181 fv1(j) = fval1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
182 fv2(j) = fval2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
183 fsum = fval1+fval2
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
184 resg = resg+wg(j)*fsum
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
185 resk = resk+wgk(j)*fsum
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
186 resabs = resabs+wgk(j)*(abs(fval1)+abs(fval2))
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
187 10 continue
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
188 reskh = resk*0.5e+00
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
189 resasc = wgk(8)*abs(fc-reskh)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
190 do 20 j=1,7
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
191 resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh))
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
192 20 continue
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
193 result = resk*hlgth
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
194 resasc = resasc*hlgth
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
195 resabs = resabs*hlgth
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
196 abserr = abs((resk-resg)*hlgth)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
197 if(resasc.ne.0.0e+00.and.abserr.ne.0.e0) abserr = resasc*
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
198 * amin1(0.1e+01,(0.2e+03*abserr/resasc)**1.5e+00)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
199 if(resabs.gt.uflow/(0.5e+02*epmach)) abserr = amax1
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
200 * ((epmach*0.5e+02)*resabs,abserr)
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
201 return
96ba591be50f Add some more support for single precision to libcruft functions
David Bateman <dbateman@free.fr>
parents:
diff changeset
202 end