epsi
/
MsSpec-DFM
3
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
MsSpec-DFM/New_libraries/DFM_library/UTILITIES_LIBRARY/integration4.f90

873 lines
41 KiB
Fortran
Raw Normal View History

initial commit
2022-02-02 16:19:10 +01:00
!
!=======================================================================
!
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