diff options
| author | Wojtek Kosior <kwojtus@protonmail.com> | 2019-06-21 16:34:40 +0200 |
|---|---|---|
| committer | Wojtek Kosior <kwojtus@protonmail.com> | 2019-06-21 16:34:40 +0200 |
| commit | 8311ea87b4e743c0788dadc582912cd08028c101 (patch) | |
| tree | 6103c8988dada0a5e76e7491b6a746f183710329 /src | |
| parent | 9ca933fd7b44d8913d13a94b54dd7fd1635a717a (diff) | |
| download | fortran-assignment3-8311ea87b4e743c0788dadc582912cd08028c101.tar.gz fortran-assignment3-8311ea87b4e743c0788dadc582912cd08028c101.zip | |
change functions order in code to one better IMO
Diffstat (limited to 'src')
| -rw-r--r-- | src/quadratures.f90 | 106 |
1 files changed, 53 insertions, 53 deletions
diff --git a/src/quadratures.f90 b/src/quadratures.f90 index cc279ed..a595ce3 100644 --- a/src/quadratures.f90 +++ b/src/quadratures.f90 @@ -39,59 +39,6 @@ MODULE quadratures CONTAINS - FUNCTION newton_cotes(ibeg, iend, fun, p) result(val) - IMPLICIT none - real(kind=8), intent(in) :: ibeg - real(kind=8), intent(in) :: iend - procedure(funint) :: fun - integer(kind=4), intent(in) :: p - real(kind=8) :: val - - procedure(quadrature), pointer :: quad - - SELECT CASE (p) - CASE (:-1) - STOP "negative interpolationg polynomial order passed" - CASE (0) - quad => rectangle - CASE (1) - quad => trapeze - CASE (2) - quad => simpson_1_third - CASE default - STOP "Newton-Cotes quadratures only implemented for order < 3" - END SELECT - - val = integrate_generic(ibeg, iend, fun, quad) - END FUNCTION newton_cotes - - FUNCTION gauss(ibeg, iend, fun, p) result(val) - IMPLICIT none - real(kind=8), intent(in) :: ibeg - real(kind=8), intent(in) :: iend - procedure(funint) :: fun - integer(kind=4), intent(in) :: p - real(kind=8) :: val - - procedure(quadrature), pointer :: quad - - SELECT CASE (p) - CASE (:0) - STOP "non-positive Legendre polynomial order passed" - CASE (1) - quad => gauss_n1 - CASE (2) - quad => gauss_n2 - CASE (3) - quad => gauss_n3 - CASE default - STOP "Gauss quadratures only implemented with roots of" & - // " Legendgre polynomial of order <= 3" - END SELECT - - val = integrate_generic(ibeg, iend, fun, quad) - END FUNCTION gauss - FUNCTION integrate_generic(ibeg, iend, fun, quad) result(val) IMPLICIT none real(kind=8), intent(in) :: ibeg @@ -139,6 +86,32 @@ CONTAINS END FUNCTION integrate_generic + FUNCTION newton_cotes(ibeg, iend, fun, p) result(val) + IMPLICIT none + real(kind=8), intent(in) :: ibeg + real(kind=8), intent(in) :: iend + procedure(funint) :: fun + integer(kind=4), intent(in) :: p + real(kind=8) :: val + + procedure(quadrature), pointer :: quad + + SELECT CASE (p) + CASE (:-1) + STOP "negative interpolationg polynomial order passed" + CASE (0) + quad => rectangle + CASE (1) + quad => trapeze + CASE (2) + quad => simpson_1_third + CASE default + STOP "Newton-Cotes quadratures only implemented for order < 3" + END SELECT + + val = integrate_generic(ibeg, iend, fun, quad) + END FUNCTION newton_cotes + FUNCTION rectangle(qbeg, qend, fun) result(val) IMPLICIT none real(kind=8), intent(in) :: qbeg, qend @@ -167,6 +140,33 @@ CONTAINS (fun(qbeg) + 4 * fun ((qbeg + qend) * 0.5) + fun(qend)) END FUNCTION simpson_1_third + FUNCTION gauss(ibeg, iend, fun, p) result(val) + IMPLICIT none + real(kind=8), intent(in) :: ibeg + real(kind=8), intent(in) :: iend + procedure(funint) :: fun + integer(kind=4), intent(in) :: p + real(kind=8) :: val + + procedure(quadrature), pointer :: quad + + SELECT CASE (p) + CASE (:0) + STOP "non-positive Legendre polynomial order passed" + CASE (1) + quad => gauss_n1 + CASE (2) + quad => gauss_n2 + CASE (3) + quad => gauss_n3 + CASE default + STOP "Gauss quadratures only implemented with roots of" & + // " Legendgre polynomial of order <= 3" + END SELECT + + val = integrate_generic(ibeg, iend, fun, quad) + END FUNCTION gauss + FUNCTION gauss_generic(mid, halfwidth, fun, points, weights) & result(val) IMPLICIT none |