F 15.12 Adaptive Quadrature Methods
SUBROUTINE GAX (INTVAL,EPS,N,FCT,NMAX,LQM,XNODES,
+ QVAL,EXE,TPOINT,STATUS,IERR,AK,IDGR)
C
C*****************************************************************
C *
C Adaptive quadrature in one dimension. *
C *
C INPUT PARAMETERS: *
C ================= *
C INTVAL: 2-dimensional array INTVAL(1:100,1:2); user supplied *
C sub-intervals of integration: *
C INTVAL(1,1) = A1, INTVAL(1,2) = B1 *
C ... ... *
C INTVAL(N,1) = AN, INTVAL(N,2) = BN. *
C Here AI must be less than BI for each I. *
C *
C EPS : relative accuracy required for the solution *
C *
C N : number of initially supplied sub-intervals *
C *
C FCT : name of the function FCT(X) that is to be integrated, *
C provided by the user in the form *
C DOUBLE PRECISION FUNCTION FCT (X). *
C In the calling program it must be defined as EXTERNAL.*
C *
C NMAX : maximal number of sub-intervals allowed to be produced*
C during the calculations *
C *
C LQM : parameter that determines which quadrature formula *
C to use on the sub-intervals *
C LQM = 1: trapezoidal rule *
C = 2: GAUSS quadrature formula *
C = 3: CLENSHAW-CURTIS formula *
C = 4: ROMBERG method *
C = 5: summed NEWTON-COTES formulas *
C *
C IDGR : this label determines the degree of the quadrature *
C formula used *
C LQM =1:IDGR not used *
C LQM =2:IDGR = 2: GAUSS quadrature formula of degree 2 *
C IDGR = 3: GAUSS quadrature formula of degree 3 *
C ... *
C IDGR =20: GAUSS quadrature formula of degree 20*
C ( 2 <= IDGR <= 20 ) *
C LQM =3:IDGR = 2: CLENSHAW-CURTIS formula with *
C 2 + 1 weights *
C IDGR = 4: CLENSHAW-CURTIS formula with *
C 4 + 1 weights *
C ... *
C IDGR must be greater than 1 and even. *
C LQM =4:IDGR not used *
C LQM =5:IDGR = 2: summed NEWTON-COTES formula for 2 *
C nodes, i.e., SIMPSON's rule *
C IDGR = 3: summed NEWTON-COTES formula for 3 *
C nodes, i.e., the 3/8 formula *
C ... *
C IDGR = 7: summed NEWTON-COTES formula for 7 *
C nodes, i.e., the 7/17280 formula *
C (We must have 2 <= IDGR <= 7 here) *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C *
C XNODES: vector XNODES(1:NMAX * 4) containing the sub-intervals*
C produced during the calculations in the following *
C form: *
C XNODES(1) : error estimate for the quadrature from A *
C to B *
C XNODES(2) : computed value of the integral from A to B*
C XNODES(3) : left hand endpoint A of the interval *
C XNODES(4) : right hand endpoint B of the interval *
C *
C QVAL : approximate value for the integral when the procedure *
C is stopped. *
C *
C EXE : accuracy of QVAL achieved when stopping *
C (absolute error) *
C *
C NMAX : actual number of sub-intervals used *
C *
C IERR : error parameter: *
C = 0: everything is o.k., EXE < EPS *
C = 1: exceeding MAXLEV = 100 while *
C the required accuracy could not be achieved *
C => choose a larger value for IDGR or a smaller *
C accuracy bound EPS *
C = 2: N > NMAX, the required accuracy was not achieved *
C = 3: left endpoint A > right endpoint B: *
C endpoints entered incorrectly have been exchanged*
C = 4: conditions IERR = 3 and = 1 both hold *
C = 5: conditions IERR = 3 and = 2 both hold *
C = 6: degree IDGR of the GAUSS quadrature formula *
C satisfies 2 > IDGR > 20 *
C = 7: weights of the CLENSHAW-CURTIS formula *
C IDGR are odd or less than 2 *
C = 8: number of nodes IDGR in the NEWTON-COTES formula *
C 2 > IDGR > 7 *
C = 9: N < 0 or EPS < 1.D-12 or NMAX < 1 *
C =10: 1 > LQM > 5 *
C .... *
C *
C >=100: error when determining an integral value *
C *
C AUXILIARY VECTORS: *
C ================== *
C ITNODE: vector ITNODE(1:2); contains information on the *
C current sub-interval: *
C ITNODE(1) indicates the state of the sub-interval: *
C = 1: state = small *
C = 0: state = big *
C ITNODE(2) contains the current level of the sub- *
C interval *
C EL : vector EL(1:102); contains the current row of the *
C ROMBERG scheme for RICHARDSON extrapolation *
C ELEPS : vector ELEPS(1:102); contains the current row of the *
C EPSILON-algorithm *
C TNODE : vector TNODE(1:4); contains the sub-interval currently*
C in use *
C XZERO : vector XZERO(1:21); contains the zeros of the LEGENDRE*
C polynomials in ascending order *
C ZWGH : vector ZWGH(1:21); contains the weights corresponding *
C to the zeros of the GAUSS-quadrature formulas *
C *
C AK : 2-dimensional array AK(0:IDGR, 2); contains the *
C weights and nodes of the CLENSHAW-CURTIS quadrature *
C formula for the reference interval [-1,1] that were *
C produced during the calculations *
C TPOINT: vector TPOINT(1:NMAX); used as a marker: *
C this vector contains XNODES in quasi order; TPOINT(1) *
C points to the sub-interval with the largest quadrature*
C error, etc. *
C STATUS: vector STATUS(1:NMAX * 2); contains the state of each *
C sub-interval (see vector ITNODE(1:4) ) *
C *
C----------------------------------------------------------------*
C *
C subroutines required : *
C GXENT : tests the input parameters *
C GXDIV : splits the intervals *
C GXQUAD : determines the integral approximately: *
C GXGAUS : integration using GAUSS quadrature *
C CLENSH : integration using CLENSHAW-CURTIS formulas *
C QUAROM : integration using ROMBERG method *
C QUANEC : integration using NEWTON-COTES formulas *
C FCT : function to be integrated *
C GXINS : inserts new sub-intervals *
C GXDEL : erases a sub-interval *
C GXACC : accesses a sub-interval *
C GXRIEP : RICHARDSON-extrapolation, EPSILON-algorithm *
C GALE0 : nodes and weights for GAUSS-quadrature *
C GXPOLY : HORNER scheme *
C GXPEGA : PEGASUS method *
C WGKNOT : weights, nodes for CLENSHAW-CURTIS formulas *
C *
C----------------------------------------------------------------*
C *
C sources : 1. Eul, T. and Rheinbach, H.J.: *
C Lecture: The combination of adaptive and extra- *
C polation methods for numerical integration, *
C RWTH Aachen, October 1984. *
C 2. D. Kahaner and J. Stoer, see [KAHA83]. *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 04.10.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
EXTERNAL FCT
INTEGER IDGR, GRDFLG, IERR2
DOUBLE PRECISION TNODE(4), N1(4), N2(4), XNODES(1:NMAX, 1:4)
DOUBLE PRECISION EL(0:102), ELEPS(0:102), INTVAL(1:100,1:2)
DOUBLE PRECISION XZERO(21), ZWGH(21),AK(0:IDGR, 2), HELP, EPS
INTEGER TPOINT(NMAX), STATUS(1:NMAX, 1:2), ITNODE(2)
DOUBLE PRECISION QVAL, EXE, QEXE, EPSL, EPSEXE, BEE, TEE
C
C testing the input parameters,
C if necessary return
C
IERR = 0
CALL GXENT (LQM, N, NMAX, EPS, AK, IDGR, ZWGH, XZERO,
+ GRDFLG, IERR)
IF (IERR .GT. 0) RETURN
C
C initialize the pointer vector TPOINT
C
DO 10 I = 1, NMAX
TPOINT(I) = I
10 CONTINUE
C
C initialize the vector XNODES for future calculations
C
QVAL = 0.0D0
TEE = 0.0D0
TNODE(1) = 1000.0D0
DO 30 I = 1, N
C
C the integral is computed for the I-th
C starting interval
C
TNODE(3) = INTVAL(I,1)
TNODE(4) = INTVAL(I,2)
C
C check that left endpoint < right endpoint
C
IF (DABS(TNODE(3)) .GT. DABS(TNODE(4))) THEN
C
C if right endpoint < left endpoint:
C ==> exchange the two
C
IERR = 3
HELP = TNODE(3)
TNODE(3) = TNODE(4)
TNODE(4) = HELP
ENDIF
C
CALL GXQUAD (TNODE, FCT, XZERO, ZWGH, LQM, GRDFLG, AK, IDGR,
+ IERR2)
C
C store the I-th sub-interval in the vector XNODES
C
DO 40 J = 1, 4
XNODES (I,J) = TNODE(J)
40 CONTINUE
C
STATUS(I,1) = 1
STATUS(I,2) = 0
QVAL = QVAL + TNODE(2)
TEE = TEE + 1000.0D0
30 CONTINUE
C
C initialize remaining variables
C
LEVEL = 0
MAXLEV = 100
BEE = 0.0D0
EXE = TEE
EPSEXE = TEE
EL(1) = QVAL
ELEPS(1) = QVAL
EPSL = 0.0D0
QEXE = 1000.0D0
M = 1
C
C integrate
C
DO 111 ITER = 1, NMAX
C
C test break-off criterion of the method used
C
IF ( TEE .LE. EPSL .OR. EXE .LE. EPSL .OR.
+ LEVEL .GT. MAXLEV ) THEN
C
C If TEE <= EPSL or EXE <= EPSL or LEVEL > MAXLEV
C ==> correct computation
C
IF (IERR2 .GT. 0) IERR = IERR + IERR2
IF (LEVEL .GT. MAXLEV) IERR = IERR + 1
IF (EXE .LT. TEE) THEN
QVAL = QEXE
ELSEIF (TEE .LT. EXE) THEN
EXE = TEE
ENDIF
NMAX = N
R E T U R N
ENDIF
C
C retrieve the interval with the largest error and transfer
C it to the vector TNODE
C
CALL GXACC (NMAX, XNODES, STATUS, N, TPOINT, TNODE, ITNODE, 1)
CALL GXDEL (NMAX, N, TPOINT, 1)
CALL GXDIV (TNODE, N1, N2, FCT, XZERO, ZWGH, LQM, GRDFLG,
+ AK, IDGR, IERR2)
C
C
IF (ITNODE(2) .EQ. LEVEL) THEN
LEVEL = LEVEL + 1
C
C all used sub-intervals are assigned the state 'BIG'.
C This requires to recalculate the value for BEE
C
BEE = 0.0D0
DO 100 I = 1, N
STATUS (TPOINT(I), 1) = 0
BEE = BEE + XNODES (TPOINT(I), 1)
100 CONTINUE
ITNODE(1) = 1
ITNODE(2) = LEVEL
ELSE
IF (ITNODE(2) .EQ. (LEVEL-1)) THEN
ITNODE(1) = 1
BEE = DABS(BEE - TNODE(1))
ELSE
ITNODE(1) = 0
BEE = DABS(BEE + (N1(1) + N2(1) - TNODE(1)) )
ENDIF
ITNODE(2) = ITNODE(2) + 1
ENDIF
IPOS = 1
C
C check whether two additional sub-intervals can be inserted
C
2 IF ((N+2) .GT. NMAX) THEN
C
C If N+2 > NMAX
C ==> correct computations
C
IERR = IERR + 2
IF (IERR2 .GT. 0) IERR = IERR + IERR2
IF (EXE .LT. TEE) THEN
QVAL = QEXE
ELSEIF (TEE .LT. EXE) THEN
EXE = TEE
ENDIF
NMAX = N
R E T U R N
ENDIF
CALL GXINS (NMAX, XNODES, STATUS, N, TPOINT, N1, N2, ITNODE,
+ IPOS)
C
C updating of values for TEE and QVAL
C
TEE = DABS(TEE + (N1(1)+N2(1)-TNODE(1)) )
QVAL = QVAL + (N1(2)+N2(2)-TNODE(2))
C
IF (BEE .GT. EPSL .AND. TEE .GT. EPSL) THEN
C
C find the sub-interval with state 'BIG'
C that has the largest quadrature error
C
DO 110 I = IPOS, N
IF (STATUS (TPOINT(I), 1) .NE. 1) THEN
IPOS = I
CALL GXACC (NMAX, XNODES, STATUS, N, TPOINT,
+ TNODE, ITNODE, IPOS)
CALL GXDEL (NMAX, N, TPOINT, IPOS)
CALL GXDIV (TNODE, N1, N2, FCT, XZERO, ZWGH,
+ LQM, GRDFLG, AK, IDGR, IERR2)
C
C are the new rows of the state 'BIG' or 'SMALL' ?
C
IF (ITNODE(2) .EQ. (LEVEL-1)) THEN
ITNODE(1) = 1
BEE = DABS(BEE - TNODE(1))
ELSE
ITNODE(1) = 0
BEE = DABS(BEE + (N1(1)+N2(1)-TNODE(1)))
ENDIF
ITNODE(2) = ITNODE(2) + 1
C
GOTO 2
C
ENDIF
110 CONTINUE
ENDIF
CALL GXRIEP (QVAL, EL ,ELEPS, EPSEXE, EPSL, M, EPS, EXE, QEXE)
111 CONTINUE
IF (IERR2 .GT. 0) IERR = IERR + IERR2
IF (EXE .LT. TEE) THEN
QVAL = QEXE
ELSEIF (TEE .LT. EXE) THEN
EXE = TEE
ENDIF
NMAX = ITER
R E T U R N
END
C
C
SUBROUTINE GXENT (LQM, N, NMAX, EPS, AK, IDGR, ZWGH,
+ XZERO, GRDFLG, IERR)
C
C*****************************************************************
C *
C This SUBROUTINE tests the validity of the input parameters,*
C and, if necessary, determines the weights for a CLENSHAW- *
C CURTIS or GAUSS quadrature formula of degree IDGR. *
C *
C *
C INPUT PARAMERTERS: *
C ================== *
C LQM : quadrature formula to be used *
C N : number of starting sub-intervals *
C NMAX : maximum number of sub-intervals that can be *
C produced *
C EPS : relative accuracy bound *
C IDGR : degree of the quadrature formula *
C *
C OUTPUT PARAMETERS: *
C ================== *
C AK : 2-dimensional array AK(0:IDGR, 2), the weights *
C and nodes for CLENSHAW-CURTIS *
C ALPHA : vector ALPHA(1:21), the nodes for GAUSS *
C ZWGH : vector ZWGH(1:21), the weights for GAUSS *
C XZERO : vector XZERO(1:21), the zeros for GAUSS *
C GRDFLG : =1, if 0 is a node; =0, if zero is not a node *
C IERR : error parameter *
C *
C----------------------------------------------------------------*
C *
C subroutines required : GALE0, WGKNOT *
C *
C*****************************************************************
C *
C author : Norbert Vogt *
C date : 05.18.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER N, IDGR, IERR, GRDFLG, NMAX
DOUBLE PRECISION AK (0:IDGR, 2), ZWGH (21), XZERO (21)
DOUBLE PRECISION EPS
C
C testing the input parameter
C
IF (N .LT. 0 .OR. EPS .LT. 1.0D-12 .OR. NMAX .LT. 1) THEN
C
C If N < 0 or EPS < 1.D-12 or NMAX < 1
C ==> return to calling program
C
IERR = 9
R E T U R N
ELSEIF (LQM .LT. 1 .OR. LQM .GT. 5) THEN
C
C If LQM < 1 or LQM > 5
C ==> return to calling program
C
IERR = 10
R E T U R N
ELSEIF (LQM .EQ. 2) THEN
C
C If LQM = 2
C ==> use GAUSS quadrature
C
IF (IDGR .LE. 1 .OR. IDGR .GT. 20) THEN
C
C If IDGR <= 1 or IDGR > 20
C ==> return to calling program
C
IERR = 6
R E T U R N
ELSE
C
C the desired GAUSS quadrature formula
C of degree 1 < IDGR < 20 is generated
C
CALL GALE0 (IDGR, .TRUE., XZERO, ZWGH)
C
C nodes
C
GRDFLG = 0
C
C Is 0 a node ?
C
IF ((MOD(IDGR,2) .EQ. 1)) GRDFLG = 1
ENDIF
ELSEIF (LQM .EQ. 3) THEN
C
C If LQM = 3
C ==> use CLENSHAW-CURTIS formulas
C
IF (MOD(IDGR,2) .NE. 0 .OR. IDGR .LT. 2) THEN
C
C If IDGR is not even or if IDGR < 2
C ==> return to calling program
C
IERR = 7
R E T U R N
ELSE
C
C the weights and nodes for the CLENSHAW-
C CURTIS formulas are determined
C
CALL WGKNOT (IDGR, AK, IERR2)
ENDIF
ELSEIF (LQM .EQ. 5) THEN
C
C If LQM = 5
C ==> use summed NEWTON-COTES formula
C
IF (IDGR .LT . 2 .OR. IDGR .GT. 7) THEN
C
C If IDGR < 2 or IDGR > 7
C ==> return to calling program
C
IERR = 8
R E T U R N
ENDIF
C
C for LQM = 1 and LQM = 4 no further
C tests are required
C
ENDIF
R E T U R N
END
C
C
SUBROUTINE GXQUAD (NODE, FCT, XZERO, ZWGH, LQM, GRDFLG,
+ AK, IDGR, IERR2)
C
C*****************************************************************
C *
C This SUBROUTINE determines the approximate integral of the *
C FUNCTION FCT(X) over the interval (A,B) by the quadrature *
C formula determined by LQM as follows: *
C LQM = 1: trapezoidal rule *
C LQM = 2: IDGR =2,...,20 : I-point-formula of GAUSS *
C LQM = 3: IDGR =2,4,6,...: CLENSHAW-CURTIS formula with *
C IDGR + 1 weights *
C LQM = 4: ROMBERG method *
C LQM = 5: IDGR =2,...,7 : NEWTON-COTES formulas with *
C IDGR nodes *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C NODE : contains the index of the sub-interval over which we *
C integrate *
C FCT : name of integrand *
C XZERO : nodes of the GAUSS-quadrature formula *
C ZWGH : weights for the nodes of the GAUSS-formulas *
C LQM : indicates quadrature formula to be used *
C GRDFLG: =1, if 0 is a node; =0, if 0 is not a node *
C AK : weights and nodes for the CLENSHAW-CURTIS formulas *
C IDGR : degree of the quadrature formula *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C NODE(2): computed value for the integral over the interval *
C [NODE(3), NODE(4)] *
C *
C----------------------------------------------------------------*
C *
C subroutines required : CLENSH, QUAROM, QUANEC, GXGAUSS *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 05.10.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
IMPLICIT DOUBLE PRECISION (A-H, O-Z)
EXTERNAL FCT
INTEGER IDGR
DOUBLE PRECISION NODE(4), XZERO(IDGR), ZWGH(IDGR), XL
DOUBLE PRECISION AK(0:IDGR, 2), H, EL(10), ERREST, QV
INTEGER GRDFLG
C
IF (LQM .EQ. 2 ) THEN
C
C If LQM = 2
C ==> the integral is determined using the GAUSS-quadrature
C formula of degree IDGR
C
CALL GXGAUS (NODE(3), XZERO, ZWGH, IDGR, GRDFLG, FCT, QV)
C
ELSEIF (LQM .EQ. 3) THEN
C
C If LQM = 2
C ==> the integral is determined using the summed CLENSHAW-
C CURTIS formula with IDGR weights
C
CALL CLENSH (FCT, IDGR, NODE(3), 1, AK, QV, IERR)
C
ELSEIF (LQM .EQ. 4) THEN
C
C If LQM = 4
C ==> the integral is determined via the ROMBERG method
C
H = 0.0D0
NROWS = 10
CALL QUAROM (NODE(3), NODE(4), 1.0D-8, NROWS, H,
+ FCT, EL, QV, ERREST, IERR)
C
ELSEIF (LQM .EQ. 5) THEN
C
C If LQM = 5
C ==> the integral is determined by the summed
C NEWTON-COTES formula with IDGR nodes
C
CALL QUANEC (NODE(3), NODE(4), 1, IDGR, FCT, QV,
+ EL(1), EL(2), IERR)
C
ELSE
C
C If LQM = 1
C ==> the integral is determined by the trapezoidal rule
C
XL = (NODE(4) - NODE(3)) * 0.5D0
QV = XL * (FCT(NODE(3)) + FCT(NODE(4)))
ENDIF
C
C store the result and return
C
NODE(2) = QV
IF (IERR .GT. 0) THEN
IERR2 = 100
ELSE
IERR2 = 0
ENDIF
R E T U R N
END
C
C
SUBROUTINE GXINS (NMAX,DATA,STATUS,N,T,N1,N2,ITNODE,IPOS)
C
C*****************************************************************
C *
C This SUBROUTINE inserts two new sub-intervals into a linearly *
C ordered list and and then re-sorts the list. *
C For this a binary search is used. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C NMAX : maximum number of intervals that can be produced *
C DATA : storage for the generated intervals *
C N : current number of the intervals produced *
C T : pointer vector, used as an indirect address list *
C ITNODE: contains the status information for N1 and N2 *
C N1, N2: sub-intervals to be inserted into DATA *
C STATUS: contains the status information ofr each interval *
C IPOS : binary search starts at this index *
C *
C----------------------------------------------------------------*
C *
C subroutines required : none *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 04.10.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION DATA (NMAX, 4), N1(4), N2(4)
INTEGER T(NMAX), STATUS(NMAX, 2), ITNODE(2)
C
C binary search to find the position in the list
C where the new sub-intervals are to be inserted
C
IF (N .LE. 1) THEN
N = N + 2
IT1 = T(N-1)
IT2 = T(N)
ELSE
I = IPOS
J = N
C
C WHILE (I < J)
C
100 K = INT((I+J)/2)
IF ( N1(1) .LT. DATA(T(K),1) ) THEN
I = K+1
ELSE
J = K-1
ENDIF
IF (I .LE. J) GOTO 100
C
C insert the new sub-intervals
C
N = N + 2
II = N
IT1 = T(N)
IT2 = T(N-1)
DO 30 L = N, I+2, -1
T(L) = T(L-2)
30 CONTINUE
C
T(I) = IT1
T(I+1) = IT2
ENDIF
C
DO 10 J = 1, 4
DATA(IT1, J) = N1(J)
DATA(IT2, J) = N2(J)
10 CONTINUE
DO 20 J = 1, 2
STATUS(IT1, J) = ITNODE(J)
STATUS(IT2, J) = ITNODE(J)
20 CONTINUE
C
R E T U R N
END
C
C
SUBROUTINE GXDEL (NMAX, NCELLS, T, POS)
C
C*****************************************************************
C *
C SUBROUTINE GXDEL erases the sub-interval indexed POS in the *
C linearly ordered list XNODES using the pointer vector T and *
C then re-sorts the vector T. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C NMAX : maximum number of sub-intervals allowed *
C NCELLS: current number of sub-intervals produced *
C T : pointer vector, used for indirect addressing *
C POS : index of the interval to be erased *
C *
C----------------------------------------------------------------*
C *
C subroutines required : none *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 04.10.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
INTEGER T(NMAX), POS
C
ISAVE = T(POS)
NCELLS = NCELLS - 1
C
IF ( NCELLS .EQ. 0 ) R E T U R N
C
DO 1 J = POS, NCELLS
T(J) = T(J+1)
1 CONTINUE
T(NCELLS + 1) = ISAVE
C
R E T U R N
END
C
C
SUBROUTINE GXDIV (NODE, R, L, FCT, XZERO, ZWGH, LQM, GRDFLG,
+ AK, IDGR, IERR2)
C
C*****************************************************************
C *
C SUBROUTINE GXDIV subdivides the interval NODE into two equal *
C sized sub-intervals. For each of these two new sub-intervals *
C the numerical value of the integral, the error and the new *
C interval endpoints are determined. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C NODE : contains the data of the interval to be subdivided *
C FCT : name of the function to be integrated *
C XZERO : nodes of the GAUSS-quadratureformula *
C ZWGH : weights for the nodes *
C LQM : quadrature formula to be used *
C GRDFLG: =1, if 0 is a node; =0, if 0 is not a node *
C AK : weights and nodes for the CLENSHAW-CURTIS formula *
C IDGR : degree of the quadrature formula *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C R : contains the data for the right sub-interval of NODE *
C L : contains the data for the left sub-interval of NODE *
C *
C----------------------------------------------------------------*
C *
C subroutines required : GXQUAD *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 04.10.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
EXTERNAL FCT
INTEGER IDGR
DOUBLE PRECISION NODE(4), R(4), L(4), XZERO(IDGR),
+ ZWGH(IDGR), AK(0:IDGR, 2)
INTEGER GRDFLG
C
C determine the new interval endpoints
C
L(3) = NODE(3)
R(4) = NODE(4)
L(4) = (L(3) + R(4)) * 0.5D0
R(3) = L(4)
C
C integrate over the new sub-intervals
C
CALL GXQUAD (L, FCT, XZERO, ZWGH, LQM, GRDFLG, AK, IDGR, IERR2)
CALL GXQUAD (R, FCT, XZERO, ZWGH, LQM, GRDFLG, AK, IDGR, IERR2)
C
C estimate of the error for the computed integral values
C
L(1) = DABS(L(2) + R(2) - NODE(2))
R(1) = L(1)
R E T U R N
END
C
C
SUBROUTINE GXACC (NMAX, DATA, STATUS, N, T ,NODE, ITNODE, K)
C
C*****************************************************************
C *
C This SUBROUTINE permits access to the K-th sub-interval in *
C the linearly ordered list DATA. *
C *
C *
C INPUT PARAMETERS: *
C ================= *
C NMAX : maximum number of sub-intervals allowed *
C DATA : storage for the sub-intervals produced *
C STATUS: contains the status information for each sub-interval *
C N : current number of produced sub-intervals *
C T : pointer vector, used for indirect addressing *
C K : determines the K-th sub-interval within DATA *
C *
C *
C OUTPUT PARAMETERS: *
C ================== *
C NODE : contains the data for the K-th sub-interval *
C ITNODE: contains the status data of the K-th sub-interval *
C *
C----------------------------------------------------------------*
C *
C subroutines required : none *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 04.19.1989 *
C source : FORTRAN 77 *
C *
C*****************************************************************
C
DOUBLE PRECISION DATA (NMAX, 4), NODE(4)
INTEGER T(NMAX), STATUS (NMAX, 2), ITNODE(2)
C
IF (K .LT. 1 .OR. K .GT. N .OR. N .GT. NMAX) RETURN
DO 10 J = 1, 4
NODE(J) = DATA(T(K), J)
10 CONTINUE
DO 20 J = 1, 2
ITNODE(J) = STATUS(T(K), J)
20 CONTINUE
R E T U R N
END
C
C
SUBROUTINE GXGAUS (VAL, XZERO, ZWGH, IDGR, GRDFLG, FCT, QV)
C
C*****************************************************************
C *
C This SUBROUTINE determines the integral of a function FCT *
C over the interval [VAL(1),VAL(2)] by the GAUSS-quadrature *
C formula of degree IDGR *
C *
C INPUT PARAMETERS: *
C ================= *
C VAL : vector VAL(1:2), the interval endpoints *
C XZERO : vector of nodes *
C ZWGH : vector of weights *
C IDGR : number of weights and nodes *
C FCT : function to be integrated *
C GRDFLG : =1, if 0 is a node; =0, if 0 is not a node *
C *
C OUTPUT PARAMETER: *
C ================= *
C QV : value for the integral *
C *
C----------------------------------------------------------------*
C *
C subroutines required : none *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 05.17.1989 *
C source : FORTRAN-77 *
C *
C*****************************************************************
C
IMPLICIT DOUBLE PRECISION (A-H, O-Z)
INTEGER IDGR, KDIV2, GRDFLG
DOUBLE PRECISION QV, XM, XL, W
DOUBLE PRECISION VAL(1:2), XZERO(IDGR), ZWGH(IDGR)
EXTERNAL FCT
C
C GAUSS-quadrature
C
QV = 0.0D0
TW = 0.0D0
XM = (VAL(2) + VAL(1)) * 0.5D0
XL = XM - VAL(1)
KDIV2 = INT(DBLE(IDGR) * 0.5D0)
DO 10 I = 1, KDIV2
W = XL * XZERO(I)
QV = QV + (FCT(XM-W) + FCT(XM+W)) * ZWGH(I)
10 CONTINUE
C
C Is 0 a node ?
C
IF (GRDFLG .EQ. 1) THEN
QV = (QV + FCT(XM) * ZWGH(KDIV2+1) ) * XL
ELSE
QV = QV * XL
ENDIF
R E T U R N
END
C
C
SUBROUTINE GXRIEP (QVAL, EL, ELEPS, EPSEXE, EPSL, M,
+ EPS, EXE, QEXE)
C
C*****************************************************************
C *
C SUBROUTINE GXRIEP extrapolates the current quadrature *
C value using the new value of T(K,0) using RICHARDSON extra-*
C polation and the EPSILON-algorithm. This results in a new *
C error and a new quadrature value for the sub-interval. *
C *
C IN/OUTPUT PARAMETERS: *
C ===================== *
C *
C QVAL : current quadrature value *
C EPS : relative accuracy *
C EXE : absolute accuracy *
C EL : vector EL(0:M), ther current ROMBERG row *
C ELEPS : vector ELEPS(0:M), the current EPSILON-row *
C M : number of executed calls of GXRIEP + 1 *
C EPSEXE : auxiliary variable *
C EPSL : auxiliary variable *
C QEXE : quadrature value *
C *
C----------------------------------------------------------------*
C *
C subroutines required : none *
C *
C*****************************************************************
C *
C author : Hermann-Josef Rheinbach *
C editor : Norbert Vogt *
C date : 05.16.1989 *
C source : FORTRAN-77 *
C *
C*****************************************************************
C
IMPLICIT DOUBLE PRECISION (E)
DOUBLE PRECISION EL(0:M), ELEPS(0:M), EPS, EPSEXE,
+ EPSL, EXE
DOUBLE PRECISION SAVE1, SAVE2, AM, QEXE, QVAL
INTEGER M, J, IM
C
C RICHARDSON extrapolation with the new T(K,0)
C
IF (M .GT. 102) RETURN
SAVE1 = EL(M)
M = M + 1
AM = 1.0D0
EL(M) = 0.0D0
EL1 = EL(1)
EL(1) = QVAL
DO 120 J = 2, M
AM = AM * 4.0D0
EL2 = EL(J)
EL(J) = (AM * EL(J-1) - EL1) / (AM-1)
EL1 = EL2
120 CONTINUE
C
C extrapolation using the EPSILON algorithm
C
IF (MOD(M,2) .EQ. 0) THEN
IM = M-1
SAVE2 = ELEPS(IM)
ELSE
SAVE2 = ELEPS(M-2)
IM = M
ENDIF
C
ELEPS(M) = 0.0D0
EPSELS = ELEPS(1)
EPSEL1 = ELEPS(1)
ELEPS(1) = QVAL
DO 121 J = 2, M
EPSEL2 = ELEPS(J)
IF ( DABS(ELEPS(J-1)-EPSEL1) .EQ. 0.0D0) THEN
ELEPS(J) = EPSELS
ELSE
ELEPS(J) = EPSELS + 1.0D0 / (ELEPS(J-1)-EPSEL1 )
EPSELS = EPSEL1
ENDIF
EPSEL1 = EPSEL2
121 CONTINUE
EXE = DABS(EL(M) - EL(M-1)) + DABS(EL(M) - SAVE1)
IF (M .GT. 2) THEN
EPSEXE = DABS(ELEPS(IM)-SAVE2) + DABS(ELEPS(IM) - ELEPS(IM-2))
QEXE = ELEPS(IM)
ENDIF
IF (EXE .LT. EPSEXE) QEXE = EL(M)
EPSL = EPS * DABS(QEXE)
EXE = DMIN1 (EXE,EPSEXE)
R E T U R N
END