home *** CD-ROM | disk | FTP | other *** search
/ BURKS 2 / BURKS_AUG97.ISO / BURKS / LANGUAGE / FORTRAN / F77TO90 / code / quad.f90 < prev    next >
Text File  |  1996-01-09  |  1KB  |  41 lines
  1. RECURSIVE FUNCTION ADAPTIVE_QUAD (F, A, B, TOL, ABS_ERROR) &
  2.                 RESULT (RESULT)
  3. IMPLICIT NONE
  4.  
  5.        INTERFACE
  6.               FUNCTION F(X) RESULT (FUNCTION_VALUE)
  7.               REAL, INTENT(IN) :: X
  8.               REAL             :: FUNCTION_VALUE
  9.               END FUNCTION F
  10.        END INTERFACE
  11.  
  12.        REAL, INTENT(IN)        :: A, B, TOL
  13.        REAL, INTENT(OUT)       :: ABS_ERROR
  14.        REAL                    :: RESULT
  15.  
  16.        REAL                    :: STEP, MIDDLE_POINT
  17.        REAL                    :: ONE_TRAPEZOIDAL_AREA, TWO_TRAPEZOIDAL_AREAS
  18.        REAL                    :: LEFT_AREA, RIGHT_AREA
  19.        REAL                    :: DIFF, ABS_ERROR_L, ABS_ERROR_R
  20.  
  21.        STEP = B-A
  22.        MIDDLE_POINT= 0.5 * (A+B)
  23.  
  24.        ONE_TRAPEZOIDAL_AREA = STEP * 0.5 * (F(A)+ F(B))
  25.        TWO_TRAPEZOIDAL_AREAS = STEP * 0.25 * (F(A) + F(MIDDLE_POINT))+&
  26.                            STEP * 0.25 * (F(MIDDLE_POINT) + F(B))
  27.        DIFF = TWO_TRAPEZOIDAL_AREAS - ONE_TRAPEZOIDAL_AREA
  28.  
  29.        IF ( ABS (DIFF) < TOL ) THEN
  30.               RESULT = TWO_TRAPEZOIDAL_AREAS + DIFF/3.0
  31.               ABS_ERROR = ABS(DIFF)
  32.        ELSE
  33.               LEFT_AREA = ADAPTIVE_QUAD (F, A, MIDDLE_POINT, &
  34.                       0.5*TOL, ABS_ERROR_L)
  35.               RIGHT_AREA = ADAPTIVE_QUAD (F, MIDDLE_POINT, B, &
  36.                        0.5*TOL, ABS_ERROR_R)
  37.               RESULT = LEFT_AREA + RIGHT_AREA
  38.               ABS_ERROR = ABS_ERROR_L + ABS_ERROR_R
  39.        END IF
  40. END FUNCTION ADAPTIVE_QUAD
  41.