home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BURKS 2
/
BURKS_AUG97.ISO
/
BURKS
/
LANGUAGE
/
FORTRAN
/
F77TO90
/
code
/
quad.f90
< prev
next >
Wrap
Text File
|
1996-01-09
|
1KB
|
41 lines
RECURSIVE FUNCTION ADAPTIVE_QUAD (F, A, B, TOL, ABS_ERROR) &
RESULT (RESULT)
IMPLICIT NONE
INTERFACE
FUNCTION F(X) RESULT (FUNCTION_VALUE)
REAL, INTENT(IN) :: X
REAL :: FUNCTION_VALUE
END FUNCTION F
END INTERFACE
REAL, INTENT(IN) :: A, B, TOL
REAL, INTENT(OUT) :: ABS_ERROR
REAL :: RESULT
REAL :: STEP, MIDDLE_POINT
REAL :: ONE_TRAPEZOIDAL_AREA, TWO_TRAPEZOIDAL_AREAS
REAL :: LEFT_AREA, RIGHT_AREA
REAL :: DIFF, ABS_ERROR_L, ABS_ERROR_R
STEP = B-A
MIDDLE_POINT= 0.5 * (A+B)
ONE_TRAPEZOIDAL_AREA = STEP * 0.5 * (F(A)+ F(B))
TWO_TRAPEZOIDAL_AREAS = STEP * 0.25 * (F(A) + F(MIDDLE_POINT))+&
STEP * 0.25 * (F(MIDDLE_POINT) + F(B))
DIFF = TWO_TRAPEZOIDAL_AREAS - ONE_TRAPEZOIDAL_AREA
IF ( ABS (DIFF) < TOL ) THEN
RESULT = TWO_TRAPEZOIDAL_AREAS + DIFF/3.0
ABS_ERROR = ABS(DIFF)
ELSE
LEFT_AREA = ADAPTIVE_QUAD (F, A, MIDDLE_POINT, &
0.5*TOL, ABS_ERROR_L)
RIGHT_AREA = ADAPTIVE_QUAD (F, MIDDLE_POINT, B, &
0.5*TOL, ABS_ERROR_R)
RESULT = LEFT_AREA + RIGHT_AREA
ABS_ERROR = ABS_ERROR_L + ABS_ERROR_R
END IF
END FUNCTION ADAPTIVE_QUAD