873 lines
41 KiB
Fortran
873 lines
41 KiB
Fortran
!
|
|
!=======================================================================
|
|
!
|
|
MODULE INTEGRATION4
|
|
!
|
|
! This module contains integration routines in order to integrate
|
|
! a function F over the interval [A,B].
|
|
!
|
|
! These routines are:
|
|
!
|
|
!
|
|
! * Newton-Cotes/Euler-Mac Laurin : INTEGR_I(X,F,F_1,F_3,F_5,N_BEG,
|
|
! N_END,N_POINTS,METH,N_RULE,RES)
|
|
!
|
|
!
|
|
USE ACCURACY_REAL
|
|
!
|
|
CONTAINS
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE INTEGR_I(X,F,F_1,F_3,F_5,N_BEG,N_END,N_POINTS, &
|
|
METH,N_RULE,RES)
|
|
!
|
|
! This is the driver routine that calls the subroutine that
|
|
! integrates a function F(X), defined over
|
|
! the interval [1,N_POINTS] with constant step H
|
|
! over the interval [N_BEG,N_END]
|
|
!
|
|
! To increase the accuracy, it computes the integral according
|
|
! to different schemes. There are four ways to compute the
|
|
! integral:
|
|
! int[N_BEG,N_END] (1)
|
|
! int[1,N_END]-int[1,N_BEG] (2)
|
|
! int[N_BEG,N_POINTS]-int[N_END,N_POINTS] (3)
|
|
! int[1,N_POINTS]-int[1,N_BEG]-int[N_END,N_POINTS] (4)
|
|
!
|
|
! Method (4) is never used as it is equivalent either to method (2)
|
|
! or to method (3) in terms of accuracy
|
|
!
|
|
! This subroutine selects the method involving the larger number
|
|
! of points, i.e. max([N_BEG,N_END],int[1,N_BEG],[N_END,N_POINTS])
|
|
!
|
|
!
|
|
! Input parameters:
|
|
!
|
|
! * X : X point of function to be integrated
|
|
! * F : function to be integrated
|
|
! * F_1 : first order derivative of F
|
|
! * F_3 : third order derivative of F
|
|
! * F_5 : fifth order derivative of F
|
|
! * N_BEG : starting X point for integration of F
|
|
! * N_END : end X point for integration of F
|
|
! * N_POINTS : dimensioning of F (1 to N_POINTS)
|
|
! * METH : integration method used
|
|
!
|
|
! = 'NCQ' : Newton-Cotes
|
|
! = 'EMS' : Euler-Mac Laurin summation
|
|
!
|
|
! * N_RULE : number of points used in the quadrature formula
|
|
!
|
|
! NCQ : Newton-Cotes quadrature rule | Accuracy
|
|
!
|
|
! --> N_RULE = 2 : trapezoidal | H^3
|
|
! --> N_RULE = 3 : Simpson 1/3 | H^5
|
|
! --> N_RULE = 4 : Simpson 3/8 | H^5
|
|
! --> N_RULE = 5 : Boole/Milne | H^7
|
|
! --> N_RULE = 6 : Weddle | H^7
|
|
!
|
|
! EMS : Euler-Mac Laurin summation | Accuracy
|
|
!
|
|
! --> N_RULE = 2 (uses F_1) | H^5
|
|
! --> N_RULE = 3 (uses F_1,F_3) | H^7
|
|
! --> N_RULE = 4 (uses F_1,F_3,F_5) | H^9
|
|
!
|
|
! BN(J) is a Bernoulli number
|
|
!
|
|
!
|
|
! Output parameters:
|
|
!
|
|
! * RES : result of the integration of F over the whole
|
|
! interval [1,N_END]
|
|
!
|
|
!
|
|
! Author : D. Sébilleau
|
|
!
|
|
! Last modified : 6 Aug 2020
|
|
!
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL (WP) :: F(N_POINTS),F_1(N_POINTS)
|
|
REAL (WP) :: F_3(N_POINTS),F_5(N_POINTS)
|
|
REAL (WP) :: X(N_POINTS)
|
|
REAL (WP) :: RES,RES1,RES2
|
|
!
|
|
INTEGER :: N_BEG,N_END,N_POINTS,N_RULE
|
|
INTEGER :: N_SIZE_I,N_SIZE_L,N_SIZE_U
|
|
INTEGER :: N_HALF
|
|
!
|
|
CHARACTER (LEN = 3) :: METH
|
|
!
|
|
! Checking the number of points in the integration interval
|
|
! with respect to that over which the function F(X) is defined
|
|
!
|
|
N_SIZE_I=N_END-N_BEG+1 !
|
|
N_SIZE_L=N_BEG !
|
|
N_SIZE_U=N_POINTS-N_END+1 !
|
|
!
|
|
N_HALF=N_POINTS/2 !
|
|
!
|
|
IF(N_SIZE_I >= N_HALF) THEN !
|
|
!
|
|
!........... Interval of integration larger than half of ...........
|
|
!........... the interval of definition of F(X) ...........
|
|
!
|
|
! Using method (1)
|
|
!
|
|
CALL INTEGR_INT(X,F,F_1,F_3,F_5,N_BEG,N_END,N_POINTS, & !
|
|
METH,N_RULE,RES) !
|
|
!
|
|
ELSE !
|
|
!
|
|
!........... Interval of integration smaller than half of ...........
|
|
!........... the interval of definition of F(X) ...........
|
|
!
|
|
IF(N_SIZE_U >= N_SIZE_L) THEN !
|
|
!
|
|
! Using method (3)
|
|
!
|
|
CALL INTEGR_INT(X,F,F_1,F_3,F_5,N_BEG,N_POINTS,N_POINTS,& !
|
|
METH,N_RULE,RES1) !
|
|
CALL INTEGR_INT(X,F,F_1,F_3,F_5,N_END,N_POINTS,N_POINTS,& !
|
|
METH,N_RULE,RES2) !
|
|
!
|
|
RES=RES1-RES2 !
|
|
!
|
|
ELSE !
|
|
!
|
|
! Using method (2)
|
|
!
|
|
CALL INTEGR_INT(X,F,F_1,F_3,F_5,1,N_END,N_POINTS, & !
|
|
METH,N_RULE,RES1) !
|
|
CALL INTEGR_INT(X,F,F_1,F_3,F_5,1,N_BEG,N_POINTS, & !
|
|
METH,N_RULE,RES2) !
|
|
!
|
|
RES=RES1-RES2 !
|
|
!
|
|
END IF !
|
|
!
|
|
END IF !
|
|
!
|
|
END SUBROUTINE INTEGR_I
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE INTEGR_INT(X,F,F_1,F_3,F_5,N_BEG,N_END,N_POINTS, &
|
|
METH,N_RULE,RES)
|
|
!
|
|
! This subroutine integrates the function F(X), defined over
|
|
! the interval [1,N_POINTS] with constant step H
|
|
! over the interval [N_BEG,N_END].
|
|
!
|
|
!
|
|
! Input parameters:
|
|
!
|
|
! * X : X point of function to be integrated
|
|
! * F : function to be integrated
|
|
! * F_1 : first order derivative of F
|
|
! * F_3 : third order derivative of F
|
|
! * F_5 : fifth order derivative of F
|
|
! * N_BEG : starting X point for integration of F
|
|
! * N_END : end X point for integration of F
|
|
! * N_POINTS : dimensioning of F (1 to N_POINTS)
|
|
! * METH : integration method used
|
|
!
|
|
! = 'NCQ' : Newton-Cotes
|
|
! = 'EMS' : Euler-Mac Laurin summation
|
|
!
|
|
! * N_RULE : number of points used in the quadrature formula
|
|
!
|
|
! NCQ : Newton-Cotes quadrature rule | Accuracy
|
|
!
|
|
! --> N_RULE = 2 : trapezoidal | H^3
|
|
! --> N_RULE = 3 : Simpson 1/3 | H^5
|
|
! --> N_RULE = 4 : Simpson 3/8 | H^5
|
|
! --> N_RULE = 5 : Boole/Milne | H^7
|
|
! --> N_RULE = 6 : Weddle | H^7
|
|
!
|
|
! EMS : Euler-Mac Laurin summation | Accuracy
|
|
!
|
|
! --> N_RULE = 2 (uses F_1) | H^5
|
|
! --> N_RULE = 3 (uses F_1,F_3) | H^7
|
|
! --> N_RULE = 4 (uses F_1,F_3,F_5) | H^9
|
|
!
|
|
! BN(J) is a Bernoulli number
|
|
!
|
|
!
|
|
! Output parameters:
|
|
!
|
|
! * RES : result of the integration of F over the whole
|
|
! interval [1,N_END]
|
|
!
|
|
!
|
|
! References: M. Abramowitz and I. A. Stegun, "Handbook of Mathematical
|
|
! "Functions", 9th Dover printing, pp.886-887, Dover
|
|
!
|
|
! P. A. Almeida Magalhaes Jr and C. Almeida Magalhaes,
|
|
! J. Math. Stat. 6, 193-204 (2010)
|
|
!
|
|
! This version: closed Newton-Cotes formula limited to N_RULE = 6
|
|
! no open Newton-Cotes formula included
|
|
! Euler-MacLaurin formula limited to N_RULE = 3
|
|
!
|
|
! Author : D. Sébilleau
|
|
!
|
|
! Last modified : 6 Aug 2020
|
|
!
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,FIVE, &
|
|
HALF,THIRD,FOURTH,FIFTH
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL (WP) :: F(N_POINTS),F_1(N_POINTS)
|
|
REAL (WP) :: F_3(N_POINTS),F_5(N_POINTS)
|
|
REAL (WP) :: X(N_POINTS)
|
|
REAL (WP) :: F_INT1,F_INT2,F_INT3,F_INT4
|
|
REAL (WP) :: RES,RES0,RES1,C_H
|
|
REAL (WP) :: BN(0:6),H,H1
|
|
REAL (WP) :: CNC2(2),CNC3(3),CNC4(4),CNC5(5),CNC6(6)
|
|
REAL (WP) :: CN(6)
|
|
REAL (WP) :: P,A(10)
|
|
!
|
|
REAL (WP) :: DFLOAT
|
|
!
|
|
INTEGER :: N_BEG,N_END,N_POINTS,N_RULE
|
|
INTEGER :: I_FLAG
|
|
INTEGER :: J
|
|
INTEGER :: N_REM,N_FIN
|
|
INTEGER :: LOGF
|
|
!
|
|
CHARACTER (LEN = 3) :: METH
|
|
!
|
|
! Bernouilli numbers
|
|
!
|
|
DATA BN /1.0E0_WP,-0.50E0_WP, &
|
|
0.166666666666666666666666667E0_WP,0.0E0_WP, &
|
|
0.000000000000000000000000000E0_WP,0.0E0_WP, &
|
|
0.023809523809523809523809524E0_WP /
|
|
!
|
|
! Closed formula Newton-Cotes coefficients CNCn for n-point formula
|
|
!
|
|
DATA CNC2 / 1.0E0_WP, 1.0E0_WP/
|
|
DATA CNC3 / 1.0E0_WP, 4.0E0_WP, 1.0E0_WP/
|
|
DATA CNC4 / 1.0E0_WP ,3.0E0_WP, 3.0E0_WP, 1.0E0_WP/
|
|
DATA CNC5 / 7.0E0_WP,32.0E0_WP,12.0E0_WP,32.0E0_WP, 7.0E0_WP/
|
|
DATA CNC6 /19.0E0_WP,75.0E0_WP,50.0E0_WP,50.0E0_WP,75.0E0_WP, 19.0E0_WP/
|
|
!
|
|
DATA CN / 0.0E0_WP, 2.0E0_WP, 6.0E0_WP, 8.0E0_WP,90.0E0_WP,288.0E0_WP/
|
|
!
|
|
LOGF=6 !
|
|
!
|
|
! Checking for consistency of input data
|
|
!
|
|
IF(N_BEG < 1) THEN !
|
|
WRITE(6,10) !
|
|
STOP !
|
|
END IF !
|
|
!
|
|
IF(N_END > N_POINTS) THEN !
|
|
WRITE(6,20) !
|
|
STOP !
|
|
END IF !
|
|
!
|
|
IF(METH == 'NCQ') THEN !
|
|
IF( (N_RULE < 2) .OR. (N_RULE > 6) ) THEN !
|
|
WRITE(6,30) !
|
|
STOP !
|
|
END IF !
|
|
ELSEIF(METH == 'EMS') THEN !
|
|
IF( (N_RULE < 2) .OR. (N_RULE > 4) ) THEN !
|
|
WRITE(6,40) !
|
|
STOP !
|
|
END IF !
|
|
END IF !
|
|
!
|
|
H=X(2)-X(1) !
|
|
!
|
|
I_FLAG=N_RULE-1 !
|
|
!
|
|
!
|
|
! Computation of Int_{1}^{X} F(X) dX for X in [N_BEG,N_END]
|
|
!
|
|
!
|
|
! The number of points used for each
|
|
! formula is N_RULE. (N_END-N_BEG-1) must
|
|
! must be divisible by I_FLAG in
|
|
! order to fully apply the formula.
|
|
! So, the formula is applied in
|
|
! the interval [N_BEG,N_END-N_REM],
|
|
! where N_REM is the remainder of
|
|
! the division of (N_END-N_BEG-1) by I_FLAG,
|
|
! and for the remaining interval,
|
|
! an interpolation is used to
|
|
! obtain exactly I_FLAG+1 points
|
|
! (F_INT1,F_INT2,F_INT3,F_INT4).
|
|
! We note N_END-N_REM-1 = N_FIN.
|
|
!
|
|
IF(METH == 'NCQ') THEN !
|
|
!
|
|
N_REM=MOD(N_END-N_BEG,I_FLAG) !
|
|
N_FIN=N_END-N_REM-1 !
|
|
C_H=DFLOAT(I_FLAG)/CN(N_RULE) !
|
|
RES0=ZERO !
|
|
!
|
|
IF(I_FLAG == 1) THEN !
|
|
!
|
|
!............. 2-point formula ........
|
|
!
|
|
DO J=N_BEG,N_FIN,I_FLAG !
|
|
RES0=RES0+CNC2(1)*F(J)+CNC2(2)*F(J+1) !
|
|
END DO !
|
|
RES=RES0*H*C_H !
|
|
!
|
|
ELSE IF(I_FLAG == 2) THEN !
|
|
!
|
|
!............. 3-point formula ........
|
|
!
|
|
IF(N_FIN > N_BEG) THEN !
|
|
DO J=N_BEG,N_FIN,I_FLAG !
|
|
RES0=RES0+CNC3(1)*F(J)+CNC3(2)*F(J+1)+CNC3(3)*F(J+2) !
|
|
END DO !
|
|
END IF !
|
|
RES0=RES0*H*C_H !
|
|
!
|
|
IF(N_REM == 0) THEN !
|
|
RES=RES0 !
|
|
ELSE IF(N_REM == 1) THEN !
|
|
!
|
|
! Lagrange 3-point interpolation for step H/2 point
|
|
! (or Lagrange 2-point when not possible)
|
|
!
|
|
P=HALF !
|
|
IF(N_END > 2) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT1=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
RES1=CNC3(1)*F(N_END-1)+CNC3(2)*F_INT1+CNC3(3)*F(N_END) !
|
|
H1=H/TWO !
|
|
RES=RES0+RES1*H1*C_H !
|
|
END IF !
|
|
!
|
|
ELSE IF(I_FLAG == 3) THEN !
|
|
!
|
|
!............. 4-point formula ........
|
|
!
|
|
IF(N_FIN > N_BEG) THEN !
|
|
DO J=N_BEG,N_FIN,I_FLAG !
|
|
RES0=RES0 + CNC4(1)*F(J) + CNC4(2)*F(J+1) + & !
|
|
CNC4(3)*F(J+2) + CNC4(4)*F(J+3) !
|
|
END DO !
|
|
END IF !
|
|
RES0=RES0*H*C_H !
|
|
!
|
|
IF(N_REM == 0) THEN !
|
|
RES=RES0 !
|
|
ELSE IF(N_REM == 1) THEN !
|
|
!
|
|
! Lagrange 3-point interpolation for step H/3 points
|
|
! (or Lagrange 2-point when not possible)
|
|
!
|
|
P=THIRD !
|
|
IF(N_END > 2) THEN
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT1=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
P=TWO*THIRD !
|
|
IF(N_END > 2) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT2=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
RES1=CNC4(1)*F(N_END-1) + CNC4(2)*F_INT1 + & !
|
|
CNC4(3)*F_INT2 + CNC4(4)*F(N_END) !
|
|
H1=H/THREE !
|
|
RES=RES0+RES1*H1*C_H !
|
|
!
|
|
ELSE IF(N_REM == 2) THEN !
|
|
!
|
|
! Lagrange 3-point interpolation for step 2H/3 points
|
|
! (or Lagrange 2-point when not possible)
|
|
! (F(N_END-1) is not used for the calculation of integral)
|
|
!
|
|
P=TWO*THIRD !
|
|
IF(N_END > 3) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT1=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)!
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1) !
|
|
END IF !
|
|
!
|
|
P=THIRD !
|
|
IF(N_END > 3) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT2=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
RES1=CNC4(1)*F(N_END-2) + CNC4(2)*F_INT1 + & !
|
|
CNC4(3)*F_INT2 + CNC4(4)*F(N_END) !
|
|
H1=TWO*H/THREE !
|
|
RES=RES0+RES1*H1*C_H !
|
|
!
|
|
END IF !
|
|
!
|
|
ELSE IF(I_FLAG == 4) THEN !
|
|
!
|
|
!............. 5-point formula ........
|
|
!
|
|
IF(N_FIN > N_BEG) THEN !
|
|
DO J=N_BEG,N_FIN,I_FLAG !
|
|
RES0=RES0 + CNC5(1)*F(J) + CNC5(2)*F(J+1) + & !
|
|
CNC5(3)*F(J+2) + CNC5(4)*F(J+3) + & !
|
|
CNC5(5)*F(J+4) !
|
|
END DO !
|
|
END IF !
|
|
RES0=RES0*H*C_H !
|
|
!
|
|
IF(N_REM == 0) THEN !
|
|
RES=RES0 !
|
|
ELSE IF(N_REM == 1) THEN !
|
|
!
|
|
! Lagrange 3-point interpolation for step H/4 points
|
|
! (or Lagrange 2-point when not possible)
|
|
!
|
|
P=FOURTH !
|
|
IF(N_END > 2) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT1=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
P=HALF !
|
|
IF(N_END > 2) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT2=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
P=THREE/FOUR !
|
|
IF(N_END > 2) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT3=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
RES1=CNC5(1)*F(N_END-1) + CNC5(2)*F_INT1 + & !
|
|
CNC5(3)*F_INT2 + CNC5(4)*F_INT3 + & !
|
|
CNC5(5)*F(N_END) !
|
|
H1=H/FOUR !
|
|
RES=RES0+RES1*H1*C_H !
|
|
!
|
|
ELSE IF(N_REM == 2) THEN !
|
|
!
|
|
! Lagrange 3 point interpolation for step 2H/4 points
|
|
! (or Lagrange 2-point when not possible)
|
|
!
|
|
P=HALF !
|
|
IF(N_END > 3) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT1=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)!
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1) !
|
|
END IF !
|
|
!
|
|
P=HALF !
|
|
IF(N_END > 3) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT3=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
RES1=CNC5(1)*F(N_END-2) + CNC5(2)*F_INT1 + & !
|
|
CNC5(3)*F(N_END-1) + CNC5(4)*F_INT3 + & !
|
|
CNC5(5)*F(N_END) !
|
|
H1=H/TWO !
|
|
RES=RES0+RES1*H1*C_H !
|
|
!
|
|
ELSE IF(N_REM == 3) THEN !
|
|
!
|
|
! Lagrange 3 point interpolation for step 3H/4 points
|
|
!
|
|
P=THREE/FOUR !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT1=A(1)*F(N_END-4)+A(2)*F(N_END-3)+A(3)*F(N_END-2) !
|
|
!
|
|
P=HALF !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT2=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1) !
|
|
!
|
|
P=FOURTH !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
!
|
|
RES1=CNC5(1)*F(N_END-3) + CNC5(2)*F_INT1 + & !
|
|
CNC5(3)*F_INT2 + CNC5(4)*F_INT3 + & !
|
|
CNC5(5)*F(N_END) !
|
|
H1=THREE*H/FOUR !
|
|
RES=RES0+RES1*H1*C_H !
|
|
!
|
|
END IF !
|
|
!
|
|
ELSE IF(I_FLAG == 5) THEN !
|
|
!
|
|
!............. 6-point formula ........
|
|
!
|
|
IF(N_FIN > N_BEG) THEN !
|
|
DO J=N_BEG,N_FIN,I_FLAG !
|
|
RES0=RES0 + CNC6(1)*F(J) + CNC6(2)*F(J+1) + & !
|
|
CNC6(3)*F(J+2) + CNC6(4)*F(J+3) + & !
|
|
CNC6(5)*F(J+4) + CNC6(6)*F(J+5) !
|
|
END DO !
|
|
END IF !
|
|
RES0=RES0*H*C_H !
|
|
!
|
|
IF(N_REM == 0) THEN !
|
|
RES=RES0 !
|
|
ELSE IF(N_REM == 1) THEN !
|
|
!
|
|
! Lagrange 3-point interpolation for step H/5 points
|
|
! (or Lagrange 2-point when not possible)
|
|
!
|
|
P=FIFTH !
|
|
IF(N_END > 2) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT1=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
P=TWO/FIVE !
|
|
IF(N_END > 2) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT2=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
P=THREE/FIVE !
|
|
IF(N_END > 2) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT3=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
P=FOUR/FIVE !
|
|
IF(N_END > 2) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT4=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT4=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
RES1=CNC6(1)*F(N_END-1) + CNC6(2)*F_INT1 + & !
|
|
CNC6(3)*F_INT2 + CNC6(4)*F_INT3 + & !
|
|
CNC6(5)*F_INT4 + CNC6(6)*F(N_END) !
|
|
H1=H/FIVE !
|
|
RES=RES0+RES1*H1*C_H !
|
|
!
|
|
ELSE IF(N_REM == 2) THEN !
|
|
!
|
|
! Lagrange 3 point interpolation for step 2H/5 points
|
|
! (or Lagrange 2-point when not possible)
|
|
!
|
|
P=TWO/FIVE !
|
|
IF(N_END > 3) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT1=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)!
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT1=A(1)*F(N_END-2)+A(2)*F(N_END-1) !
|
|
END IF !
|
|
!
|
|
P=FOUR/FIVE !
|
|
IF(N_END > 3) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT2=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)!
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1) !
|
|
END IF !
|
|
!
|
|
P=FIFTH !
|
|
IF(N_END > 3) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT3=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
P=THREE/FIVE !
|
|
IF(N_END > 3) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT4=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT4=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
RES1=CNC6(1)*F(N_END-2) + CNC6(2)*F_INT1 + & !
|
|
CNC6(3)*F_INT2 + CNC6(4)*F_INT3 + & !
|
|
CNC6(5)*F_INT4 + CNC6(6)*F(N_END) !
|
|
H1=TWO*H/FIVE !
|
|
RES=RES0+RES1*H1*C_H !
|
|
!
|
|
ELSE IF(N_REM == 3) THEN !
|
|
!
|
|
! Lagrange 3 point interpolation for step 3H/5 points
|
|
! (or Lagrange 2-point when not possible)
|
|
!
|
|
P=THREE/FIVE !
|
|
IF(N_END > 4) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT1=A(1)*F(N_END-4)+A(2)*F(N_END-3)+A(3)*F(N_END-2)!
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT1=A(1)*F(N_END-3)+A(2)*F(N_END-2) !
|
|
END IF !
|
|
!
|
|
P=FIFTH !
|
|
IF(N_END > 4) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT2=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)!
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT2=A(1)*F(N_END-2)+A(2)*F(N_END-1) !
|
|
END IF !
|
|
!
|
|
P=FOUR/FIVE !
|
|
IF(N_END > 4) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT3=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)!
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1) !
|
|
END IF !
|
|
!
|
|
P=TWO/FIVE !
|
|
IF(N_END > 4) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT4=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT4=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
RES1=CNC6(1)*F(N_END-3) + CNC6(2)*F_INT1 + & !
|
|
CNC6(3)*F_INT2 + CNC6(4)*F_INT3 + & !
|
|
CNC6(5)*F_INT4 + CNC6(6)*F(N_END) !
|
|
H1=THREE*H/FIVE !
|
|
RES=RES0+RES1*H1*C_H !
|
|
!
|
|
ELSE IF(N_REM == 4) THEN !
|
|
!
|
|
! Lagrange 3 point interpolation for step 4H/5 points
|
|
! (or Lagrange 2-point when not possible)
|
|
!
|
|
P=FOUR/FIVE !
|
|
IF(N_END > 5) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT1=A(1)*F(N_END-5)+A(2)*F(N_END-4)+A(3)*F(N_END-3)!
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT1=A(1)*F(N_END-4)+A(2)*F(N_END-3) !
|
|
END IF !
|
|
!
|
|
P=THREE/FIVE !
|
|
IF(N_END > 5) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT2=A(1)*F(N_END-4)+A(2)*F(N_END-3)+A(3)*F(N_END-2)!
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT2=A(1)*F(N_END-3)+A(2)*F(N_END-2) !
|
|
END IF !
|
|
!
|
|
P=TWO/FIVE !
|
|
IF(N_END > 5) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT3=A(1)*F(N_END-3)+A(2)*F(N_END-2)+A(3)*F(N_END-1)!
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT3=A(1)*F(N_END-2)+A(2)*F(N_END-1) !
|
|
END IF !
|
|
!
|
|
P=FIFTH !
|
|
IF(N_END > 5) THEN !
|
|
CALL LAGR_INTERP(3,P,A) !
|
|
F_INT4=A(1)*F(N_END-2)+A(2)*F(N_END-1)+A(3)*F(N_END) !
|
|
ELSE !
|
|
CALL LAGR_INTERP(2,P,A) !
|
|
F_INT4=A(1)*F(N_END-1)+A(2)*F(N_END) !
|
|
END IF !
|
|
!
|
|
RES1=CNC6(1)*F(N_END-4) + CNC6(2)*F_INT1 + & !
|
|
CNC6(3)*F_INT2 + CNC6(4)*F_INT3 + & !
|
|
CNC6(5)*F_INT4 + CNC6(6)*F(N_END) !
|
|
H1=FOUR*H/FIVE !
|
|
RES=RES0+RES1*H1*C_H !
|
|
!
|
|
END IF !
|
|
!
|
|
END IF !
|
|
!
|
|
ELSE IF(METH == 'EMS') THEN !
|
|
!
|
|
IF(N_RULE >= 1) THEN !
|
|
RES1=(F(N_BEG)+F(N_END))*HALF !
|
|
DO J=N_BEG+1,N_END-1 !
|
|
RES1=RES1+F(J) !
|
|
END DO !
|
|
RES1=RES1*H !
|
|
END IF !
|
|
IF(N_RULE >= 2) THEN !
|
|
RES1=RES1-BN(2)*H*H*(F_1(N_END)-F_1(N_BEG))/TWO !
|
|
END IF !
|
|
IF(N_RULE >= 3) THEN !
|
|
RES1=RES1-BN(4)*H*H*H*H*(F_3(N_END)-F_3(N_BEG))/24.0E0_WP !
|
|
END IF !
|
|
IF(N_RULE >= 4) THEN !
|
|
RES1=RES1-BN(6)*H*H*H*H*H*H*(F_5(N_END)-F_5(N_BEG)) / & !
|
|
720.0E0_WP !
|
|
END IF !
|
|
RES=RES1 !
|
|
!
|
|
END IF !
|
|
!
|
|
! Formats
|
|
!
|
|
10 FORMAT(//,10X,'<<<<< Wrong value of N_BEG: >>>>>',/, &
|
|
10X,'<<<<< Cannot be lower than 1 >>>>>',//)
|
|
20 FORMAT(//,10X,'<<<<< Wrong value of N_END: >>>>>',/, &
|
|
10X,'<<<<< Cannot exceed N_POINTS >>>>>',//)
|
|
30 FORMAT(//,10X,'<<<<< Wrong value of N_RULE: >>>>>',/, &
|
|
10X,'<<<<< Should be in [2,6] >>>>>',//)
|
|
40 FORMAT(//,10X,'<<<<< Wrong value of N_RULE: >>>>>',/, &
|
|
10X,'<<<<< Should be in [2,4] >>>>>',//)
|
|
!
|
|
END SUBROUTINE INTEGR_INT
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE LAGR_INTERP(N,P,A)
|
|
!
|
|
! This subroutine computes the coefficients for the Lagrange
|
|
! n-point interpolation, 1 < n < 7
|
|
!
|
|
! Input parameters:
|
|
!
|
|
! * N : number of points of the interpolation
|
|
! * P : value of the step fraction
|
|
!
|
|
! Output parameters:
|
|
!
|
|
! * A(N) : coefficients of the interpolation
|
|
!
|
|
!
|
|
! References: M. Abramowitz and I. A. Stegun, "Handbook of Mathematical
|
|
! "Functions", 9th Dover printing, pp.878-879, Dover
|
|
!
|
|
!
|
|
! Author : D. Sébilleau
|
|
!
|
|
! Last modified : 6 Aug 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,THREE,FOUR,SIX, &
|
|
HALF
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL (WP) :: P,A(10)
|
|
!
|
|
INTEGER :: N
|
|
INTEGER :: J
|
|
!
|
|
! Initialization
|
|
!
|
|
DO J=1,10 !
|
|
A(J)=ZERO !
|
|
END DO !
|
|
!
|
|
IF(N == 2) THEN !
|
|
!
|
|
!.......... 2-point Lagrange interpolation ............
|
|
!
|
|
A(1)=ONE-P !
|
|
A(2)=P !
|
|
!
|
|
ELSE IF(N == 3) THEN !
|
|
!
|
|
!.......... 3-point Lagrange interpolation ............
|
|
!
|
|
A(1)=HALF*P*(P-ONE) !
|
|
A(2)=ONE-P*P !
|
|
A(3)=HALF*P*(P+ONE) !
|
|
!
|
|
ELSE IF(N == 4) THEN !
|
|
!
|
|
!.......... 4-point Lagrange interpolation ............
|
|
!
|
|
A(1)=-P*(P-ONE)*(P-TWO)/SIX !
|
|
A(2)=(P*P-ONE)*(P-TWO)/TWO !
|
|
A(3)=-P*(P+ONE)*(P-TWO)/TWO !
|
|
A(4)=P*(P*P-ONE)/SIX !
|
|
!
|
|
ELSE IF(N == 5) THEN !
|
|
!
|
|
!.......... 5-point Lagrange interpolation ............
|
|
!
|
|
A(1)=(P*P-ONE)*P*(P-TWO)/24.0E0_WP !
|
|
A(2)=-(P-ONE)*P*(P*P-FOUR)/SIX !
|
|
A(3)=(P*P-ONE)*(P*P-FOUR)/FOUR !
|
|
A(4)=-(P+ONE)*P*(P*P-FOUR)/SIX !
|
|
A(5)=(P*P-ONE)*P*(P+TWO)/24.0E0_WP !
|
|
!
|
|
ELSE IF(N == 6) THEN !
|
|
!
|
|
!.......... 6-point Lagrange interpolation ............
|
|
!
|
|
A(1)=-P*(P*P-ONE)*(P-TWO)*(P-THREE)/120.0E0_WP !
|
|
A(2)=P*(P-ONE)*(P*P-FOUR)*(P-THREE)/24.0E0_WP !
|
|
A(3)=-(P*P-ONE)*(P*P-FOUR)*(P-THREE)/12.0E0_WP !
|
|
A(4)=P*(P+ONE)*(P*P-FOUR)*(P-THREE)/12.0E0_WP !
|
|
A(5)=-P*(P*P-ONE)*(P+TWO)*(P-THREE)/24.0E0_WP !
|
|
A(6)=P*(P*P-ONE)*(P*P-FOUR)/120.0E0_WP !
|
|
!
|
|
END IF !
|
|
!
|
|
END SUBROUTINE LAGR_INTERP
|
|
!
|
|
END MODULE INTEGRATION4
|