! !======================================================================= ! MODULE INTEGRATION3 ! ! This module contains integration routines in order to integrate ! a function F over the interval [0,+INF] when f(x) has ! an oscillatory behaviour. ! ! These routines are: ! ! * double exponential transformation : INTDEO(F,A,OMEGA,EPS,I,ERR) <-- standard version ! INTDEO_1(F,AA,A,OMEGA,EPS,I,ERR) <-- 1-parameter version (AA) ! INTDEO_2(F,AA,LL,A,OMEGA,EPS,I,ERR) <-- 2-parameter version (AA,LL) ! INTDEO_F(F,A,OMEGA,AW,I,ERR) <-- fast version ^ ! | USE ACCURACY_REAL ! ! integer CONTAINS ! !======================================================================= ! SUBROUTINE INTDEO(F,A,OMEGA,EPS,I,ERR) ! ! This subroutine is the integrator of f(x) over (a,infinity) when ! f(x) has an oscillatory behaviour: ! ! f(x) = g(x) * sin(omega * x + theta) as x -> infinity ! ! ! Input parameters: ! ! * F : integrand f(x) ! * A : lower limit of integration ! * OMEGA : frequency of oscillation ! * EPS : relative error requested ! ! ! Output variables: ! ! * I : approximation to the integral ! * ERR : estimate of the absolute error ! ! Remarks: ! function ! f(x) needs to be analytic over (a,infinity). ! relative error ! EPS is relative error requested excluding ! cancellation of significant digits. ! i.e. EPS means : (absolute error) / ! (integral_a^R |f(x)| dx). ! EPS does not mean : (absolute error) / I. ! error message ! ERR >= 0 : normal termination. ! ERR < 0 : abnormal termination (m >= MMAX). ! i.e. convergent error is detected : ! 1. f(x) or (d/dx)^n f(x) has ! discontinuous points or sharp ! peaks over (a,infinity). ! you must divide the interval ! (a,infinity) at this points. ! 2. relative error of f(x) is ! greater than EPS. ! ! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). ! You may use, copy, modify this code for any purpose and ! without fee. You may distribute this ORIGINAL package. ! ! ! Modified: D. Sébilleau 5 Aug 2020 ! ! USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF ! IMPLICIT NONE ! REAL (WP) :: A,OMEGA,EPS,I,ERR REAL (WP) :: EFS,ENOFF,PQOFF,PPOFF REAL (WP) :: PI4,EPSLN,EPSH,FRQ4,PER2,PP,PQ,EHP,EHM,IR,H REAL (WP) :: IBACK,IRBACK,T,EP,EM,TK,XW,WG,XA,FP,FM,ERRH REAL (WP) :: TN,ERRD ! REAL (WP), EXTERNAL :: F ! REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DABS ! INTEGER :: MMAX,LMAX INTEGER :: N,M,L,K ! INTEGER :: INT ! ! ---- adjustable parameter ---- ! MMAX = 256 ! LMAX = 5 ! EFS = 0.1E0_WP ! ENOFF = 0.40E0_WP ! PQOFF = 2.9E0_WP ! PPOFF = -0.72E0_WP ! ! ! ------------------------------ ! PI4 = DATAN(ONE) ! EPSLN = ONE - DLOG(EFS*EPS) ! EPSH = DSQRT(EFS*EPS) ! N = INT(ENOFF*EPSLN) ! FRQ4 = DABS(OMEGA) / (TWO*PI4) ! PER2 = FOUR * PI4 / DABS(OMEGA) ! PQ = PQOFF / EPSLN ! PP = PPOFF - DLOG(PQ*PQ*FRQ4) ! EHP = DEXP(TWO*PQ) ! EHM = ONE / EHP ! XW = DEXP(PP-TWO*PI4) ! I = F(A + DSQRT(XW * (PER2*HALF))) ! IR = I*XW ! I = I*(PER2*HALF) ! ERR = DABS(I) ! H = 2 ! M = 1 ! ! 10 CONTINUE ! ! IBACK = I ! IRBACK = IR ! T = H * HALF ! ! 20 CONTINUE ! ! EM = DEXP(TWO*PQ*T) ! EP = PI4 * EM ! EM = PI4 / EM ! TK = T ! ! 30 CONTINUE ! ! XW = DEXP(PP-EP-EM) ! WG = DSQRT(FRQ4*XW + TK*TK) ! XA = XW / (TK+WG) ! WG = (PQ*XW*(EP-EM)+XA) / WG ! FM = F(A + XA) ! FP = F(A + XA + PER2*TK) ! IR = IR + (FP + FM)*XW ! FM = FM * WG ! FP = FP * (PER2-WG) ! I = I + (FP+FM) ! ! IF (M == 1) ERR = ERR + (DABS(FP) + DABS(FM)) ! EP = EP * EHP ! EM = EM * EHM ! TK = TK + ONE ! ! IF (EP < EPSLN) GO TO 30 ! ! IF (M == 1) THEN ! ERRH = ERR * EPSH ! ERR = ERR * EPS ! END IF ! ! TN = TK ! ! DO WHILE(DABS(FM) > ERR) ! XW = DEXP(PP-EP-EM) ! XA = XW / TK * HALF ! WG = XA * (ONE / TK + TWO*PQ*(EP - EM)) ! FM = F(A + XA) ! IR = IR + FM*XW ! FM = FM * WG ! I = I + FM ! EP = EP * EHP ! EM = EM * EHM ! TK = TK + ONE ! END DO ! ! FM = F(A + PER2*TN) ! EM = PER2 * FM ! I = I + EM ! ! IF(DABS(FP) > ERR .OR. DABS(EM) > ERR) THEN ! L = 0 ! 40 CONTINUE ! L = L + 1 ! TN = TN + N ! EM = FM ! FM = F(A + PER2*TN) ! XA = FM ! EP = FM ! EM = EM + FM ! XW = ONE ! WG = ONE ! DO K = 1, N-1 ! XW = XW * (N+1-K) / K ! WG = WG + XW ! FP = F(A + PER2*(TN-K)) ! XA = XA + FP ! EP = EP + FP*WG ! EM = EM + FP*XW ! END DO ! WG = PER2 * N / (WG*N + XW) ! EM = WG * DABS(EM) ! IF(EM <= ERR .OR. L >= LMAX) GO TO 50 ! I = I + PER2*XA ! GO TO 40 ! 50 CONTINUE ! I = I + WG*EP ! IF(EM > ERR) ERR = EM ! END IF ! ! T = T + H ! ! IF(T < ONE) GO TO 20 ! ! IF(M == 1) THEN ! ERRD = ONE + TWO*ERRH ! ELSE ! ERRD = H*(DABS(I-TWO*IBACK) + PQ*DABS(IR-TWO*IRBACK)) ! END IF ! ! H = H * HALF ! M = M * 2 ! ! IF(ERRD > ERRH .AND. M < MMAX) GO TO 10 ! ! I = I*H ! ! IF(ERRD > ERRH) THEN ! ERR = -ERRD ! ELSE ! ERR = ERR * (M*HALF) ! END IF ! ! END SUBROUTINE INTDEO ! !======================================================================= ! SUBROUTINE INTDEO_1(F,G,AA,A,OMEGA,EPS,I,ERR) ! ! This subroutine is the integrator of g(x) over (a,infinity) when ! g(x) has an oscillatory behaviour: ! ! g(x) = f(x) * sin(omega * x + theta) * x, as x -> infinity ! ! ! This version: f(x) has ONE extra parameters: AA (real) ! ! so that f(x) = g(a*x) ! ! ! Input parameters: ! ! * F : integrand f(x) ! * AA : parameter used in function f ! * A : lower limit of integration ! * OMEGA : frequency of oscillation ! * EPS : relative error requested ! ! ! Intermediate parameters: ! ! * G : function g(a,x) to be integrated ! ! ! Output variables: ! ! * I : approximation to the integral ! * ERR : estimate of the absolute error ! ! Remarks: ! function ! f(x) needs to be analytic over (a,infinity). ! relative error ! EPS is relative error requested excluding ! cancellation of significant digits. ! i.e. EPS means : (absolute error) / ! (integral_a^R |f(x)| dx). ! EPS does not mean : (absolute error) / I. ! error message ! ERR >= 0 : normal termination. ! ERR < 0 : abnormal termination (m >= MMAX). ! i.e. convergent error is detected : ! 1. f(x) or (d/dx)^n f(x) has ! discontinuous points or sharp ! peaks over (a,infinity). ! you must divide the interval ! (a,infinity) at this points. ! 2. relative error of f(x) is ! greater than EPS. ! ! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). ! You may use, copy, modify this code for any purpose and ! without fee. You may distribute this ORIGINAL package. ! ! ! Modified: D. Sébilleau 5 Aug 2020 ! ! ! --> f(x) changed into g(f,a,omega,x) ! where G(f,a,omega,x) = f(a,x) * sin(omega*x) * x ! ! USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF ! IMPLICIT NONE ! REAL (WP) :: A,AA,OMEGA,EPS,I,ERR REAL (WP) :: EFS,ENOFF,PQOFF,PPOFF REAL (WP) :: PI4,EPSLN,EPSH,FRQ4,PER2,PP,PQ,EHP,EHM,IR,H REAL (WP) :: IBACK,IRBACK,T,EP,EM,TK,XW,WG,XA,FP,FM,ERRH REAL (WP) :: TN,ERRD ! REAL (WP), EXTERNAL :: F,G ! REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DABS ! INTEGER :: MMAX,LMAX INTEGER :: N,M,L,K ! INTEGER :: INT ! ! ---- adjustable parameter ---- ! MMAX = 256 ! LMAX = 5 ! EFS = 0.1E0_WP ! ENOFF = 0.40E0_WP ! PQOFF = 2.9E0_WP ! PPOFF = -0.72E0_WP ! ! ! ------------------------------ ! PI4 = DATAN(ONE) ! EPSLN = ONE - DLOG(EFS*EPS) ! EPSH = DSQRT(EFS*EPS) ! N = INT(ENOFF*EPSLN) ! FRQ4 = DABS(OMEGA) / (TWO*PI4) ! PER2 = FOUR * PI4 / DABS(OMEGA) ! PQ = PQOFF / EPSLN ! PP = PPOFF - DLOG(PQ*PQ*FRQ4) ! EHP = DEXP(TWO*PQ) ! EHM = ONE / EHP ! XW = DEXP(PP-TWO*PI4) ! I = G(F,AA,OMEGA,A + DSQRT(XW * (PER2*HALF))) ! IR = I*XW ! I = I*(PER2*HALF) ! ERR = DABS(I) ! H = 2 ! M = 1 ! ! 10 CONTINUE ! ! IBACK = I ! IRBACK = IR ! T = H * HALF ! ! 20 CONTINUE ! ! EM = DEXP(TWO*PQ*T) ! EP = PI4 * EM ! EM = PI4 / EM ! TK = T ! ! 30 CONTINUE ! ! XW = DEXP(PP-EP-EM) ! WG = DSQRT(FRQ4*XW + TK*TK) ! XA = XW / (TK+WG) ! WG = (PQ*XW*(EP-EM)+XA) / WG ! FM = G(F,AA,OMEGA,A + XA) ! FP = G(F,AA,OMEGA,A + XA + PER2*TK) ! IR = IR + (FP + FM)*XW ! FM = FM * WG ! FP = FP * (PER2-WG) ! I = I + (FP+FM) ! ! IF (M == 1) ERR = ERR + (DABS(FP) + DABS(FM)) ! EP = EP * EHP ! EM = EM * EHM ! TK = TK + ONE ! ! IF (EP < EPSLN) GO TO 30 ! ! IF (M == 1) THEN ! ERRH = ERR * EPSH ! ERR = ERR * EPS ! END IF ! ! TN = TK ! ! DO WHILE(DABS(FM) > ERR) ! XW = DEXP(PP-EP-EM) ! XA = XW / TK * HALF ! WG = XA * (ONE / TK + TWO*PQ*(EP - EM)) ! FM = G(F,AA,OMEGA,A + XA) ! IR = IR + FM*XW ! FM = FM * WG ! I = I + FM ! EP = EP * EHP ! EM = EM * EHM ! TK = TK + ONE ! END DO ! ! FM = G(F,AA,OMEGA,A + PER2*TN) ! EM = PER2 * FM ! I = I + EM ! ! IF(DABS(FP) > ERR .OR. DABS(EM) > ERR) THEN ! L = 0 ! 40 CONTINUE ! L = L + 1 ! TN = TN + N ! EM = FM ! FM = G(F,AA,OMEGA,A + PER2*TN) ! XA = FM ! EP = FM ! EM = EM + FM ! XW = ONE ! WG = ONE ! DO K = 1, N-1 ! XW = XW * (N+1-K) / K ! WG = WG + XW ! FP = F(A + PER2*(TN-K)) ! XA = XA + FP ! EP = EP + FP*WG ! EM = EM + FP*XW ! END DO ! WG = PER2 * N / (WG*N + XW) ! EM = WG * DABS(EM) ! IF(EM <= ERR .OR. L >= LMAX) GO TO 50 ! I = I + PER2*XA ! GO TO 40 ! 50 CONTINUE ! I = I + WG*EP ! IF(EM > ERR) ERR = EM ! END IF ! ! T = T + H ! ! IF(T < ONE) GO TO 20 ! ! IF(M == 1) THEN ! ERRD = ONE + TWO*ERRH ! ELSE ! ERRD = H*(DABS(I-TWO*IBACK) + PQ*DABS(IR-TWO*IRBACK)) ! END IF ! ! H = H * HALF ! M = M * 2 ! ! IF(ERRD > ERRH .AND. M < MMAX) GO TO 10 ! ! I = I*H ! ! IF(ERRD > ERRH) THEN ! ERR = -ERRD ! ELSE ! ERR = ERR * (M*HALF) ! END IF ! ! END SUBROUTINE INTDEO_1 ! !======================================================================= ! SUBROUTINE INTDEO_2(F,G,AA,LL,A,OMEGA,EPS,I,ERR) ! ! This subroutine is the integrator of g(x) over (a,infinity) when ! g(x) has an oscillatory behaviour: ! ! g(x) = f(x) * sin(omega * x + theta), as x -> infinity ! ! ! This version: f(x) has TWO extra parameters: AA (real) ! LL (integer) ! so that f(x) = g_l(a*x) ! ! ! Input parameters: ! ! * F : function f(x) to be Fourier transformed ! * AA : parameter used in function F ! * LL : order of the oscillatory function F ! * A : lower limit of integration ! * OMEGA : frequency of oscillation ! * EPS : relative error requested ! ! ! Intermediate parameters: ! ! * G : function g(x) to be integrated ! ! ! Output variables: ! ! * I : approximation to the integral ! * ERR : estimate of the absolute error ! ! Remarks: ! function ! f(x) needs to be analytic over (a,infinity). ! relative error ! EPS is relative error requested excluding ! cancellation of significant digits. ! i.e. EPS means : (absolute error) / ! (integral_a^R |f(x)| dx). ! EPS does not mean : (absolute error) / I. ! error message ! ERR >= 0 : normal termination. ! ERR < 0 : abnormal termination (m >= MMAX). ! i.e. convergent error is detected : ! 1. f(x) or (d/dx)^n f(x) has ! discontinuous points or sharp ! peaks over (a,infinity). ! you must divide the interval ! (a,infinity) at this points. ! 2. relative error of f(x) is ! greater than EPS. ! ! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). ! You may use, copy, modify this code for any purpose and ! without fee. You may distribute this ORIGINAL package. ! ! ! Modified: D. Sébilleau 5 Aug 2020 ! ! ! --> f(x) changed into g(f,a,l,omega,x) ! where G(f,a,l,omega,x) = f(a,x) * j_l(omega*x) * x^2 ! --> a replaced by AA, as A is used for the lower integration bound ! ! USE REAL_NUMBERS, ONLY : ONE,TWO,FOUR,HALF ! IMPLICIT NONE ! REAL (WP) :: A,AA,OMEGA,EPS,I,ERR REAL (WP) :: EFS,ENOFF,PQOFF,PPOFF REAL (WP) :: PI4,EPSLN,EPSH,FRQ4,PER2,PP,PQ,EHP,EHM,IR,H REAL (WP) :: IBACK,IRBACK,T,EP,EM,TK,XW,WG,XA,FP,FM,ERRH REAL (WP) :: TN,ERRD ! REAL (WP), EXTERNAL :: F,G ! REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DABS ! INTEGER :: MMAX,LMAX INTEGER :: N,M,L,K INTEGER :: LL ! INTEGER :: INT ! ! ---- adjustable parameter ---- ! MMAX = 256 ! LMAX = 5 ! EFS = 0.1E0_WP ! ENOFF = 0.40E0_WP ! PQOFF = 2.9E0_WP ! PPOFF = -0.72E0_WP ! ! ! ------------------------------ ! PI4 = DATAN(ONE) ! EPSLN = ONE - DLOG(EFS*EPS) ! EPSH = DSQRT(EFS*EPS) ! N = INT(ENOFF*EPSLN) ! FRQ4 = DABS(OMEGA) / (TWO*PI4) ! PER2 = FOUR * PI4 / DABS(OMEGA) ! PQ = PQOFF / EPSLN ! PP = PPOFF - DLOG(PQ*PQ*FRQ4) ! EHP = DEXP(TWO*PQ) ! EHM = ONE / EHP ! XW = DEXP(PP-TWO*PI4) ! I = G(F,AA,OMEGA,A + DSQRT(XW * (PER2*HALF))) ! IR = I*XW ! I = I*(PER2*HALF) ! ERR = DABS(I) ! H = 2 ! M = 1 ! ! 10 CONTINUE ! ! IBACK = I ! IRBACK = IR ! T = H * HALF ! ! 20 CONTINUE ! ! EM = DEXP(TWO*PQ*T) ! EP = PI4 * EM ! EM = PI4 / EM ! TK = T ! ! 30 CONTINUE ! ! XW = DEXP(PP-EP-EM) ! WG = DSQRT(FRQ4*XW + TK*TK) ! XA = XW / (TK+WG) ! WG = (PQ*XW*(EP-EM)+XA) / WG ! FM = G(F,AA,LL,OMEGA,A + XA) ! FP = G(F,AA,LL,OMEGA,A + XA + PER2*TK) ! IR = IR + (FP + FM)*XW ! FM = FM * WG ! FP = FP * (PER2-WG) ! I = I + (FP+FM) ! ! IF (M == 1) ERR = ERR + (DABS(FP) + DABS(FM)) ! EP = EP * EHP ! EM = EM * EHM ! TK = TK + ONE ! ! IF (EP < EPSLN) GO TO 30 ! ! IF (M == 1) THEN ! ERRH = ERR * EPSH ! ERR = ERR * EPS ! END IF ! ! TN = TK ! ! DO WHILE(DABS(FM) > ERR) ! XW = DEXP(PP-EP-EM) ! XA = XW / TK * HALF ! WG = XA * (ONE / TK + TWO*PQ*(EP - EM)) ! FM = G(F,AA,LL,OMEGA,A + XA) ! IR = IR + FM*XW ! FM = FM * WG ! I = I + FM ! EP = EP * EHP ! EM = EM * EHM ! TK = TK + ONE ! END DO ! ! FM = G(F,AA,LL,OMEGA,A + PER2*TN) ! EM = PER2 * FM ! I = I + EM ! ! IF(DABS(FP) > ERR .OR. DABS(EM) > ERR) THEN ! L = 0 ! 40 CONTINUE ! L = L + 1 ! TN = TN + N ! EM = FM ! FM = G(F,AA,LL,OMEGA,A + PER2*TN) ! XA = FM ! EP = FM ! EM = EM + FM ! XW = ONE ! WG = ONE ! DO K = 1, N-1 ! XW = XW * (N+1-K) / K ! WG = WG + XW ! FP = F(A + PER2*(TN-K)) ! XA = XA + FP ! EP = EP + FP*WG ! EM = EM + FP*XW ! END DO ! WG = PER2 * N / (WG*N + XW) ! EM = WG * DABS(EM) ! IF(EM <= ERR .OR. L >= LMAX) GO TO 50 ! I = I + PER2*XA ! GO TO 40 ! 50 CONTINUE ! I = I + WG*EP ! IF(EM > ERR) ERR = EM ! END IF ! ! T = T + H ! ! IF(T < ONE) GO TO 20 ! ! IF(M == 1) THEN ! ERRD = ONE + TWO*ERRH ! ELSE ! ERRD = H*(DABS(I-TWO*IBACK) + PQ*DABS(IR-TWO*IRBACK)) ! END IF ! ! H = H * HALF ! M = M * 2 ! ! IF(ERRD > ERRH .AND. M < MMAX) GO TO 10 ! ! I = I*H ! ! IF(ERRD > ERRH) THEN ! ERR = -ERRD ! ELSE ! ERR = ERR * (M*HALF) ! END IF ! ! END SUBROUTINE INTDEO_2 ! !======================================================================= ! SUBROUTINE INTDEO_F(F,A,OMEGA,AW,I,ERR) ! ! This subroutine is the integrator of f(x) over (a,infinity) when ! f(x) has an oscillatory behaviour: ! ! f(x) = g(x) * sin(omega * x + theta) as x -> infinity ! ! ! ! --> <-- ! --> This is the fast version <-- ! --> <-- ! ! ! Usage: ! ! CALL INTDEOINI(LENAW,TINY,EPS,AW) ! initialization of AW ! ... ! CALL INTDEO_F(F,A,AW,I,ERR) ! ! ! Input parameters: ! ! * F : integrand f(x) ! * A : lower limit of integration ! * OMEGA : frequency of oscillation ! * EPS : relative error requested ! ! ! Output variables: ! ! * I : approximation to the integral ! * ERR : estimate of the absolute error ! ! Remarks: ! initial parameters ! LENAW > 1000, ! IEEE double : ! LENAW = 8000 ! TINY = 1.0D-307 ! function ! f(x) needs to be analytic over (a,infinity). ! relative error ! EPS is relative error requested excluding ! cancellation of significant digits. ! i.e. EPS means : (absolute error) / ! (integral_a^R |f(x)| dx). ! EPS does not mean : (absolute error) / I. ! error message ! ERR >= 0 : normal termination. ! ERR < 0 : abnormal termination (m >= MMAX). ! i.e. convergent error is detected : ! 1. f(x) or (d/dx)^n f(x) has ! discontinuous points or sharp ! peaks over (a,infinity). ! you must divide the interval ! (a,infinity) at this points. ! 2. relative error of f(x) is ! greater than EPS. ! ! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). ! You may use, copy, modify this code for any purpose and ! without fee. You may distribute this ORIGINAL package. ! ! ! Modified: D. Sébilleau 5 Aug 2020 ! ! USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF ! IMPLICIT NONE ! REAL (WP) :: A,OMEGA,AW(0 : *),I,ERR REAL (WP) :: EPS,PER,PERW,W02,IR,H,IBACK,IRBACK,T,TK REAL (WP) :: XA,FM,FP,ERRH,S0,S1,S2,ERRD ! REAL (WP), EXTERNAL :: F ! REAL (WP) :: DABS ! INTEGER :: LENAWM,NK0,NOFF0,NK,NOFF,LMAX,M,K,J,JM,L ! INTEGER :: INT ! LENAWM = INT(AW(0) + HALF) ! NK0 = INT(AW(1) + HALF) ! NOFF0 = 6 ! NK = INT(AW(2) + HALF) ! NOFF = 2*NK0 + NOFF0 ! LMAX = INT(AW(3) + HALF) ! EPS = AW(4) ! PER = ONE / DABS(OMEGA) ! W02 = TWO * AW(NOFF+2) ! PERW = PER * W02 ! I = F(A + AW(NOFF)*PER) ! IR = I * AW(NOFF+1) ! I = I * AW(NOFF+2) ! ERR = DABS(I) ! H = TWO ! M = 1 ! K = NOFF ! ! 10 CONTINUE ! ! IBACK = I ! IRBACK = IR ! T = H * HALF ! ! 20 CONTINUE ! ! IF(K == NOFF) THEN ! TK = ONE ! K = K + NK ! J = NOFF ! ! 30 CONTINUE ! ! J = J + 3 ! XA = PER * AW(J) ! FM = F(A + XA) ! FP = F(A + XA + PERW*TK) ! IR = IR + (FM+FP) * AW(J+1) ! FM = FM * AW(J+2) ! FP = FP * (W02-AW(J+2)) ! I = I + (FM+FP) ! ERR = ERR + (DABS(FM)+DABS(FP)) ! TK = TK + ONE ! ! IF(AW(J) > EPS .AND. J < K) GO TO 30 ! ! ERRH = ERR * AW(5) ! ERR = ERR * EPS ! JM = J - NOFF ! ELSE ! TK = T ! DO J = K+3, K+JM, 3 ! XA = PER * AW(J) ! FM = F(A + XA) ! FP = F(A + XA + PERW*TK) ! IR = IR + (FM+FP) * AW(J+1) ! FM = FM * AW(J+2) ! FP = FP * (W02-AW(J+2)) ! I = I + (FM+FP) ! TK = TK + ONE ! END DO ! J = K + JM ! K = K + NK ! END IF ! ! DO WHILE (DABS(FM) > ERR .AND. J < K) ! J = J + 3 ! FM = F(A + PER*AW(J)) ! IR = IR + FM*AW(J+1) ! FM = FM * AW(J+2) ! I = I + FM ! END DO ! ! FM = F(A + PERW*TK) ! S2 = W02 * FM ! I = I + S2 ! ! IF(DABS(FP) > ERR .OR. DABS(S2) > ERR) THEN ! L = 0 ! ! 40 CONTINUE ! ! L = L + 1 ! S0 = ZERO ! S1 = ZERO ! S2 = FM * AW(NOFF0+1) ! ! DO J = NOFF0+2, NOFF-2, 2 ! TK = TK + ONE ! FM = F(A + PERW*TK) ! S0 = S0 + FM ! S1 = S1 + FM*AW(J) ! S2 = S2 + FM*AW(J+1) ! END DO ! IF(S2 <= ERR .OR. L >= LMAX) GO TO 50 ! ! I = I + W02*S0 ! GO TO 40 ! ! 50 CONTINUE ! ! I = I + S1 ! ! IF(S2 > ERR) ERR = S2 ! ! END IF ! ! T = T + H ! ! IF(T < ONE) GO TO 20 ! ! IF(M == 1) THEN ! ERRD = ONE + TWO*ERRH ! ELSE ! ERRD = H * (DABS(I-2*IBACK) + DABS(IR- 2*IRBACK)) ! END IF ! ! H = H * HALF ! M = M * 2 ! ! IF(ERRD > ERRH .AND. (2*K - NOFF) <= LENAWM) GO TO 10 ! ! I = I * (H*PER) ! ! IF(ERRD > ERRH) THEN ! ERR = -ERRD*PER ! ELSE ! ERR = ERR * (PER*M*HALF) ! END IF ! ! END SUBROUTINE INTDEO_F ! !======================================================================= ! SUBROUTINE INTDEOINI_F(LENAW,TINY,EPS,AW) ! ! This subroutine calculates the points and weights of the quadrature ! formula ! ! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). ! You may use, copy, modify this code for any purpose and ! without fee. You may distribute this ORIGINAL package. ! ! ! Modified: D. Sébilleau 5 Aug 2020 ! ! USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FOUR,HALF ! IMPLICIT NONE ! REAL (WP) :: TINY,EPS,AW(0 : LENAW - 1) REAL (WP) :: EFS,ENOFF,PQOFF,PPOFF REAL (WP) :: PI4,TINYLN,EPSLN,FRQ4,PER2,PP,PQ,EHP,EHM,H REAL (WP) :: T,EP,EM,TK,XW,WG,XA ! REAL (WP) :: DATAN,DLOG,DSQRT,DEXP,DFLOAT ! INTEGER :: NOFF0,NK0,NOFF,K,NK,J INTEGER :: LENAW INTEGER :: LMAX ! INTEGER :: INT ! ! ---- adjustable parameter ---- ! LMAX = 5 ! EFS = 0.1E0_WP ! ENOFF = 0.40E0_WP ! PQOFF = 2.9E0_WP ! PPOFF = -0.72E0_WP ! ! ! ------------------------------ ! PI4 = DATAN(ONE) ! TINYLN = -DLOG(TINY) ! EPSLN = ONE - DLOG(EFS*EPS) ! FRQ4 = ONE / (TWO*PI4) ! PER2 = FOUR * PI4 ! PQ = PQOFF / EPSLN ! PP = PPOFF - DLOG(PQ*PQ*FRQ4) ! EHP = DEXP(TWO*PQ) ! EHM = ONE / EHP ! AW(3) = DFLOAT(LMAX) ! AW(4) = EPS ! AW(5) = DSQRT(EFS*EPS) ! NOFF0 = 6 ! NK0 = 1 + INT(ENOFF*EPSLN) ! AW(1) = NK0 ! NOFF = 2*NK0 + NOFF0 ! WG = ZERO ! XW = ONE ! ! DO K = 1, NK0 ! WG = WG + XW ! AW(NOFF - 2*K) = WG ! AW(NOFF - 2*K + 1) = XW ! XW = XW * (NK0-K) / K ! END DO ! ! WG = PER2 / WG ! ! DO K = NOFF0, NOFF-2, 2 ! AW(K) = AW(K)*WG ! AW(K+1) = AW(K+1)*WG ! END DO ! ! XW = DEXP(PP - TWO*PI4) ! AW(NOFF) = DSQRT(XW * (PER2*HALF)) ! AW(NOFF+1) = XW * PQ ! AW(NOFF+2) = PER2 * HALF ! H = TWO ! NK = 0 ! K = NOFF + 3 ! ! 10 CONTINUE ! ! T = H * HALF ! ! 20 CONTINUE ! ! EM = DEXP(2*PQ*T) ! EP = PI4 * EM ! EM = PI4 / EM ! TK = T ! J = K ! ! 30 CONTINUE ! ! XW = DEXP(PP - EP - EM) ! WG = DSQRT(FRQ4*XW + TK*TK) ! XA = XW / (TK + WG) ! WG = (PQ*XW*(EP-EM) + XA) / WG ! AW(J) = XA ! AW(J+1) = XW * PQ ! AW(J+2) = WG ! EP = EP * EHP ! EM = EM * EHM ! TK = TK + ONE ! J = J + 3 ! ! IF(EP < TINYLN .AND. J <= (LENAW-3)) GO TO 30 ! ! T = T + H ! K = K + NK ! ! IF(T < ONE) GO TO 20 ! ! H = H * HALF ! ! IF(NK == 0) THEN ! IF(J > (LENAW-6)) J = J - 3 ! NK = J - NOFF ! K = K + NK ! AW(2) = NK ! END IF ! ! IF ((2*K - NOFF - 3) <= LENAW) GO TO 10 ! ! AW(0) = DFLOAT(K-3) ! ! END SUBROUTINE INTDEOINI_F ! END MODULE INTEGRATION3