home *** CD-ROM | disk | FTP | other *** search
/ BURKS 2 / BURKS_AUG97.ISO / BURKS / LANGUAGE / FORTRAN / F77TO90 / code / quad2.f90 < prev    next >
Text File  |  1996-01-09  |  2KB  |  40 lines
  1. RECURSIVE FUNCTION ADAPTIVE_QUAD (F, A, B, FA, FB, 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, FA, FB, TOL
  13.        REAL, INTENT(OUT)       :: ABS_ERROR
  14.        REAL                    :: RESULT
  15.  
  16.        REAL                    :: STEP, MIDDLE_POINT, FMIDDLE
  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.        FMIDDLE = F(MIDDLE_POINT)
  24.        ONE_TRAPEZOIDAL_AREA = STEP * 0.5 * (FA + FB)
  25.        TWO_TRAPEZOIDAL_AREAS = STEP * 0.25 * (FA + 2.0*FMIDDLE + FB)
  26.        DIFF = TWO_TRAPEZOIDAL_AREAS - ONE_TRAPEZOIDAL_AREA
  27.  
  28.        IF ( ABS (DIFF) < TOL ) THEN
  29.               RESULT = TWO_TRAPEZOIDAL_AREAS + DIFF/3.0
  30.               ABS_ERROR = ABS(DIFF)
  31.        ELSE
  32.               LEFT_AREA = ADAPTIVE_QUAD (F, A, MIDDLE_POINT, FA, FMIDDLE, &
  33.                       0.5*TOL, ABS_ERROR_L)
  34.               RIGHT_AREA = ADAPTIVE_QUAD (F, MIDDLE_POINT, B, FMIDDLE, FB, &
  35.                        0.5*TOL, ABS_ERROR_R)
  36.               RESULT = LEFT_AREA + RIGHT_AREA
  37.               ABS_ERROR = ABS_ERROR_L + ABS_ERROR_R
  38.        END IF
  39. END FUNCTION ADAPTIVE_QUAD
  40.