├── .gitignore ├── img ├── shear-1.png ├── shear-2.png └── shear-3.png ├── src ├── ppr_1d.F90 ├── pcm.f90 ├── root1d.f90 ├── util1d.f90 ├── rcon1d.f90 ├── p1e.f90 ├── bfun1d.f90 ├── p3e.f90 ├── oscl1d.f90 ├── p5e.f90 ├── ffsl1d.f90 ├── ppr_1d.f90 ├── ppm.f90 ├── weno1d.f90 ├── plm.f90 ├── rmap1d.f90 └── pqm.f90 ├── .travis.yml ├── LICENSE.md ├── README.md └── example ├── ex_1.F90 ├── ex_1.f90 ├── ex_7.f90 ├── ex_4.f90 ├── ex_2.f90 ├── ex_3.f90 ├── ex_5.f90 └── ex_6.f90 /.gitignore: -------------------------------------------------------------------------------- 1 | # fortran binaries 2 | * 3 | !/**/ 4 | !*.* 5 | *.mod 6 | 7 | -------------------------------------------------------------------------------- /img/shear-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dengwirda/PPR/HEAD/img/shear-1.png -------------------------------------------------------------------------------- /img/shear-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dengwirda/PPR/HEAD/img/shear-2.png -------------------------------------------------------------------------------- /img/shear-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dengwirda/PPR/HEAD/img/shear-3.png -------------------------------------------------------------------------------- /src/ppr_1d.F90: -------------------------------------------------------------------------------- 1 | 2 | !-- an alternative to buidling w the -cpp compile flag 3 | 4 | # include "ppr_1d.f90" 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: fortran 2 | matrix: 3 | include: 4 | - os: linux 5 | addons: 6 | apt: 7 | sources: 8 | - ubuntu-toolchain-r-test 9 | packages: 10 | - gcc-8 11 | - gfortran-8 12 | script: 13 | - export FC=gfortran-8 14 | - $FC --version 15 | - cd example 16 | - $FC -pedantic -cpp -O3 -flto ex_1.f90 -o ex_1 17 | - ./ex_1 18 | - $FC -pedantic -O3 -flto ex_1.F90 -o ex_1 19 | - ./ex_1 20 | - $FC -pedantic -cpp -O3 -flto ex_2.f90 -o ex_2 21 | - ./ex_2 22 | - $FC -pedantic -cpp -O3 -flto ex_3.f90 -o ex_3 23 | - ./ex_3 24 | - $FC -pedantic -cpp -O3 -flto ex_4.f90 -o ex_4 25 | - ./ex_4 26 | - $FC -pedantic -cpp -O3 -flto ex_5.f90 -o ex_5 27 | - ./ex_5 28 | - $FC -pedantic -cpp -O3 -flto ex_6.f90 -o ex_6 29 | - ./ex_6 30 | - $FC -pedantic -cpp -O3 -flto ex_7.f90 -o ex_7 31 | - ./ex_7 32 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | 2 | `PPR` is licensed under the following terms: 3 | 4 | This program may be freely redistributed under the condition that the copyright notices (including this entire header) are not removed, and no compensation is received through use of the software. Private, research, and institutional use is free. You may distribute modified versions of this code `UNDER THE CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR NOTICE IS GIVEN OF THE MODIFICATIONS`. Distribution of this code as part of a commercial system is permissible `ONLY BY DIRECT ARRANGEMENT WITH THE AUTHOR`. (If you are not directly supplying this code to a customer, and you are instead telling them how they can obtain it for free, then you are not required to make any arrangement with me.) 5 | 6 | `DISCLAIMER`: Neither I nor: Columbia University, the National Aeronautics and Space Administration, nor the Massachusetts Institute of Technology warrant or certify this code in any way whatsoever. This code is provided "as-is" to be used at your own risk. 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /src/pcm.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! PCM.f90: 1d piecewise constant reconstruction . 31 | ! 32 | ! Darren Engwirda 33 | ! 08-Sep-2016 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | pure subroutine pcm(npos,nvar,ndof,fdat, & 39 | & fhat) 40 | 41 | ! 42 | ! NPOS no. edges over grid. 43 | ! NVAR no. state variables. 44 | ! NDOF no. degrees-of-freedom per grid-cell . 45 | ! FDAT grid-cell moments array. FDAT is an array with 46 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 47 | ! FHAT grid-cell re-con. array. FHAT is an array with 48 | ! SIZE = MDOF-by-NVAR-by-NPOS-1 . 49 | ! 50 | 51 | implicit none 52 | 53 | !------------------------------------------- arguments ! 54 | integer , intent(in) :: npos,nvar,ndof 55 | real(kind=dp), intent(out) :: fhat(:,:,:) 56 | real(kind=dp), intent(in) :: fdat(:,:,:) 57 | 58 | !------------------------------------------- variables ! 59 | integer :: ipos,ivar,idof 60 | 61 | do ipos = +1, npos - 1 62 | do ivar = +1, nvar + 0 63 | do idof = +1, ndof + 0 64 | 65 | fhat(idof,ivar,ipos) = fdat(idof,ivar,ipos) 66 | 67 | end do 68 | end do 69 | end do 70 | 71 | return 72 | 73 | end subroutine 74 | 75 | 76 | 77 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | ## `PPR: Piecewise Polynomial Reconstruction` 3 | 4 |

5 |     6 |     7 | 8 |

9 | 10 | The `PPR` package is a `Fortran-90` library designed to compute high-order piecewise polynomial reconstructions and conservative integral re-mappings on structured grids. These operators can be used to build high-order finite-volume / arbitrary lagrangian-eulerian `ALE` schemes for the solution of hyperbolic transport problems. 11 | 12 | Various conservative polynomial reconstructions are supported, including piecewise constant `PCM`, linear `PLM`, parabolic `PPM` and quartic `PQM` types. Each interpolant can be combined with a selection of slope-limiters, including exact monotonicity-preserving and weighted essential non-oscillatory `WENO`-like formulations. Support is provided for both uniform and non-uniform structured grid types. 13 | 14 | ## `Getting Started` 15 | 16 | The `PPR` package is encapsulated in a single module: `ppr_1d` --- defining interfaces to the main reconstruction and re-mapping routines `rcon1d` and `rmap1d`. To call `PPR`, simply `#include ../src/ppr_1d.f90` and compile with the `-cpp` flag. 17 | 18 | See the example programs for additional detail. 19 | 20 | ## `Example cases` 21 | 22 | A set of simple example programs are provided in the `../example` directory. See the various inline comments for a detailed description of `PPR` functionality, data-structures, etc. 23 | ```` 24 | ex_1.f90 ! a simple, analytical unit test 25 | ex_2.f90 ! impose monotone slope limiting 26 | ex_3.f90 ! a smooth profile used for convergence tests 27 | ex_4.f90 ! multi-tracer re-mapping 28 | ex_5.f90 ! building high-order interpolants 29 | ex_6.f90 ! flux-form semi-lagrangian transport (in 1d) 30 | ex_7.f90 ! as per ex-1, but with negative orientations 31 | ```` 32 | 33 | ## `License` 34 | 35 | This program may be freely redistributed under the condition that the copyright notices (including this entire header) are not removed, and no compensation is received through use of the software. Private, research, and institutional use is free. You may distribute modified versions of this code `UNDER THE CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR NOTICE IS GIVEN OF THE MODIFICATIONS`. Distribution of this code as part of a commercial system is permissible `ONLY BY DIRECT ARRANGEMENT WITH THE AUTHOR`. (If you are not directly supplying this code to a customer, and you are instead telling them how they can obtain it for free, then you are not required to make any arrangement with me.) 36 | 37 | `DISCLAIMER`: Neither I nor: Columbia University, the National Aeronautics and Space Administration, nor the Massachusetts Institute of Technology warrant or certify this code in any way whatsoever. This code is provided "as-is" to be used at your own risk. 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /src/root1d.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! ROOT1D.f90: find the "roots" of degree-k polynomials. 31 | ! 32 | ! Darren Engwirda 33 | ! 25-Mar-2019 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | pure subroutine roots_2(aa,bb,cc,xx,haveroot) 39 | 40 | ! 41 | ! solve:: aa * xx**2 + bb * xx**1 + cc = +0.0 . 42 | ! 43 | 44 | implicit none 45 | 46 | !------------------------------------------- arguments ! 47 | real(kind=dp), intent(in) :: aa,bb,cc 48 | real(kind=dp), intent(out) :: xx(1:2) 49 | logical , intent(out) :: haveroot 50 | 51 | !------------------------------------------- variables ! 52 | real(kind=dp) :: sq,ia,a0,b0,c0,x0 53 | 54 | real(kind=dp), parameter :: rt = +1.d-14 55 | 56 | a0 = abs(aa) 57 | b0 = abs(bb) 58 | c0 = abs(cc) 59 | 60 | sq = bb * bb - 4.0d+0 * aa * cc 61 | 62 | if (sq .ge. 0.0d+0) then 63 | 64 | sq = sqrt (sq) 65 | 66 | xx(1) = - bb + sq 67 | xx(2) = - bb - sq 68 | 69 | x0 = max(abs(xx(1)), & 70 | & abs(xx(2))) 71 | 72 | if (a0 .gt. (rt*x0)) then 73 | 74 | !-------------------------------------- degree-2 roots ! 75 | 76 | haveroot = .true. 77 | 78 | ia = 0.5d+0 / aa 79 | 80 | xx(1) = xx(1) * ia 81 | xx(2) = xx(2) * ia 82 | 83 | else & 84 | & if (b0 .gt. (rt*c0)) then 85 | 86 | !-------------------------------------- degree-1 roots ! 87 | 88 | haveroot = .true. 89 | 90 | xx(1) = - cc / bb 91 | xx(2) = - cc / bb 92 | 93 | else 94 | 95 | haveroot = .false. 96 | 97 | end if 98 | 99 | else 100 | 101 | haveroot = .false. 102 | 103 | end if 104 | 105 | return 106 | 107 | end subroutine 108 | 109 | 110 | 111 | -------------------------------------------------------------------------------- /example/ex_1.F90: -------------------------------------------------------------------------------- 1 | 2 | ! gfortran -pedantic -O3 -flto ex_1.F90 -o ex_1 3 | ! ./ex_1 4 | 5 | ! Same as ex_1.f90, but with a capitalised *.F90 to enable 6 | ! the preprocessor directives without the -cpp flag. 7 | ! 8 | 9 | ! note: *.F90! 10 | # include "../src/ppr_1d.F90" 11 | 12 | program ex 13 | 14 | use ppr_1d 15 | 16 | implicit none 17 | 18 | integer, parameter :: npos = 31 ! no. edge (old grid) 19 | integer, parameter :: ntmp = 23 ! no. edge (new grid) 20 | integer, parameter :: nvar = 1 ! no. variables to remap 21 | integer, parameter :: ndof = 1 ! no. FV DoF per cell 22 | integer :: ipos 23 | 24 | !------------------------------ position of cell edges ! 25 | real(kind=dp) :: xpos(npos),xtmp(ntmp) 26 | real(kind=dp) :: xmid 27 | 28 | !-------------------------------- finite-volume arrays ! 29 | 30 | ! Arrays represent a "block" of finite-volume tracers 31 | ! to remap. The 1st dim. is the no. of DoF per cell, 32 | ! NDOF=1 is a standard finite-volume scheme where the 33 | ! data is specified as cell means. NDOF>1 is reserved 34 | ! for future use with DG-style schemes. NVAR is the 35 | ! number of tracers to remap. Processing tracers in a 36 | ! batch is typically more efficient than one-by-one. 37 | ! The last dim. is the no. cells (layers) in the grid. 38 | 39 | real(kind=dp) :: init(ndof,nvar,npos-1) 40 | real(kind=dp) :: fdat(ndof,nvar,npos-1) 41 | real(kind=dp) :: ftmp(ndof,nvar,ntmp-1) 42 | 43 | !------------------------------ method data-structures ! 44 | type(rmap_work) :: work 45 | type(rmap_opts) :: opts 46 | type(rcon_ends) :: bc_l(nvar) 47 | type(rcon_ends) :: bc_r(nvar) 48 | 49 | !------------------------------ define a simple domain ! 50 | 51 | call linspace(0.d0,1.d0,npos,xpos) 52 | call linspace(0.d0,1.d0,ntmp,xtmp) 53 | 54 | !------------------------------ setup some simple data ! 55 | 56 | do ipos = +1, npos-1 57 | 58 | xmid = xpos(ipos+0) * 0.5d+0 & 59 | & + xpos(ipos+1) * 0.5d+0 60 | 61 | init(1,1,ipos) = xmid ** 2 62 | 63 | end do 64 | 65 | !------------------------------ specify method options ! 66 | 67 | opts%edge_meth = p3e_method ! 3rd-order edge interp. 68 | opts%cell_meth = ppm_method ! PPM method in cells 69 | opts%cell_lims = null_limit ! no slope limiter 70 | 71 | !------------------------------ set BC.'s at endpoints ! 72 | 73 | bc_l%bcopt = bcon_loose ! "loose" = extrapolate 74 | bc_r%bcopt = bcon_loose 75 | 76 | !------------------------------ init. method workspace ! 77 | 78 | call work%init(npos,nvar,opts) 79 | 80 | !------------------------------ re-map back-and-forth: ! 81 | 82 | fdat = init 83 | 84 | do ipos = +1, +1000 85 | 86 | !------------------------------ re-map from dat-to-tmp ! 87 | 88 | call rmap1d(npos,ntmp,nvar,ndof, & 89 | & xpos,xtmp,fdat,ftmp, & 90 | & bc_l,bc_r,work,opts) 91 | 92 | !------------------------------ re-map from tmp-to-dat ! 93 | 94 | call rmap1d(ntmp,npos,nvar,ndof, & 95 | & xtmp,xpos,ftmp,fdat, & 96 | & bc_l,bc_r,work,opts) 97 | 98 | end do 99 | 100 | !------------------------------ clear method workspace ! 101 | 102 | call work%free() 103 | 104 | !------------------------------ dump results to stdout ! 105 | 106 | print*,"Cell data: [INIT] [RMAP] " 107 | 108 | do ipos = +1, npos-1 109 | 110 | print *, init(1,1,ipos) & 111 | & , fdat(1,1,ipos) 112 | 113 | end do 114 | 115 | print*,"Conservation defect := " & 116 | & , sum(init) - sum(fdat) 117 | 118 | end program 119 | 120 | 121 | 122 | -------------------------------------------------------------------------------- /example/ex_1.f90: -------------------------------------------------------------------------------- 1 | 2 | ! gfortran -pedantic -cpp -O3 -flto ex_1.f90 -o ex_1 3 | ! ./ex_1 4 | 5 | ! A very simple starting point: remap a quadratic profile 6 | ! between two unequal (but uniform) grids. The PPM + PQM 7 | ! methods should be exact here! 8 | ! 9 | 10 | # include "../src/ppr_1d.f90" 11 | 12 | program ex 13 | 14 | use ppr_1d 15 | 16 | implicit none 17 | 18 | integer, parameter :: npos = 31 ! no. edge (old grid) 19 | integer, parameter :: ntmp = 23 ! no. edge (new grid) 20 | integer, parameter :: nvar = 1 ! no. variables to remap 21 | integer, parameter :: ndof = 1 ! no. FV DoF per cell 22 | integer :: ipos 23 | 24 | !------------------------------ position of cell edges ! 25 | real(kind=dp) :: xpos(npos),xtmp(ntmp) 26 | real(kind=dp) :: xmid 27 | 28 | !-------------------------------- finite-volume arrays ! 29 | 30 | ! Arrays represent a "block" of finite-volume tracers 31 | ! to remap. The 1st dim. is the no. of DoF per cell, 32 | ! NDOF=1 is a standard finite-volume scheme where the 33 | ! data is specified as cell means. NDOF>1 is reserved 34 | ! for future use with DG-style schemes. NVAR is the 35 | ! number of tracers to remap. Processing tracers in a 36 | ! batch is typically more efficient than one-by-one. 37 | ! The last dim. is the no. cells (layers) in the grid. 38 | 39 | real(kind=dp) :: init(ndof,nvar,npos-1) 40 | real(kind=dp) :: fdat(ndof,nvar,npos-1) 41 | real(kind=dp) :: ftmp(ndof,nvar,ntmp-1) 42 | 43 | !------------------------------ method data-structures ! 44 | type(rmap_work) :: work 45 | type(rmap_opts) :: opts 46 | type(rcon_ends) :: bc_l(nvar) 47 | type(rcon_ends) :: bc_r(nvar) 48 | 49 | !------------------------------ define a simple domain ! 50 | 51 | call linspace(0.d0,1.d0,npos,xpos) 52 | call linspace(0.d0,1.d0,ntmp,xtmp) 53 | 54 | !------------------------------ setup some simple data ! 55 | 56 | do ipos = +1, npos-1 57 | 58 | xmid = xpos(ipos+0) * 0.5d+0 & 59 | & + xpos(ipos+1) * 0.5d+0 60 | 61 | init(1,1,ipos) = xmid ** 2 62 | 63 | end do 64 | 65 | !------------------------------ specify method options ! 66 | 67 | opts%edge_meth = p3e_method ! 3rd-order edge interp. 68 | opts%cell_meth = ppm_method ! PPM method in cells 69 | opts%cell_lims = null_limit ! no slope limiter 70 | 71 | !------------------------------ set BC.'s at endpoints ! 72 | 73 | bc_l%bcopt = bcon_loose ! "loose" = extrapolate 74 | bc_r%bcopt = bcon_loose 75 | 76 | !------------------------------ init. method workspace ! 77 | 78 | call work%init(npos,nvar,opts) 79 | 80 | !------------------------------ re-map back-and-forth: ! 81 | 82 | fdat = init 83 | 84 | do ipos = +1, +1000 85 | 86 | !------------------------------ re-map from dat-to-tmp ! 87 | 88 | call rmap1d(npos,ntmp,nvar,ndof, & 89 | & xpos,xtmp,fdat,ftmp, & 90 | & bc_l,bc_r,work,opts) 91 | 92 | !------------------------------ re-map from tmp-to-dat ! 93 | 94 | call rmap1d(ntmp,npos,nvar,ndof, & 95 | & xtmp,xpos,ftmp,fdat, & 96 | & bc_l,bc_r,work,opts) 97 | 98 | end do 99 | 100 | !------------------------------ clear method workspace ! 101 | 102 | call work%free() 103 | 104 | !------------------------------ dump results to stdout ! 105 | 106 | print*,"Cell data: [INIT] [RMAP] " 107 | 108 | do ipos = +1, npos-1 109 | 110 | print *, init(1,1,ipos) & 111 | & , fdat(1,1,ipos) 112 | 113 | end do 114 | 115 | print*,"Conservation defect := " & 116 | & , sum(init) - sum(fdat) 117 | 118 | end program 119 | 120 | 121 | 122 | -------------------------------------------------------------------------------- /example/ex_7.f90: -------------------------------------------------------------------------------- 1 | 2 | ! gfortran -pedantic -cpp -O3 -flto ex_7.f90 -o ex_7 3 | ! ./ex_7 4 | 5 | ! Same as ex_1, but with xdir reversed so that xpos, xnew 6 | ! become more -ve with increasing array indices. 7 | ! 8 | 9 | # include "../src/ppr_1d.f90" 10 | 11 | program ex 12 | 13 | use ppr_1d 14 | 15 | implicit none 16 | 17 | integer, parameter :: npos = 31 ! no. edge (old grid) 18 | integer, parameter :: ntmp = 23 ! no. edge (new grid) 19 | integer, parameter :: nvar = 1 ! no. variables to remap 20 | integer, parameter :: ndof = 1 ! no. FV DoF per cell 21 | integer :: ipos 22 | 23 | !------------------------------ position of cell edges ! 24 | real(kind=dp) :: xpos(npos),xtmp(ntmp) 25 | real(kind=dp) :: xmid 26 | 27 | !-------------------------------- finite-volume arrays ! 28 | 29 | ! Arrays represent a "block" of finite-volume tracers 30 | ! to remap. The 1st dim. is the no. of DoF per cell, 31 | ! NDOF=1 is a standard finite-volume scheme where the 32 | ! data is specified as cell means. NDOF>1 is reserved 33 | ! for future use with DG-style schemes. NVAR is the 34 | ! number of tracers to remap. Processing tracers in a 35 | ! batch is typically more efficient than one-by-one. 36 | ! The last dim. is the no. cells (layers) in the grid. 37 | 38 | real(kind=dp) :: init(ndof,nvar,npos-1) 39 | real(kind=dp) :: fdat(ndof,nvar,npos-1) 40 | real(kind=dp) :: ftmp(ndof,nvar,ntmp-1) 41 | 42 | !------------------------------ method data-structures ! 43 | type(rmap_work) :: work 44 | type(rmap_opts) :: opts 45 | type(rcon_ends) :: bc_l(nvar) 46 | type(rcon_ends) :: bc_r(nvar) 47 | 48 | !------------------------------ define a simple domain ! 49 | 50 | call linspace(0.d0,1.d0,npos,xpos) 51 | call linspace(0.d0,1.d0,ntmp,xtmp) 52 | 53 | xpos = -1.d0 * xpos 54 | xtmp = -1.d0 * xtmp 55 | 56 | !------------------------------ setup some simple data ! 57 | 58 | do ipos = +1, npos-1 59 | 60 | xmid = xpos(ipos+0) * 0.5d+0 & 61 | & + xpos(ipos+1) * 0.5d+0 62 | 63 | init(1,1,ipos) = xmid ** 2 64 | 65 | end do 66 | 67 | !------------------------------ specify method options ! 68 | 69 | opts%edge_meth = p3e_method ! 3rd-order edge interp. 70 | opts%cell_meth = ppm_method ! PPM method in cells 71 | opts%cell_lims = null_limit ! no slope limiter 72 | 73 | !------------------------------ set BC.'s at endpoints ! 74 | 75 | bc_l%bcopt = bcon_loose ! "loose" = extrapolate 76 | bc_r%bcopt = bcon_loose 77 | 78 | !------------------------------ init. method workspace ! 79 | 80 | call work%init(npos,nvar,opts) 81 | 82 | !------------------------------ re-map back-and-forth: ! 83 | 84 | fdat = init 85 | 86 | do ipos = +1, +1000 87 | 88 | !------------------------------ re-map from dat-to-tmp ! 89 | 90 | call rmap1d(npos,ntmp,nvar,ndof, & 91 | & xpos,xtmp,fdat,ftmp, & 92 | & bc_l,bc_r,work,opts) 93 | 94 | !------------------------------ re-map from tmp-to-dat ! 95 | 96 | call rmap1d(ntmp,npos,nvar,ndof, & 97 | & xtmp,xpos,ftmp,fdat, & 98 | & bc_l,bc_r,work,opts) 99 | 100 | end do 101 | 102 | !------------------------------ clear method workspace ! 103 | 104 | call work%free() 105 | 106 | !------------------------------ dump results to stdout ! 107 | 108 | print*,"Cell data: [INIT] [RMAP] " 109 | 110 | do ipos = +1, npos-1 111 | 112 | print *, init(1,1,ipos) & 113 | & , fdat(1,1,ipos) 114 | 115 | end do 116 | 117 | print*,"Conservation defect := " & 118 | & , sum(init) - sum(fdat) 119 | 120 | end program 121 | 122 | 123 | 124 | -------------------------------------------------------------------------------- /example/ex_4.f90: -------------------------------------------------------------------------------- 1 | 2 | ! gfortran -pedantic -cpp -O3 -flto ex_4.f90 -o ex_4 3 | ! ./ex_4 4 | 5 | ! Test for multi-tracer remapping: remap a set of profiles 6 | ! between randomly perturbed grids. 7 | ! 8 | 9 | # include "../src/ppr_1d.f90" 10 | 11 | program ex 12 | 13 | use ppr_1d 14 | 15 | implicit none 16 | 17 | integer, parameter :: npos = 53 ! no. edge (old grid) 18 | integer, parameter :: ntmp = 43 ! no. edge (new grid) 19 | integer, parameter :: nvar = 3 ! no. variables to remap 20 | integer, parameter :: ndof = 1 ! no. FV DoF per cell 21 | integer :: ipos 22 | 23 | !------------------------------ position of cell edges ! 24 | real(kind=dp) :: xpos(npos),xtmp(ntmp) 25 | real(kind=dp) :: xmid 26 | 27 | !-------------------------------- finite-volume arrays ! 28 | 29 | ! Arrays represent a "block" of finite-volume tracers 30 | ! to remap. The 1st dim. is the no. of DoF per cell, 31 | ! NDOF=1 is a standard finite-volume scheme where the 32 | ! data is specified as cell means. NDOF>1 is reserved 33 | ! for future use with DG-style schemes. NVAR is the 34 | ! number of tracers to remap. Processing tracers in a 35 | ! batch is typically more efficient than one-by-one. 36 | ! The last dim. is the no. cells (layers) in the grid. 37 | 38 | real(kind=dp) :: init(ndof,nvar,npos-1) 39 | real(kind=dp) :: fdat(ndof,nvar,npos-1) 40 | real(kind=dp) :: ftmp(ndof,nvar,ntmp-1) 41 | 42 | !------------------------------ method data-structures ! 43 | type(rmap_work) :: work 44 | type(rmap_opts) :: opts 45 | type(rcon_ends) :: bc_l(nvar) 46 | type(rcon_ends) :: bc_r(nvar) 47 | 48 | !------------------------------ define a simple domain ! 49 | 50 | call linspace(0.d0,1.d0,npos,xpos) 51 | call rndspace(0.d0,1.d0,ntmp,xtmp) 52 | 53 | !------------------------------ setup some simple data ! 54 | 55 | do ipos = +1, npos-1 56 | 57 | xmid = xpos(ipos+0) * 0.5d+0 & 58 | & + xpos(ipos+1) * 0.5d+0 59 | 60 | init(1,1,ipos) = & 61 | & .8d+0 * exp( -75.0d+0 * (xmid - 0.275d+0) ** 2 ) 62 | 63 | init(1,2,ipos) = & 64 | & + .9d+0 * exp(-100.0d+0 * (xmid - 0.500d+0) ** 2 ) 65 | 66 | init(1,3,ipos) = & 67 | & + 1.d+0 * exp(-125.0d+0 * (xmid - 0.725d+0) ** 2 ) 68 | 69 | end do 70 | 71 | !------------------------------ specify method options ! 72 | 73 | opts%edge_meth = p3e_method ! 5th-order edge interp. 74 | opts%cell_meth = ppm_method ! PQM method in cells 75 | opts%cell_lims = mono_limit ! monotone limiter 76 | 77 | !------------------------------ set BC.'s at endpoints ! 78 | 79 | bc_l%bcopt = bcon_loose ! "loose" = extrapolate 80 | bc_r%bcopt = bcon_loose 81 | 82 | !------------------------------ init. method workspace ! 83 | 84 | call work%init(npos,nvar,opts) 85 | 86 | !------------------------------ re-map back-and-forth: ! 87 | 88 | fdat = init 89 | 90 | do ipos = +1, +1000 91 | 92 | !------------------------------ re-map from dat-to-tmp ! 93 | 94 | call rmap1d(npos,ntmp,nvar,ndof, & 95 | & xpos,xtmp,fdat,ftmp, & 96 | & bc_l,bc_r,work,opts) 97 | 98 | !------------------------------ re-map from tmp-to-dat ! 99 | 100 | call rmap1d(ntmp,npos,nvar,ndof, & 101 | & xtmp,xpos,ftmp,fdat, & 102 | & bc_l,bc_r,work,opts) 103 | 104 | end do 105 | 106 | !------------------------------ clear method workspace ! 107 | 108 | call work%free() 109 | 110 | !------------------------------ dump results to stdout ! 111 | 112 | print*,"Cell data: [INIT] [RMAP] " 113 | 114 | do ipos = +1, npos-1 115 | 116 | print *, init(1,:,ipos) & 117 | & , fdat(1,:,ipos) 118 | 119 | end do 120 | 121 | print*,"Conservation defect := " & 122 | & , sum(init) - sum(fdat) 123 | 124 | end program 125 | 126 | 127 | 128 | -------------------------------------------------------------------------------- /example/ex_2.f90: -------------------------------------------------------------------------------- 1 | 2 | ! gfortran -pedantic -cpp -O3 -flto ex_2.f90 -o ex_2 3 | ! ./ex_2 4 | 5 | ! Test for the monotone limiter: remap a stairstep profile 6 | ! between randomly perturbed grids. When MONO-LIMIT is 7 | ! selected, all methods should lead to monotone behaviour. 8 | ! 9 | 10 | # include "../src/ppr_1d.f90" 11 | 12 | program ex 13 | 14 | use ppr_1d 15 | 16 | implicit none 17 | 18 | integer, parameter :: npos = 97 ! no. edge (old grid) 19 | integer, parameter :: ntmp = 77 ! no. edge (new grid) 20 | integer, parameter :: nvar = 1 ! no. variables to remap 21 | integer, parameter :: ndof = 1 ! no. FV DoF per cell 22 | integer :: ipos 23 | 24 | !------------------------------ position of cell edges ! 25 | real(kind=dp) :: xpos(npos),xtmp(ntmp) 26 | real(kind=dp) :: xmid 27 | 28 | !-------------------------------- finite-volume arrays ! 29 | 30 | ! Arrays represent a "block" of finite-volume tracers 31 | ! to remap. The 1st dim. is the no. of DoF per cell, 32 | ! NDOF=1 is a standard finite-volume scheme where the 33 | ! data is specified as cell means. NDOF>1 is reserved 34 | ! for future use with DG-style schemes. NVAR is the 35 | ! number of tracers to remap. Processing tracers in a 36 | ! batch is typically more efficient than one-by-one. 37 | ! The last dim. is the no. cells (layers) in the grid. 38 | 39 | real(kind=dp) :: init(ndof,nvar,npos-1) 40 | real(kind=dp) :: fdat(ndof,nvar,npos-1) 41 | real(kind=dp) :: ftmp(ndof,nvar,ntmp-1) 42 | 43 | !------------------------------ method data-structures ! 44 | type(rmap_work) :: work 45 | type(rmap_opts) :: opts 46 | type(rcon_ends) :: bc_l(nvar) 47 | type(rcon_ends) :: bc_r(nvar) 48 | 49 | !------------------------------ define a simple domain ! 50 | 51 | call linspace(0.d0,1.d0,npos,xpos) 52 | call rndspace(0.d0,1.d0,ntmp,xtmp) 53 | 54 | !------------------------------ setup some simple data ! 55 | 56 | do ipos = +1, npos-1 57 | 58 | xmid = xpos(ipos+0) * 0.5d+0 & 59 | & + xpos(ipos+1) * 0.5d+0 60 | 61 | if (xmid .lt. 0.075d0) then 62 | init(1,1,ipos) = +1.0d0 63 | else & 64 | if (xmid .lt. 0.80d0) then 65 | init(1,1,ipos) = +2.0d0 66 | else 67 | init(1,1,ipos) = -0.5d0 * xmid ** 2 68 | end if 69 | 70 | end do 71 | 72 | !------------------------------ specify method options ! 73 | 74 | opts%edge_meth = p5e_method ! 5th-order edge interp. 75 | opts%cell_meth = pqm_method ! PQM method in cells 76 | opts%cell_lims = mono_limit ! monotone limiter 77 | !opts%wall_lims = weno_limit 78 | 79 | !------------------------------ set BC.'s at endpoints ! 80 | 81 | bc_l%bcopt = bcon_loose ! "loose" = extrapolate 82 | bc_r%bcopt = bcon_loose 83 | 84 | !------------------------------ init. method workspace ! 85 | 86 | call work%init(npos,nvar,opts) 87 | 88 | !------------------------------ re-map back-and-forth: ! 89 | 90 | fdat = init 91 | 92 | do ipos = +1, +1000 93 | 94 | !------------------------------ re-map from dat-to-tmp ! 95 | 96 | call rmap1d(npos,ntmp,nvar,ndof, & 97 | & xpos,xtmp,fdat,ftmp, & 98 | & bc_l,bc_r,work,opts) 99 | 100 | !------------------------------ re-map from tmp-to-dat ! 101 | 102 | call rmap1d(ntmp,npos,nvar,ndof, & 103 | & xtmp,xpos,ftmp,fdat, & 104 | & bc_l,bc_r,work,opts) 105 | 106 | end do 107 | 108 | !------------------------------ clear method workspace ! 109 | 110 | call work%free() 111 | 112 | !------------------------------ dump results to stdout ! 113 | 114 | print*,"Cell data: [INIT] [RMAP] " 115 | 116 | do ipos = +1, npos-1 117 | 118 | print *, init(1,1,ipos) & 119 | & , fdat(1,1,ipos) 120 | 121 | end do 122 | 123 | print*,"Conservation defect := " & 124 | & , sum(init) - sum(fdat) 125 | 126 | end program 127 | 128 | 129 | 130 | -------------------------------------------------------------------------------- /example/ex_3.f90: -------------------------------------------------------------------------------- 1 | 2 | ! gfortran -pedantic -cpp -O3 -flto ex_3.f90 -o ex_3 3 | ! ./ex_3 4 | 5 | ! "Convergence" testing: remap a smooth (Gaussian) profile 6 | ! between perturbed grids and compute error in the L2-nrm. 7 | ! Re-run with N = 50, 100, 200, ... etc (and N-tmp at 80%) 8 | ! to assess the order of spatial accuracy. With NUll/WENO- 9 | ! LIMIT, all methods should achieve their best-case O(h^p) 10 | ! scaling. 11 | ! 12 | 13 | # include "../src/ppr_1d.f90" 14 | 15 | program ex 16 | 17 | use ppr_1d 18 | 19 | implicit none 20 | 21 | integer, parameter :: npos = 100 ! no. edge (old grid) 22 | integer, parameter :: ntmp = 80 ! no. edge (new grid) 23 | integer, parameter :: nvar = 1 ! no. variables to remap 24 | integer, parameter :: ndof = 1 ! no. FV DoF per cell 25 | integer :: ipos 26 | 27 | !------------------------------ position of cell edges ! 28 | real(kind=dp) :: xpos(npos),xtmp(ntmp) 29 | real(kind=dp) :: xdel,xmid 30 | 31 | !-------------------------------- finite-volume arrays ! 32 | 33 | ! Arrays represent a "block" of finite-volume tracers 34 | ! to remap. The 1st dim. is the no. of DoF per cell, 35 | ! NDOF=1 is a standard finite-volume scheme where the 36 | ! data is specified as cell means. NDOF>1 is reserved 37 | ! for future use with DG-style schemes. NVAR is the 38 | ! number of tracers to remap. Processing tracers in a 39 | ! batch is typically more efficient than one-by-one. 40 | ! The last dim. is the no. cells (layers) in the grid. 41 | 42 | real(kind=dp) :: init(ndof,nvar,npos-1) 43 | real(kind=dp) :: fdat(ndof,nvar,npos-1) 44 | real(kind=dp) :: ftmp(ndof,nvar,ntmp-1) 45 | 46 | !------------------------------ method data-structures ! 47 | type(rmap_work) :: work 48 | type(rmap_opts) :: opts 49 | type(rcon_ends) :: bc_l(nvar) 50 | type(rcon_ends) :: bc_r(nvar) 51 | 52 | !------------------------------ define a simple domain ! 53 | 54 | call linspace(0.d0,1.d0,npos,xpos) 55 | call rndspace(0.d0,1.d0,ntmp,xtmp) 56 | 57 | !------------------------------ setup some simple data ! 58 | 59 | do ipos = +1, npos-1 60 | 61 | xmid = xpos(ipos+0) * 0.5d+0 & 62 | & + xpos(ipos+1) * 0.5d+0 63 | 64 | init(1,1,ipos) = & 65 | & .8d+0 * exp( -75.0d+0 * (xmid - 0.275d+0) ** 2 ) & 66 | & + .9d+0 * exp(-100.0d+0 * (xmid - 0.500d+0) ** 2 ) & 67 | & + 1.d+0 * exp(-125.0d+0 * (xmid - 0.725d+0) ** 2 ) 68 | 69 | end do 70 | 71 | !------------------------------ specify method options ! 72 | 73 | opts%edge_meth = p3e_method ! 5th-order edge interp. 74 | opts%cell_meth = ppm_method ! PQM method in cells 75 | opts%cell_lims = mono_limit ! monotone limiter 76 | 77 | !------------------------------ set BC.'s at endpoints ! 78 | 79 | bc_l%bcopt = bcon_loose ! "loose" = extrapolate 80 | bc_r%bcopt = bcon_loose 81 | 82 | !------------------------------ init. method workspace ! 83 | 84 | call work%init(npos,nvar,opts) 85 | 86 | !------------------------------ re-map back-and-forth: ! 87 | 88 | fdat = init 89 | 90 | do ipos = +1, +1000 91 | 92 | !------------------------------ re-map from dat-to-tmp ! 93 | 94 | call rmap1d(npos,ntmp,nvar,ndof, & 95 | & xpos,xtmp,fdat,ftmp, & 96 | & bc_l,bc_r,work,opts) 97 | 98 | !------------------------------ re-map from tmp-to-dat ! 99 | 100 | call rmap1d(ntmp,npos,nvar,ndof, & 101 | & xtmp,xpos,ftmp,fdat, & 102 | & bc_l,bc_r,work,opts) 103 | 104 | end do 105 | 106 | !------------------------------ clear method workspace ! 107 | 108 | call work%free() 109 | 110 | !------------------------------ dump results to stdout ! 111 | 112 | print*,"Cell data: [INIT] [RMAP] " 113 | 114 | do ipos = +1, npos-1 115 | 116 | print *, init(1,1,ipos) & 117 | & , fdat(1,1,ipos) 118 | 119 | end do 120 | 121 | print*,"Conservation defect := " & 122 | & , sum(init) - sum(fdat) 123 | 124 | !------------------------------ calc. errors in L2 nrm ! 125 | 126 | xdel = (xpos(npos)-xpos(1))/(npos-1) 127 | 128 | print*,"Discrete (L2) Error := ",& 129 | sqrt(sum(xdel * (init(1,1,:) - fdat(1,1,:)) ** 2)) 130 | 131 | end program 132 | 133 | 134 | 135 | -------------------------------------------------------------------------------- /src/util1d.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! UTIL1D.f90: util. func. for 1-dim. grid manipulation. 31 | ! 32 | ! Darren Engwirda 33 | ! 08-Nov-2021 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | function sum_kbn(xvec) result(ssum) 39 | 40 | ! 41 | ! XVEC array to sum. 42 | ! SSUM sum(XVEC), via Kahan-Babuska-Neumaier sum . 43 | ! 44 | 45 | implicit none 46 | 47 | real(kind=dp), intent(in) :: xvec(:) 48 | 49 | integer :: ipos 50 | real(kind=dp) :: ssum,serr,stmp 51 | 52 | !------------------------------- compensated summation ! 53 | 54 | ssum = 0.d0; serr = 0.d0 55 | 56 | do ipos = +1, size(xvec) - 0 57 | 58 | stmp = ssum + xvec(ipos) 59 | 60 | if (abs(ssum) & 61 | & .ge. abs(xvec(ipos))) then 62 | 63 | serr = & 64 | & serr + ((ssum-stmp)+xvec(ipos)) 65 | 66 | else 67 | 68 | serr = & 69 | & serr + ((xvec(ipos)-stmp)+ssum) 70 | 71 | end if 72 | 73 | ssum = stmp 74 | 75 | end do 76 | 77 | ssum = ssum + serr 78 | 79 | return 80 | 81 | end function 82 | 83 | subroutine linspace(xxll,xxuu,npos,xpos) 84 | 85 | ! 86 | ! XXLL lower-bound grid position. 87 | ! NNEW upper-bound grid position. 88 | ! NPOS no. edges in the grid. 89 | ! XPOS array of grid edges. XPOS has length NPOS . 90 | ! 91 | 92 | implicit none 93 | 94 | real(kind=dp), intent(in) :: xxll,xxuu 95 | integer , intent(in) :: npos 96 | real(kind=dp), intent(out) :: xpos(:) 97 | 98 | integer :: ipos 99 | real(kind=dp) :: xdel 100 | 101 | xpos( 1) = xxll 102 | xpos(npos) = xxuu 103 | 104 | xdel = (xxuu-xxll) / (npos - 1) 105 | 106 | do ipos = +2, npos-1 107 | 108 | xpos(ipos) = (ipos-1) * xdel 109 | 110 | end do 111 | 112 | return 113 | 114 | end subroutine 115 | 116 | subroutine rndspace(xxll,xxuu,npos,xpos, & 117 | & frac) 118 | 119 | ! 120 | ! XXLL lower-bound grid position. 121 | ! NNEW upper-bound grid position. 122 | ! NPOS no. edges in the grid. 123 | ! XPOS array of grid edges. XPOS has length NPOS . 124 | ! FRAC fractional perturbation of cell, OPTIONAL . 125 | ! 126 | 127 | implicit none 128 | 129 | real(kind=dp), intent(in) :: xxll,xxuu 130 | integer , intent(in) :: npos 131 | real(kind=dp), intent(out) :: xpos(:) 132 | real(kind=dp), intent(in), optional :: frac 133 | 134 | integer :: ipos 135 | real(kind=dp) :: xdel 136 | real(kind=dp) :: rand,move 137 | 138 | if (present(frac)) then 139 | move = +frac 140 | else 141 | move = 3.0d0 / 8.0d0 142 | end if 143 | 144 | xpos( 1) = xxll 145 | xpos(npos) = xxuu 146 | 147 | xdel = (xxuu-xxll) / (npos - 1) 148 | 149 | do ipos = +2, npos-1 150 | 151 | xpos(ipos) = (ipos-1) * xdel 152 | 153 | end do 154 | 155 | do ipos = +2, npos-1 156 | 157 | call random_number (rand) 158 | 159 | rand = 2.d0 * (rand-.5d0) 160 | 161 | xpos(ipos) = & 162 | & xpos(ipos) + (move * rand * xdel) 163 | 164 | end do 165 | 166 | return 167 | 168 | end subroutine 169 | 170 | 171 | 172 | -------------------------------------------------------------------------------- /example/ex_5.f90: -------------------------------------------------------------------------------- 1 | 2 | ! gfortran -pedantic -cpp -O3 -flto ex_5.f90 -o ex_5 3 | ! ./ex_5 4 | 5 | ! Assemble high-order interpolants over a uniform domain. 6 | ! 7 | 8 | # include "../src/ppr_1d.f90" 9 | 10 | program ex 11 | 12 | use ppr_1d 13 | 14 | implicit none 15 | 16 | integer, parameter :: npos = 37 ! no. edge 17 | integer, parameter :: nvar = 1 ! no. variables to build 18 | integer, parameter :: ndof = 1 ! no. FV DoF per cell 19 | integer :: ipos,jpos,mdof 20 | 21 | !------------------------------- domain discretisation ! 22 | real(kind=dp) :: xpos(npos),xdel(npos-1) 23 | real(kind=dp) :: xmid,xhat,xloc,floc 24 | 25 | !-------------------------------- finite-volume arrays ! 26 | 27 | ! Arrays represent a "block" of finite-volume tracers 28 | ! to remap. The 1st dim. is the no. of DoF per cell, 29 | ! NDOF=1 is a standard finite-volume scheme where the 30 | ! data is specified as cell means. NDOF>1 is reserved 31 | ! for future use with DG-style schemes. NVAR is the 32 | ! number of tracers to remap. Processing tracers in a 33 | ! batch is typically more efficient than one-by-one. 34 | ! The last dim. is the no. cells (layers) in the grid. 35 | 36 | real(kind=dp) :: fdat(ndof,nvar,npos-1) 37 | 38 | !-------------------------------- reconstruction coeff ! 39 | 40 | ! Coeff. for the piecewise polynomial reconstruction. 41 | ! A polynomial is assembled for each cell w.r.t. a 42 | ! "local" cell coordinate system: each cell is mapped 43 | ! onto [-1,+1]. The interpolants can be evaluated by 44 | ! taking the product FHAT*BVEC, where BVEC is a basis 45 | ! vector assembled at the interpolation points. Basis 46 | ! vectors can eb assembled via calls to BFUN1D(). 47 | 48 | real(kind=dp) :: fhat( 5,nvar,npos-1) 49 | real(kind=dp) :: bvec( 5) 50 | real(kind=dp) :: spos( 5) 51 | 52 | !------------------------------ method data-structures ! 53 | type(rcon_work) :: work 54 | type(rcon_opts) :: opts 55 | type(rcon_ends) :: bc_l(nvar) 56 | type(rcon_ends) :: bc_r(nvar) 57 | 58 | !------------------------------ define a simple domain ! 59 | 60 | call rndspace(0.d0,1.d0,npos,xpos) 61 | 62 | xdel(1) = (xpos(npos)& 63 | & - xpos( 1)) / (npos- 1) 64 | 65 | !------------------------------ setup some simple data ! 66 | 67 | do ipos = +1, npos-1 68 | 69 | xdel(ipos) = xpos(ipos+1) - xpos(ipos) 70 | print*, xdel(ipos) 71 | 72 | xmid = xpos(ipos+0) * 0.5d+0 & 73 | & + xpos(ipos+1) * 0.5d+0 74 | 75 | fdat(1,1,ipos) = & 76 | & .8d+0 * exp( -75.0d+0 * (xmid - 0.275d+0) ** 2 ) & 77 | & + .9d+0 * exp(-100.0d+0 * (xmid - 0.500d+0) ** 2 ) & 78 | & + 1.d+0 * exp(-125.0d+0 * (xmid - 0.725d+0) ** 2 ) 79 | 80 | 81 | if (xmid .lt. 0.075d0) then 82 | fdat(1,1,ipos) = +1.0d0 83 | else & 84 | if (xmid .lt. 0.80d0) then 85 | fdat(1,1,ipos) = +2.0d0 86 | else 87 | fdat(1,1,ipos) = -0.5d0 * xmid ** 2 88 | end if 89 | 90 | end do 91 | 92 | !------------------------------ specify method options ! 93 | 94 | opts%edge_meth = p5e_method ! 5th-order edge interp. 95 | opts%cell_meth = ppm_method ! PPM method in cells 96 | opts%cell_lims = mono_limit ! monotone limiter 97 | 98 | !------------------------------ set BC.'s at endpoints ! 99 | 100 | bc_l%bcopt = bcon_loose ! "loose" = extrapolate 101 | bc_r%bcopt = bcon_loose 102 | 103 | !------------------------------ init. method workspace ! 104 | 105 | call work%init(npos,nvar,opts) 106 | 107 | !------------------------------ build cell polynomials ! 108 | 109 | fhat = 0.d+0; bvec = 0.d+0; spos = 0.d+0 110 | 111 | mdof = ndof1d (opts%cell_meth) 112 | 113 | call rcon1d(npos,nvar,ndof,xdel, & 114 | & fdat,bc_l,bc_r,fhat, & 115 | & work,opts) 116 | 117 | !------------------------------ clear method workspace ! 118 | 119 | call work%free() 120 | 121 | !------------------------------ dump results to stdout ! 122 | 123 | print*,"Eval. PPR interpolant: " 124 | 125 | spos(1) = -1.0d+0 ! eval. at local points 126 | spos(2) = -0.5d+0 127 | spos(3) = +0.0d+0 128 | spos(4) = +0.5d+0 129 | spos(5) = +1.0d+0 130 | 131 | do ipos = +1, npos-1 132 | do jpos = +1, +5 133 | 134 | xmid = xpos(ipos+1)* 0.5d+0 & 135 | & + xpos(ipos+0)* 0.5d+0 136 | 137 | xhat = xpos(ipos+1)* 0.5d+0 & 138 | & - xpos(ipos+0)* 0.5d+0 139 | 140 | xloc = xmid + spos(jpos)*xhat 141 | 142 | call bfun1d(0,mdof,spos(jpos),bvec) 143 | 144 | floc = dot_product( & 145 | & fhat(+1:mdof,1,ipos),bvec(+1:mdof)) 146 | 147 | print *, xloc, floc 148 | 149 | end do 150 | end do 151 | 152 | end program 153 | 154 | 155 | 156 | -------------------------------------------------------------------------------- /example/ex_6.f90: -------------------------------------------------------------------------------- 1 | 2 | ! gfortran -pedantic -cpp -O3 -flto ex_6.f90 -o ex_6 3 | ! ./ex_6 4 | 5 | ! 1d scalar transport in a periodic domain. Fluxes are 6 | ! computed in a flux-form semi-lagrangian sense -- 7 | ! integrating over the upwind regions "swept" by edges 8 | ! in each time-step. This implementation requires CFL<1, 9 | ! with the upwind regions covering adjacent cells only. 10 | ! A CFL>=1 variant could be constructed using RMAP1D(). 11 | ! 12 | 13 | # include "../src/ppr_1d.f90" 14 | 15 | program ex 16 | 17 | use ppr_1d 18 | 19 | implicit none 20 | 21 | integer, parameter :: halo = 4 ! halo cells at boundary 22 | integer, parameter :: npos = 51 ! no. edge 23 | integer, parameter :: nvar = 1 ! no. tracers to trnsprt 24 | integer, parameter :: ndof = 1 ! no. FV DoF per cell 25 | integer :: ipos,il,ir,step 26 | 27 | !------------------------------- domain discretisation ! 28 | real(kind=dp) :: xpos(1-halo:npos+halo) 29 | real(kind=dp) :: xmid,xdel(1),tDEL 30 | 31 | !-------------------------------- finite-volume arrays ! 32 | 33 | ! INIT: initial cell-wise finite-volume profile 34 | ! QBAR: dynamic cell-wise finite-volume profile 35 | ! MASK: cell-wise "land" mask (all TRUE here) 36 | ! UVEL: edge-wise velocity distribution 37 | ! FLUX: edge-wise distribution of upwind fluxes 38 | ! QDIV: cell-wise distribution of divergence 39 | 40 | real(kind=dp) :: init(ndof,nvar,1-halo:npos+halo-1) 41 | real(kind=dp) :: qbar(ndof,nvar,1-halo:npos+halo-1) 42 | logical :: mask( 1-halo:npos+halo-1) 43 | real(kind=dp) :: uvel( 1-halo:npos+halo) 44 | real(kind=dp) :: flux( nvar,1-halo:npos+halo) 45 | real(kind=dp) :: qdiv( nvar,1-halo:npos+halo-1) 46 | 47 | 48 | !------------------------------ method data-structures ! 49 | type(rmap_work) :: work 50 | type(rmap_opts) :: opts 51 | type(rcon_ends) :: bc_l(nvar) 52 | type(rcon_ends) :: bc_r(nvar) 53 | 54 | !------------------------------ define a simple domain ! 55 | 56 | il = + 1 ! 1st real interior cell 57 | ir = npos - 1 ! Nth real interior cell 58 | 59 | xpos(il+0) = 0.0d+00 60 | xpos(ir+1) = 1.0d+00 61 | 62 | xdel(1) = (xpos(ir+1)-xpos(il+0))/(npos-1) 63 | 64 | do ipos = il+1, ir-0 65 | 66 | xpos(ipos) = (ipos-1) * xdel(1) 67 | 68 | end do 69 | 70 | !------------------------------ setup some simple data ! 71 | 72 | uvel = +1.0d+0 73 | mask = .true. 74 | 75 | tDEL = +1.0d-2 76 | 77 | do ipos = +1, npos-1 78 | 79 | xmid = xpos(ipos+0)* 0.5d+00 & 80 | & + xpos(ipos+1)* 0.5d+00 81 | 82 | init(1,1,ipos) = & 83 | & .8d+0 * exp( -75.0d+0 * (xmid - 0.275d+0) ** 2 ) & 84 | & + .9d+0 * exp(-100.0d+0 * (xmid - 0.500d+0) ** 2 ) & 85 | & + 1.d+0 * exp(-125.0d+0 * (xmid - 0.725d+0) ** 2 ) 86 | 87 | end do 88 | 89 | !------------------------------ specify method options ! 90 | 91 | opts%edge_meth = p3e_method ! 3rd-order edge interp. 92 | opts%cell_meth = ppm_method ! PPM method in cells 93 | opts%cell_lims = weno_limit ! "non-oscillatory" lim. 94 | 95 | !------------------------------ set BC.'s at endpoints ! 96 | 97 | bc_l%bcopt = bcon_loose ! "loose" = extrapolate 98 | bc_r%bcopt = bcon_loose 99 | 100 | !------------------------------ init. method workspace ! 101 | 102 | call work%init(npos+2*halo,nvar,opts) 103 | 104 | !------------------------------ calc. scalar transport ! 105 | 106 | qbar = init 107 | 108 | do step = +1, +100 ! 100 steps => full loop 109 | 110 | !------------------------------ periodicity via halo's ! 111 | 112 | qbar(1,:,il-halo:il-1) = & 113 | & qbar(1,:,ir-halo+1:ir) 114 | qbar(1,:,ir+1:ir+halo) = & 115 | & qbar(1,:,il:il+halo-1) 116 | 117 | !------------------------------ form lagrangian fluxes ! 118 | 119 | call ffsl1d (npos+2*halo,nvar, & 120 | & ndof,xdel,tDEL,mask,uvel, & 121 | & qbar,flux,bc_l,bc_r,work, & 122 | & opts) 123 | 124 | 125 | !------------------------------ flux divergence eval's ! 126 | qdiv( 1,il:ir) = & 127 | & flux(1,il+1:ir+1) & 128 | & - flux(1,il+0:ir+0) 129 | 130 | !------------------------------ take a single timestep ! 131 | 132 | qbar(1,1,il:ir) = & 133 | & qbar(1,1,il:ir) - & 134 | & qdiv(1,il:ir) / xdel(1) 135 | 136 | end do 137 | 138 | !------------------------------ clear method workspace ! 139 | 140 | call work%free() 141 | 142 | !------------------------------ dump results to stdout ! 143 | 144 | print*,"End timestep profile : " 145 | 146 | do ipos = il+0, ir-0 147 | 148 | print *, init(1,:,ipos) & 149 | & , qbar(1,:,ipos) 150 | 151 | end do 152 | 153 | print*,"Conservation defect := " & 154 | & , sum(init(1,:,il:ir)) & 155 | & - sum(qbar(1,:,il:ir)) 156 | 157 | end program 158 | 159 | 160 | 161 | -------------------------------------------------------------------------------- /src/rcon1d.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! RCON1D.f90: conservative, polynomial reconstructions. 31 | ! 32 | ! Darren Engwirda 33 | ! 07-Sep-2016 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | subroutine rcon1d(npos,nvar,ndof,delx,fdat, & 39 | & bclo,bchi,fhat,work,opts, & 40 | & tCPU) 41 | 42 | ! 43 | ! NPOS no. edges over grid. 44 | ! NVAR no. state variables. 45 | ! NDOF no. degrees-of-freedom per grid-cell. 46 | ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if 47 | ! spacing is uniform . 48 | ! FDAT grid-cell moments array. FDAT is an array with 49 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 50 | ! BCLO boundary condition at lower endpoint. 51 | ! BCHI boundary condition at upper endpoint. 52 | ! FHAT grid-cell re-con. array. FHAT is an array with 53 | ! SIZE = MDOF-by-NVAR-by-NPOS-1 . 54 | ! WORK method work-space. See RCON-WORK for details . 55 | ! OPTS method parameters. See RCON-OPTS for details . 56 | ! TCPU method tcpu-timer. 57 | ! 58 | 59 | implicit none 60 | 61 | !------------------------------------------- arguments ! 62 | integer, intent(in) :: npos,nvar,ndof 63 | class(rcon_work), intent(inout) :: work 64 | class(rcon_opts), intent(in) :: opts 65 | real(kind=dp) , intent(in) :: delx(:) 66 | real(kind=dp) , intent(out) :: fhat(:,:,:) 67 | real(kind=dp) , intent(in) :: fdat(:,:,:) 68 | type (rcon_ends), intent(in) :: bclo(:) 69 | type (rcon_ends), intent(in) :: bchi(:) 70 | type (rmap_tics), & 71 | & intent(inout) , optional :: tCPU 72 | 73 | !------------------------------------------- variables ! 74 | integer :: halo,ipos 75 | real(kind=dp) :: dmin,dmid 76 | 77 | # ifdef __PPR_TIMER__ 78 | integer(kind=8) :: ttic,ttoc,rate 79 | # endif 80 | 81 | if (ndof.lt.1) return 82 | if (npos.lt.2) return 83 | if (nvar.lt.1) return 84 | 85 | !-------------------------- compute min grid-tolerance ! 86 | 87 | dmid = delx(1) 88 | 89 | if (size(delx).gt.+1) then 90 | 91 | do ipos = 2, npos-1 92 | dmid = & 93 | & dmid + delx (ipos) 94 | end do 95 | 96 | dmid = dmid /(npos-1) 97 | 98 | end if 99 | 100 | dmin = +1.0d-14 * dmid 101 | 102 | !-------------------------- compute edge values/slopes ! 103 | 104 | __TIC__ 105 | 106 | if ( (opts%cell_meth.eq.ppm_method) & 107 | & .or. (opts%cell_meth.eq.pqm_method) ) then 108 | 109 | select case (opts%edge_meth) 110 | case(p1e_method) 111 | !------------------------------------ 2nd-order method ! 112 | halo = +1 113 | call p1e(npos,nvar,ndof, & 114 | & delx,fdat, & 115 | & bclo,bchi, & 116 | & work%edge_func, & 117 | & work%edge_dfdx, & 118 | & opts,dmin) 119 | 120 | case(p3e_method) 121 | !------------------------------------ 4th-order method ! 122 | halo = +2 123 | call p3e(npos,nvar,ndof, & 124 | & delx,fdat, & 125 | & bclo,bchi, & 126 | & work%edge_func, & 127 | & work%edge_dfdx, & 128 | & opts,dmin) 129 | 130 | case(p5e_method) 131 | !------------------------------------ 6th-order method ! 132 | halo = +3 133 | call p5e(npos,nvar,ndof, & 134 | & delx,fdat, & 135 | & bclo,bchi, & 136 | & work%edge_func, & 137 | & work%edge_dfdx, & 138 | & opts,dmin) 139 | 140 | end select 141 | 142 | end if 143 | 144 | __TOC__(tCPU,edge_time) 145 | 146 | !-------------------------- compute oscil. derivatives ! 147 | 148 | __TIC__ 149 | 150 | if (opts%cell_lims.eq.weno_limit) then 151 | 152 | call oscli(npos,nvar,ndof, & 153 | & delx,fdat, & 154 | & work%cell_oscl, & 155 | & dmin) 156 | 157 | end if 158 | 159 | __TOC__(tCPU,oscl_time) 160 | 161 | !-------------------------- compute grid-cell profiles ! 162 | 163 | __TIC__ 164 | 165 | select case (opts%cell_meth) 166 | case(pcm_method) 167 | !------------------------------------ 1st-order method ! 168 | call pcm(npos,nvar,ndof, & 169 | & fdat,fhat) 170 | 171 | case(plm_method) 172 | !------------------------------------ 2nd-order method ! 173 | call plm(npos,nvar,ndof, & 174 | & delx,fdat,fhat, & 175 | & opts%cell_lims) 176 | 177 | case(ppm_method) 178 | !------------------------------------ 3rd-order method ! 179 | call ppm(npos,nvar,ndof, & 180 | & delx,fdat,fhat, & 181 | & work%edge_func, & 182 | & work%cell_oscl, & 183 | & opts%cell_lims, & 184 | & opts%wall_lims, & 185 | & halo ) 186 | 187 | case(pqm_method) 188 | !------------------------------------ 5th-order method ! 189 | call pqm(npos,nvar,ndof, & 190 | & delx,fdat,fhat, & 191 | & work%edge_func, & 192 | & work%edge_dfdx, & 193 | & work%cell_oscl, & 194 | & opts%cell_lims, & 195 | & opts%wall_lims, & 196 | & halo ) 197 | 198 | end select 199 | 200 | __TOC__(tCPU,cell_time) 201 | 202 | end subroutine 203 | 204 | 205 | 206 | -------------------------------------------------------------------------------- /src/p1e.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! P1E.f90: set edge estimates via degree-1 polynomials. 31 | ! 32 | ! Darren Engwirda 33 | ! 25-Oct-2021 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | subroutine p1e(npos,nvar,ndof,delx, & 39 | & fdat,bclo,bchi,edge, & 40 | & dfdx,opts,dmin) 41 | 42 | ! 43 | ! NPOS no. edges over grid. 44 | ! NVAR no. state variables. 45 | ! NDOF no. degrees-of-freedom per grid-cell. 46 | ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if 47 | ! spacing is uniform . 48 | ! FDAT grid-cell moments array. FDAT is an array with 49 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 50 | ! BCLO boundary condition at lower endpoint. 51 | ! BCHI boundary condition at upper endpoint. 52 | ! EDGE edge-centred interp. for function-value. EDGE 53 | ! is an array with SIZE = NVAR-by-NPOS . 54 | ! DFDX edge-centred interp. for 1st-derivative. DFDX 55 | ! is an array with SIZE = NVAR-by-NPOS . 56 | ! OPTS method parameters. See RCON-OPTS for details . 57 | ! DMIN min. grid-cell spacing thresh . 58 | ! 59 | 60 | implicit none 61 | 62 | !------------------------------------------- arguments ! 63 | integer , intent(in) :: npos,nvar,ndof 64 | real(kind=dp) , intent(in) :: delx(:) 65 | real(kind=dp) , intent(in) :: fdat(:,:,:) 66 | type (rcon_ends), intent(in) :: bclo(:) 67 | type (rcon_ends), intent(in) :: bchi(:) 68 | real(kind=dp) , intent(out) :: edge(:,:) 69 | real(kind=dp) , intent(out) :: dfdx(:,:) 70 | real(kind=dp) , intent(in) :: dmin 71 | class(rcon_opts), intent(in) :: opts 72 | 73 | !------------------------------------------- variables ! 74 | integer :: ipos,ivar,bopt 75 | integer :: head,tail 76 | real(kind=dp) :: dd10 77 | real(kind=dp) :: delh(-1:+0) 78 | 79 | head = +2; tail = npos-1 80 | 81 | if (npos.lt.2) return 82 | if (npos.eq.2) then 83 | !----- default to reduced order if insufficient points ! 84 | do ivar = 1,nvar 85 | 86 | edge(ivar,1) = fdat(1,ivar,1) 87 | dfdx(ivar,1) = 0.d0 88 | 89 | edge(ivar,2) = fdat(1,ivar,1) 90 | dfdx(ivar,2) = 0.d0 91 | 92 | end do 93 | end if 94 | 95 | if (ndof.le.0) return 96 | if (npos.le.2) return 97 | 98 | if (opts%edge_meth & 99 | & .lt.p1e_method) return 100 | 101 | ! Reconstruct edge-centred 2nd-order polynomials. Com- ! 102 | ! pute values/slopes at edges directly. Full-order ex- ! 103 | ! trapolation at endpoints. 104 | 105 | if (size(delx).eq.+1) then 106 | 107 | do ipos = head , tail 108 | 109 | !--------------- reconstruction: constant grid-spacing ! 110 | 111 | dd10 = delx(+1) * 2.d0 112 | 113 | do ivar = +1, nvar 114 | 115 | edge(ivar,ipos) = & 116 | & + delx(+1) * & 117 | & fdat(1,ivar,ipos-1) & 118 | & + delx(+1) * & 119 | & fdat(1,ivar,ipos+0) 120 | 121 | dfdx(ivar,ipos) = & 122 | & - 2.00d+00 * & 123 | & fdat(1,ivar,ipos-1) & 124 | & + 2.00d+00 * & 125 | & fdat(1,ivar,ipos+0) 126 | 127 | edge(ivar,ipos) = & 128 | & edge(ivar,ipos) / dd10 129 | dfdx(ivar,ipos) = & 130 | & dfdx(ivar,ipos) / dd10 131 | 132 | end do 133 | 134 | end do 135 | 136 | else 137 | 138 | do ipos = head , tail 139 | 140 | !--------------- reconstruction: variable grid-spacing ! 141 | 142 | delh(-1) = & 143 | & max(delx(ipos-1),dmin) 144 | delh(+0) = & 145 | & max(delx(ipos+0),dmin) 146 | 147 | dd10 = delh(-1)+delh(+0) 148 | 149 | do ivar = +1, nvar 150 | 151 | edge(ivar,ipos) = & 152 | & + delh(+0) * & 153 | & fdat(1,ivar,ipos-1) & 154 | & + delh(-1) * & 155 | & fdat(1,ivar,ipos+0) 156 | 157 | dfdx(ivar,ipos) = & 158 | & - 2.00d+00 * & 159 | & fdat(1,ivar,ipos-1) & 160 | & + 2.00d+00 * & 161 | & fdat(1,ivar,ipos+0) 162 | 163 | edge(ivar,ipos) = & 164 | & edge(ivar,ipos) / dd10 165 | dfdx(ivar,ipos) = & 166 | & dfdx(ivar,ipos) / dd10 167 | 168 | end do 169 | 170 | end do 171 | 172 | end if 173 | 174 | !------------- 1st-order value/slope BC's at endpoints ! 175 | 176 | do ivar = +1, nvar 177 | 178 | !------------------------------------- at LHS endpoint ! 179 | 180 | bopt = bclo(ivar)%bcopt 181 | dd10 = 1.d0 182 | 183 | if (bopt.eq.bcon_loose) then 184 | 185 | edge(ivar,head-1) = & 186 | & fdat(+1,ivar,head-1) 187 | 188 | dfdx(ivar,head-1) = 0.d0 189 | 190 | else & 191 | & if (bopt.eq.bcon_value) then 192 | 193 | edge(ivar,head-1) = & 194 | & bclo(ivar)%value 195 | 196 | dfdx(ivar,head-1) = 0.d0 197 | 198 | else & 199 | & if (bopt.eq.bcon_slope) then 200 | 201 | edge(ivar,head-1) = & 202 | & fdat(+1,ivar,head-1) 203 | 204 | dfdx(ivar,head-1) = & 205 | & bclo(ivar)%slope * dd10 206 | 207 | end if 208 | 209 | !------------------------------------- at RHS endpoint ! 210 | 211 | bopt = bchi(ivar)%bcopt 212 | dd10 = 1.d0 213 | 214 | if (bopt.eq.bcon_loose) then 215 | 216 | edge(ivar,tail+1) = & 217 | & fdat(+1,ivar,tail+0) 218 | 219 | dfdx(ivar,tail+1) = 0.d0 220 | 221 | else & 222 | & if (bopt.eq.bcon_value) then 223 | 224 | edge(ivar,tail+1) = & 225 | & bchi(ivar)%value 226 | 227 | dfdx(ivar,tail+1) = 0.d0 228 | 229 | else & 230 | & if (bopt.eq.bcon_slope) then 231 | 232 | edge(ivar,tail+1) = & 233 | & fdat(+1,ivar,tail+0) 234 | 235 | dfdx(ivar,tail+1) = & 236 | & bchi(ivar)%slope * dd10 237 | 238 | end if 239 | 240 | end do 241 | 242 | return 243 | 244 | end subroutine 245 | 246 | 247 | 248 | -------------------------------------------------------------------------------- /src/bfun1d.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! BFUN1D.f90: poly. basis-functions for reconstruction. 31 | ! 32 | ! Darren Engwirda 33 | ! 07-Sep-2016 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | pure subroutine bfun1d(isel,ndof,sval,bfun) 39 | 40 | ! 41 | ! ISEL basis-function "order", -1 => integral-basis , 42 | ! +0 => function-basis, +1 => 1st deriv.-basis , 43 | ! +2 => 2nd deriv.-basis. 44 | ! NDOF no. degrees-of-freedom in basis. 45 | ! SVAL local coord. at which to evaluate basis-func., 46 | ! such that -1.0 <= SVAL <= +1.0 . 47 | ! BFUN basis-vector evaluated at SVAL . 48 | ! 49 | 50 | implicit none 51 | 52 | !------------------------------------------- arguments ! 53 | integer , intent(in) :: isel,ndof 54 | real(kind=dp), intent(in) :: sval 55 | real(kind=dp), intent(out) :: bfun(:) 56 | 57 | select case (isel) 58 | case (-1) 59 | !------------------------------------ -1th-order basis ! 60 | select case (ndof) 61 | case (+1) 62 | bfun(1) = sval**1 / 1.d0 63 | 64 | case (+2) 65 | bfun(1) = sval**1 / 1.d0 66 | bfun(2) = sval**2 / 2.d0 67 | 68 | case (+3) 69 | bfun(1) = sval**1 / 1.d0 70 | bfun(2) = sval**2 / 2.d0 71 | bfun(3) = sval**3 / 3.d0 72 | 73 | case (+4) 74 | bfun(1) = sval**1 / 1.d0 75 | bfun(2) = sval**2 / 2.d0 76 | bfun(3) = sval**3 / 3.d0 77 | bfun(4) = sval**4 / 4.d0 78 | 79 | case (+5) 80 | bfun(1) = sval**1 / 1.d0 81 | bfun(2) = sval**2 / 2.d0 82 | bfun(3) = sval**3 / 3.d0 83 | bfun(4) = sval**4 / 4.d0 84 | bfun(5) = sval**5 / 5.d0 85 | 86 | case (+6) 87 | bfun(1) = sval**1 / 1.d0 88 | bfun(2) = sval**2 / 2.d0 89 | bfun(3) = sval**3 / 3.d0 90 | bfun(4) = sval**4 / 4.d0 91 | bfun(5) = sval**5 / 5.d0 92 | bfun(6) = sval**6 / 6.d0 93 | 94 | case (+7) 95 | bfun(1) = sval**1 / 1.d0 96 | bfun(2) = sval**2 / 2.d0 97 | bfun(3) = sval**3 / 3.d0 98 | bfun(4) = sval**4 / 4.d0 99 | bfun(5) = sval**5 / 5.d0 100 | bfun(6) = sval**6 / 6.d0 101 | bfun(7) = sval**7 / 7.d0 102 | 103 | end select 104 | 105 | case (+0) 106 | !------------------------------------ +0th-order basis ! 107 | select case (ndof) 108 | case (+1) 109 | bfun(1) = 1.d0 110 | 111 | case (+2) 112 | bfun(1) = 1.d0 113 | bfun(2) = sval**1 * 1.d0 114 | 115 | case (+3) 116 | bfun(1) = 1.d0 117 | bfun(2) = sval**1 * 1.d0 118 | bfun(3) = sval**2 * 1.d0 119 | 120 | case (+4) 121 | bfun(1) = 1.d0 122 | bfun(2) = sval**1 * 1.d0 123 | bfun(3) = sval**2 * 1.d0 124 | bfun(4) = sval**3 * 1.d0 125 | 126 | case (+5) 127 | bfun(1) = 1.d0 128 | bfun(2) = sval**1 * 1.d0 129 | bfun(3) = sval**2 * 1.d0 130 | bfun(4) = sval**3 * 1.d0 131 | bfun(5) = sval**4 * 1.d0 132 | 133 | case (+6) 134 | bfun(1) = 1.d0 135 | bfun(2) = sval**1 * 1.d0 136 | bfun(3) = sval**2 * 1.d0 137 | bfun(4) = sval**3 * 1.d0 138 | bfun(5) = sval**4 * 1.d0 139 | bfun(6) = sval**5 * 1.d0 140 | 141 | case (+7) 142 | bfun(1) = 1.d0 143 | bfun(2) = sval**1 * 1.d0 144 | bfun(3) = sval**2 * 1.d0 145 | bfun(4) = sval**3 * 1.d0 146 | bfun(5) = sval**4 * 1.d0 147 | bfun(6) = sval**5 * 1.d0 148 | bfun(7) = sval**6 * 1.d0 149 | 150 | end select 151 | 152 | case (+1) 153 | !------------------------------------ +1st-order basis ! 154 | select case (ndof) 155 | case (+1) 156 | bfun(1) = 0.d0 157 | 158 | case (+2) 159 | bfun(1) = 0.d0 160 | bfun(2) = 1.d0 161 | 162 | case (+3) 163 | bfun(1) = 0.d0 164 | bfun(2) = 1.d0 165 | bfun(3) = sval**1 * 2.d0 166 | 167 | case (+4) 168 | bfun(1) = 0.d0 169 | bfun(2) = 1.d0 170 | bfun(3) = sval**1 * 2.d0 171 | bfun(4) = sval**2 * 3.d0 172 | 173 | case (+5) 174 | bfun(1) = 0.d0 175 | bfun(2) = 1.d0 176 | bfun(3) = sval**1 * 2.d0 177 | bfun(4) = sval**2 * 3.d0 178 | bfun(5) = sval**3 * 4.d0 179 | 180 | case (+6) 181 | bfun(1) = 0.d0 182 | bfun(2) = 1.d0 183 | bfun(3) = sval**1 * 2.d0 184 | bfun(4) = sval**2 * 3.d0 185 | bfun(5) = sval**3 * 4.d0 186 | bfun(6) = sval**4 * 5.d0 187 | 188 | case (+7) 189 | bfun(1) = 0.d0 190 | bfun(2) = 1.d0 191 | bfun(3) = sval**1 * 2.d0 192 | bfun(4) = sval**2 * 3.d0 193 | bfun(5) = sval**3 * 4.d0 194 | bfun(6) = sval**4 * 5.d0 195 | bfun(7) = sval**5 * 6.d0 196 | 197 | end select 198 | 199 | case (+2) 200 | !------------------------------------ +2nd-order basis ! 201 | select case (ndof) 202 | case (+1) 203 | bfun(1) = 0.d0 204 | 205 | case (+2) 206 | bfun(1) = 0.d0 207 | bfun(2) = 0.d0 208 | 209 | case (+3) 210 | bfun(1) = 0.d0 211 | bfun(2) = 0.d0 212 | bfun(3) = 2.d0 213 | 214 | case (+4) 215 | bfun(1) = 0.d0 216 | bfun(2) = 0.d0 217 | bfun(3) = 2.d0 218 | bfun(4) = sval**1 * 6.d0 219 | 220 | case (+5) 221 | bfun(1) = 0.d0 222 | bfun(2) = 0.d0 223 | bfun(3) = 2.d0 224 | bfun(4) = sval**1 * 6.d0 225 | bfun(5) = sval**2 *12.d0 226 | 227 | case (+6) 228 | bfun(1) = 0.d0 229 | bfun(2) = 0.d0 230 | bfun(3) = 2.d0 231 | bfun(4) = sval**1 * 6.d0 232 | bfun(5) = sval**2 *12.d0 233 | bfun(6) = sval**3 *20.d0 234 | 235 | case (+7) 236 | bfun(1) = 0.d0 237 | bfun(2) = 0.d0 238 | bfun(3) = 2.d0 239 | bfun(4) = sval**1 * 6.d0 240 | bfun(5) = sval**2 *12.d0 241 | bfun(6) = sval**3 *20.d0 242 | bfun(7) = sval**4 *30.d0 243 | 244 | end select 245 | 246 | end select 247 | 248 | end subroutine 249 | 250 | 251 | 252 | -------------------------------------------------------------------------------- /src/p3e.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! P3E.f90: set edge estimates via degree-3 polynomials. 31 | ! 32 | ! Darren Engwirda 33 | ! 09-Sep-2016 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | subroutine p3e(npos,nvar,ndof,delx, & 39 | & fdat,bclo,bchi,edge, & 40 | & dfdx,opts,dmin) 41 | 42 | ! 43 | ! NPOS no. edges over grid. 44 | ! NVAR no. state variables. 45 | ! NDOF no. degrees-of-freedom per grid-cell. 46 | ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if 47 | ! spacing is uniform . 48 | ! FDAT grid-cell moments array. FDAT is an array with 49 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 50 | ! BCLO boundary condition at lower endpoint. 51 | ! BCHI boundary condition at upper endpoint. 52 | ! EDGE edge-centred interp. for function-value. EDGE 53 | ! is an array with SIZE = NVAR-by-NPOS . 54 | ! DFDX edge-centred interp. for 1st-derivative. DFDX 55 | ! is an array with SIZE = NVAR-by-NPOS . 56 | ! OPTS method parameters. See RCON-OPTS for details . 57 | ! DMIN min. grid-cell spacing thresh . 58 | ! 59 | 60 | implicit none 61 | 62 | !------------------------------------------- arguments ! 63 | integer , intent(in) :: npos,nvar,ndof 64 | real(kind=dp) , intent(in) :: delx(:) 65 | real(kind=dp) , intent(in) :: fdat(:,:,:) 66 | type (rcon_ends), intent(in) :: bclo(:) 67 | type (rcon_ends), intent(in) :: bchi(:) 68 | real(kind=dp) , intent(out) :: edge(:,:) 69 | real(kind=dp) , intent(out) :: dfdx(:,:) 70 | real(kind=dp) , intent(in) :: dmin 71 | class(rcon_opts), intent(in) :: opts 72 | 73 | !------------------------------------------- variables ! 74 | integer :: ipos,ivar,idof 75 | integer :: head,tail 76 | logical :: okay 77 | real(kind=dp) :: xhat,fEPS 78 | real(kind=dp) :: delh(-2:+1) 79 | real(kind=dp) :: xmap(-2:+2) 80 | real(kind=dp) :: fhat(+4, nvar) 81 | real(kind=dp) :: ivec(+4,-2:+2) 82 | real(kind=dp) :: cmat(+4,+4) 83 | 84 | integer , parameter :: NSIZ = +4 85 | real(kind=dp), parameter :: ZERO = +1.d-14 86 | 87 | head = +3 ; tail = npos - 2 88 | 89 | if (npos.le.4) then 90 | !----- default to reduced order if insufficient points ! 91 | call p1e (npos,nvar,ndof, & 92 | & delx,fdat,bclo, & 93 | & bchi,edge,dfdx, & 94 | & opts,dmin) 95 | end if 96 | 97 | if (ndof.le.0) return 98 | if (npos.le.4) return 99 | 100 | !------ impose value/slope B.C.'s about lower endpoint ! 101 | 102 | call pbc(npos,nvar,ndof,delx, & 103 | & fdat,bclo,edge,dfdx, & 104 | & -1 ,dmin) 105 | 106 | !------ impose value/slope B.C.'s about upper endpoint ! 107 | 108 | call pbc(npos,nvar,ndof,delx, & 109 | & fdat,bchi,edge,dfdx, & 110 | & +1 ,dmin) 111 | 112 | ! Reconstruct edge-centred 4th-order polynomials. Com- ! 113 | ! pute values/slopes at edges directly. Mid.-order ex- ! 114 | ! trapolation at endpoints. ! 115 | 116 | if (size(delx).eq.+1) then 117 | 118 | do ipos = head , tail 119 | 120 | !--------------- reconstruction: constant grid-spacing ! 121 | 122 | do ivar = 1, nvar 123 | 124 | edge(ivar,ipos) = ( & 125 | & - 1.d0 * & 126 | & fdat(1,ivar,ipos-2) & 127 | & + 7.d0 * & 128 | & fdat(1,ivar,ipos-1) & 129 | & + 7.d0 * & 130 | & fdat(1,ivar,ipos+0) & 131 | & - 1.d0 * & 132 | & fdat(1,ivar,ipos+1) ) / 12.d0 133 | 134 | dfdx(ivar,ipos) = ( & 135 | & + 1.d0 * & 136 | & fdat(1,ivar,ipos-2) & 137 | & - 15.d0 * & 138 | & fdat(1,ivar,ipos-1) & 139 | & + 15.d0 * & 140 | & fdat(1,ivar,ipos+0) & 141 | & - 1.d0 * & 142 | & fdat(1,ivar,ipos+1) ) / 12.d0 143 | 144 | dfdx(ivar,ipos) = & 145 | & dfdx(ivar,ipos) / delx(+1) 146 | 147 | end do 148 | 149 | end do 150 | 151 | else 152 | 153 | fEPS = ZERO * dmin 154 | 155 | do ipos = head , tail 156 | 157 | !--------------- reconstruction: variable grid-spacing ! 158 | 159 | delh(-2) = delx(ipos-2) 160 | delh(-1) = delx(ipos-1) 161 | delh(+0) = delx(ipos+0) 162 | delh(+1) = delx(ipos+1) 163 | 164 | xhat = .5d0 * max(delh(-1),dmin) + & 165 | & .5d0 * max(delh(+0),dmin) 166 | 167 | xmap(-2) = -( delh(-2) & 168 | & + delh(-1) ) / xhat 169 | xmap(-1) = - delh(-1) / xhat 170 | xmap(+0) = + 0.d0 171 | xmap(+1) = + delh(+0) / xhat 172 | xmap(+2) = +( delh(+0) & 173 | & + delh(+1) ) / xhat 174 | 175 | !--------------------------- calc. integral basis vec. ! 176 | 177 | do idof = -2, +2 178 | 179 | ivec(1,idof) = & 180 | & xmap(idof) ** 1 / 1.0d+0 181 | ivec(2,idof) = & 182 | & xmap(idof) ** 2 / 2.0d+0 183 | ivec(3,idof) = & 184 | & xmap(idof) ** 3 / 3.0d+0 185 | ivec(4,idof) = & 186 | & xmap(idof) ** 4 / 4.0d+0 187 | 188 | end do 189 | 190 | !--------------------------- linear system: lhs matrix ! 191 | 192 | do idof = +1, +4 193 | 194 | cmat(1,idof) = ivec(idof,-1) & 195 | & - ivec(idof,-2) 196 | cmat(2,idof) = ivec(idof,+0) & 197 | & - ivec(idof,-1) 198 | cmat(3,idof) = ivec(idof,+1) & 199 | & - ivec(idof,+0) 200 | cmat(4,idof) = ivec(idof,+2) & 201 | & - ivec(idof,+1) 202 | 203 | end do 204 | 205 | !--------------------------- linear system: rhs vector ! 206 | 207 | do ivar = +1, nvar 208 | 209 | fhat(+1,ivar) = & 210 | & delx(ipos-2) * & 211 | & fdat(+1,ivar,ipos-2) / xhat 212 | fhat(+2,ivar) = & 213 | & delx(ipos-1) * & 214 | & fdat(+1,ivar,ipos-1) / xhat 215 | fhat(+3,ivar) = & 216 | & delx(ipos+0) * & 217 | & fdat(+1,ivar,ipos+0) / xhat 218 | fhat(+4,ivar) = & 219 | & delx(ipos+1) * & 220 | & fdat(+1,ivar,ipos+1) / xhat 221 | 222 | end do 223 | 224 | !------------------------- factor/solve linear systems ! 225 | 226 | call slv_4x4(cmat,NSIZ,fhat, & 227 | & NSIZ,nvar,fEPS, & 228 | & okay) 229 | 230 | if (okay .eqv. .true.) then 231 | 232 | do ivar = +1, nvar 233 | 234 | edge(ivar,ipos) = fhat(1,ivar) 235 | 236 | dfdx(ivar,ipos) = fhat(2,ivar) & 237 | & / xhat 238 | 239 | end do 240 | 241 | else 242 | 243 | !------------------------- fallback if system singular ! 244 | 245 | # ifdef __PPR_PIVOT__ 246 | 247 | write(*,*) & 248 | & "WARNING::P3E - matrix-is-singular!" 249 | 250 | # endif 251 | 252 | do ivar = +1, nvar 253 | 254 | edge(ivar,ipos) = & 255 | & fdat(1,ivar,ipos-1) * 0.5d+0 + & 256 | & fdat(1,ivar,ipos-0) * 0.5d+0 257 | 258 | dfdx(ivar,ipos) = & 259 | & fdat(1,ivar,ipos-0) * 1.0d+0 - & 260 | & fdat(1,ivar,ipos-1) * 1.0d+0 261 | 262 | dfdx(ivar,ipos) = & 263 | & dfdx(ivar,ipos) / xhat 264 | 265 | end do 266 | 267 | end if 268 | 269 | end do 270 | 271 | end if 272 | 273 | return 274 | 275 | end subroutine 276 | 277 | 278 | 279 | -------------------------------------------------------------------------------- /src/oscl1d.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! OSCL1D.f90: "oscillation-indicators" for WENO interp. 31 | ! 32 | ! Darren Engwirda 33 | ! 25-Oct-2021 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | pure subroutine oscli (npos,nvar,ndof,delx,& 39 | & fdat,oscl,dmin) 40 | 41 | ! 42 | ! NPOS no. edges over grid. 43 | ! NVAR no. state variables. 44 | ! NDOF no. degrees-of-freedom per grid-cell . 45 | ! DELX (constant) grid-cell spacing. LENGTH(DELX)==+1 . 46 | ! FDAT grid-cell moments array. FDAT is an array with 47 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 48 | ! OSCL grid-cell oscil. dof.'s. OSCL is an array with 49 | ! SIZE = +2 -by-NVAR-by-NPOS-1 . 50 | ! DMIN min. grid-cell spacing thresh . 51 | ! 52 | 53 | implicit none 54 | 55 | !------------------------------------------- arguments ! 56 | integer , intent(in) :: npos,nvar,ndof 57 | real(kind=dp), intent(in) :: dmin 58 | real(kind=dp), intent(in) :: delx(:) 59 | real(kind=dp), intent(in) :: fdat(:,:,:) 60 | real(kind=dp), intent(out) :: oscl(:,:,:) 61 | 62 | !------------------------------------------- variables ! 63 | integer :: ivar,ipos 64 | 65 | if (npos.lt.3) then 66 | !------------------------------- at least 3 grid-cells ! 67 | do ipos = +1, npos-1 68 | do ivar = +1, nvar-0 69 | oscl(1,ivar,ipos) = +0.d0 70 | oscl(2,ivar,ipos) = +0.d0 71 | end do 72 | end do 73 | end if 74 | 75 | if (npos.lt.3) return 76 | if (nvar.lt.1) return 77 | if (ndof.lt.1) return 78 | 79 | if (size(delx).gt.+1) then 80 | 81 | !------------------------------- variable grid-spacing ! 82 | 83 | call osclv(npos,nvar,ndof,delx,dmin, & 84 | & fdat,oscl) 85 | 86 | else 87 | 88 | !------------------------------- constant grid-spacing ! 89 | 90 | call osclc(npos,nvar,ndof,fdat,oscl) 91 | 92 | end if 93 | 94 | return 95 | 96 | end subroutine 97 | 98 | pure subroutine osclv (npos,nvar,ndof,delx,& 99 | & dmin,fdat,oscl) 100 | 101 | ! 102 | ! *this is the variable grid-spacing variant . 103 | ! 104 | ! NPOS no. edges over grid. 105 | ! NVAR no. state variables. 106 | ! NDOF no. degrees-of-freedom per grid-cell . 107 | ! DELX (variable) grid-cell spacing. LENGTH(DELX)!=+1 . 108 | ! FDAT grid-cell moments array. FDAT is an array with 109 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 110 | ! OSCL grid-cell oscil. dof.'s. OSCL is an array with 111 | ! SIZE = +2 -by-NVAR-by-NPOS-1 . 112 | ! DMIN min. grid-cell spacing thresh . 113 | ! 114 | 115 | implicit none 116 | 117 | !------------------------------------------- arguments ! 118 | integer , intent(in) :: npos,nvar,ndof 119 | real(kind=dp), intent(in) :: dmin 120 | real(kind=dp), intent(in) :: delx(:) 121 | real(kind=dp), intent(in) :: fdat(:,:,:) 122 | real(kind=dp), intent(out) :: oscl(:,:,:) 123 | 124 | !------------------------------------------- variables ! 125 | integer :: head,tail 126 | integer :: ipos,ivar 127 | real(kind=dp) :: hhll,hhcc,hhrr 128 | real(kind=dp) :: hhmm,hhrc,hhlc 129 | real(kind=dp) :: cmat(+2,+3) 130 | 131 | !--------------------------------------- centred point ! 132 | 133 | head = +1 ; tail = npos-1 134 | 135 | if (ndof.lt.1) return 136 | 137 | do ipos = head+1, tail-1 138 | 139 | hhll = max(delx(ipos-1),dmin) 140 | hhcc = max(delx(ipos+0),dmin) 141 | hhrr = max(delx(ipos+1),dmin) 142 | 143 | hhrc = hhrr + hhcc 144 | hhlc = hhll + hhcc 145 | hhmm = hhll + hhcc + hhrr 146 | 147 | cmat(1,1) = -(hhcc+2.d0*hhrr)/(hhlc*hhmm) 148 | cmat(1,2) = -(hhll-hhrr)* & 149 | & (3.d0*hhcc+2.d0*(hhll+hhrr))/& 150 | & (hhlc*hhrc*hhmm) 151 | cmat(1,3) = +(hhcc+2.d0*hhll)/(hhrc*hhmm) 152 | 153 | cmat(2,1) = +3.d0/(hhlc*hhmm) 154 | cmat(2,2) = -3.d0*(2.d0*hhcc+hhll+hhrr)/& 155 | & (hhlc*hhrc*hhmm) 156 | cmat(2,3) = +3.d0/(hhrc*hhmm) 157 | 158 | do ivar = 1, nvar 159 | 160 | oscl(1,ivar,ipos) = +1.d0 * ( & 161 | & + cmat(1,1)*fdat(1,ivar,ipos-1) & 162 | & + cmat(1,2)*fdat(1,ivar,ipos+0) & 163 | & + cmat(1,3)*fdat(1,ivar,ipos+1) ) 164 | 165 | oscl(2,ivar,ipos) = +2.d0 * ( & 166 | & + cmat(2,1)*fdat(1,ivar,ipos-1) & 167 | & + cmat(2,2)*fdat(1,ivar,ipos+0) & 168 | & + cmat(2,3)*fdat(1,ivar,ipos+1) ) 169 | 170 | end do 171 | 172 | end do 173 | 174 | !-------------------------------------- lower endpoint ! 175 | 176 | hhll = max(delx(head+0),dmin) 177 | hhcc = max(delx(head+1),dmin) 178 | hhrr = max(delx(head+2),dmin) 179 | 180 | cmat(1,1) = -2.d0 / (hhll+hhcc) 181 | cmat(1,2) = +2.d0 / (hhll+hhcc) 182 | 183 | do ivar = 1, nvar 184 | 185 | oscl(1,ivar,head) = & 186 | & + cmat(1,1)*fdat(1,ivar,head+0) & 187 | & + cmat(1,2)*fdat(1,ivar,head+1) 188 | 189 | oscl(2,ivar,head) = +0.d0 190 | 191 | end do 192 | 193 | !-------------------------------------- upper endpoint ! 194 | 195 | hhll = max(delx(tail-2),dmin) 196 | hhcc = max(delx(tail-1),dmin) 197 | hhrr = max(delx(tail-0),dmin) 198 | 199 | cmat(1,2) = -2.d0 / (hhrr+hhcc) 200 | cmat(1,3) = +2.d0 / (hhrr+hhcc) 201 | 202 | do ivar = 1, nvar 203 | 204 | oscl(1,ivar,tail) = & 205 | & + cmat(1,2)*fdat(1,ivar,tail-1) & 206 | & + cmat(1,3)*fdat(1,ivar,tail+0) 207 | 208 | oscl(2,ivar,tail) = +0.d0 209 | 210 | end do 211 | 212 | return 213 | 214 | end subroutine 215 | 216 | pure subroutine osclc (npos,nvar,ndof,fdat,oscl) 217 | 218 | ! 219 | ! *this is the constant grid-spacing variant . 220 | ! 221 | ! NPOS no. edges over grid. 222 | ! NVAR no. state variables. 223 | ! NDOF no. degrees-of-freedom per grid-cell . 224 | ! DELX (constant) grid-cell spacing. LENGTH(DELX)==+1 . 225 | ! FDAT grid-cell moments array. FDAT is an array with 226 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 227 | ! OSCL grid-cell oscil. dof.'s. OSCL is an array with 228 | ! SIZE = +2 -by-NVAR-by-NPOS-1 . 229 | ! DMIN min. grid-cell spacing thresh . 230 | ! 231 | 232 | implicit none 233 | 234 | !------------------------------------------- arguments ! 235 | integer , intent( in) :: npos,nvar,ndof 236 | real(kind=dp), intent( in) :: fdat(:,:,:) 237 | real(kind=dp), intent(out) :: oscl(:,:,:) 238 | 239 | !------------------------------------------- variables ! 240 | integer :: head,tail,ipos,ivar 241 | 242 | !-------------------------------------- centred points ! 243 | 244 | head = +1; tail = npos - 1 245 | 246 | if (ndof.lt.1) return 247 | 248 | do ipos = 2, npos-2 249 | do ivar = 1, nvar-0 250 | 251 | oscl(1,ivar,ipos) = & 252 | & + .25d+0 * fdat(1,ivar,ipos+1) & 253 | & - .25d+0 * fdat(1,ivar,ipos-1) 254 | 255 | oscl(2,ivar,ipos) = & 256 | & + .25d+0 * fdat(1,ivar,ipos+1) & 257 | & - .50d+0 * fdat(1,ivar,ipos+0) & 258 | & + .25d+0 * fdat(1,ivar,ipos-1) 259 | 260 | end do 261 | end do 262 | 263 | !-------------------------------------- lower endpoint ! 264 | 265 | do ivar = 1, nvar 266 | 267 | oscl(1,ivar,head) = & 268 | & + .50d+0 * fdat(1,ivar,head+1) & 269 | & - .50d+0 * fdat(1,ivar,head+0) 270 | 271 | oscl(2,ivar,head) = +0.d0 272 | 273 | end do 274 | 275 | !-------------------------------------- upper endpoint ! 276 | 277 | do ivar = 1, nvar 278 | 279 | oscl(1,ivar,tail) = & 280 | & + .50d+0 * fdat(1,ivar,tail+0) & 281 | & - .50d+0 * fdat(1,ivar,tail-1) 282 | 283 | oscl(2,ivar,tail) = +0.d0 284 | 285 | end do 286 | 287 | return 288 | 289 | end subroutine 290 | 291 | 292 | 293 | -------------------------------------------------------------------------------- /src/p5e.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! P5E.f90: set edge estimates via degree-5 polynomials. 31 | ! 32 | ! Darren Engwirda 33 | ! 25-Mar-2019 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | subroutine p5e(npos,nvar,ndof,delx, & 39 | & fdat,bclo,bchi,edge, & 40 | & dfdx,opts,dmin) 41 | 42 | ! 43 | ! NPOS no. edges over grid. 44 | ! NVAR no. state variables. 45 | ! NDOF no. degrees-of-freedom per grid-cell. 46 | ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if 47 | ! spacing is uniform . 48 | ! FDAT grid-cell moments array. FDAT is an array with 49 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 50 | ! BCLO boundary condition at lower endpoint. 51 | ! BCHI boundary condition at upper endpoint. 52 | ! EDGE edge-centred interp. for function-value. EDGE 53 | ! is an array with SIZE = NVAR-by-NPOS . 54 | ! DFDX edge-centred interp. for 1st-derivative. DFDX 55 | ! is an array with SIZE = NVAR-by-NPOS . 56 | ! OPTS method parameters. See RCON-OPTS for details . 57 | ! DMIN min. grid-cell spacing thresh . 58 | ! 59 | 60 | implicit none 61 | 62 | !------------------------------------------- arguments ! 63 | integer , intent(in) :: npos,nvar,ndof 64 | real(kind=dp) , intent(in) :: delx(:) 65 | real(kind=dp) , intent(in) :: fdat(:,:,:) 66 | type (rcon_ends), intent(in) :: bclo(:) 67 | type (rcon_ends), intent(in) :: bchi(:) 68 | real(kind=dp) , intent(out) :: edge(:,:) 69 | real(kind=dp) , intent(out) :: dfdx(:,:) 70 | real(kind=dp) , intent(in) :: dmin 71 | class(rcon_opts), intent(in) :: opts 72 | 73 | !------------------------------------------- variables ! 74 | integer :: ipos,ivar,idof 75 | integer :: head,tail 76 | logical :: okay 77 | real(kind=dp) :: xhat,fEPS 78 | real(kind=dp) :: delh(-3:+2) 79 | real(kind=dp) :: xmap(-3:+3) 80 | real(kind=dp) :: fhat(+6, nvar) 81 | real(kind=dp) :: ivec(+6,-3:+3) 82 | real(kind=dp) :: cmat(+6,+6) 83 | 84 | integer , parameter :: NSIZ = +6 85 | real(kind=dp), parameter :: ZERO = +1.d-14 86 | 87 | head = +4 ; tail = npos - 3 88 | 89 | if (npos.le.6) then 90 | !----- default to reduced order if insufficient points ! 91 | call p3e (npos,nvar,ndof, & 92 | & delx,fdat,bclo, & 93 | & bchi,edge,dfdx, & 94 | & opts,dmin) 95 | end if 96 | 97 | if (ndof.le.0) return 98 | if (npos.le.6) return 99 | 100 | !------ impose value/slope B.C.'s about lower endpoint ! 101 | 102 | call pbc(npos,nvar,ndof,delx, & 103 | & fdat,bclo,edge,dfdx, & 104 | & -1 ,dmin) 105 | 106 | !------ impose value/slope B.C.'s about upper endpoint ! 107 | 108 | call pbc(npos,nvar,ndof,delx, & 109 | & fdat,bchi,edge,dfdx, & 110 | & +1 ,dmin) 111 | 112 | ! Reconstruct edge-centred 6th-order polynomials. Com- ! 113 | ! pute values/slopes at edges directly. Mid.-order ex- ! 114 | ! trapolation at endpoints. ! 115 | 116 | if (size(delx).eq.+1) then 117 | 118 | do ipos = head , tail 119 | 120 | !--------------- reconstruction: constant grid-spacing ! 121 | 122 | do ivar = 1, nvar 123 | 124 | edge(ivar,ipos) = & 125 | & + ( 1.d+0 / 60.d+0) * & 126 | & fdat(1,ivar,ipos-3) & 127 | & - ( 8.d+0 / 60.d+0) * & 128 | & fdat(1,ivar,ipos-2) & 129 | & + (37.d+0 / 60.d+0) * & 130 | & fdat(1,ivar,ipos-1) & 131 | & + (37.d+0 / 60.d+0) * & 132 | & fdat(1,ivar,ipos+0) & 133 | & - ( 8.d+0 / 60.d+0) * & 134 | & fdat(1,ivar,ipos+1) & 135 | & + ( 1.d+0 / 60.d+0) * & 136 | & fdat(1,ivar,ipos+2) 137 | 138 | dfdx(ivar,ipos) = & 139 | & - ( 1.d+0 / 90.d+0) * & 140 | & fdat(1,ivar,ipos-3) & 141 | & + ( 5.d+0 / 36.d+0) * & 142 | & fdat(1,ivar,ipos-2) & 143 | & - (49.d+0 / 36.d+0) * & 144 | & fdat(1,ivar,ipos-1) & 145 | & + (49.d+0 / 36.d+0) * & 146 | & fdat(1,ivar,ipos+0) & 147 | & - ( 5.d+0 / 36.d+0) * & 148 | & fdat(1,ivar,ipos+1) & 149 | & + ( 1.d+0 / 90.d+0) * & 150 | & fdat(1,ivar,ipos+2) 151 | 152 | dfdx(ivar,ipos) = & 153 | dfdx(ivar,ipos) / delx(+1) 154 | 155 | end do 156 | 157 | end do 158 | 159 | else 160 | 161 | fEPS = ZERO * dmin 162 | 163 | do ipos = head , tail 164 | 165 | !--------------- reconstruction: variable grid-spacing ! 166 | 167 | delh(-3) = & 168 | & max(delx(ipos-3),dmin) 169 | delh(-2) = & 170 | & max(delx(ipos-2),dmin) 171 | delh(-1) = & 172 | & max(delx(ipos-1),dmin) 173 | delh(+0) = & 174 | & max(delx(ipos+0),dmin) 175 | delh(+1) = & 176 | & max(delx(ipos+1),dmin) 177 | delh(+2) = & 178 | & max(delx(ipos+2),dmin) 179 | 180 | xhat = .5d0 * delh(-1) + & 181 | & .5d0 * delh(+0) 182 | 183 | xmap(-3) = -( delh(-3) & 184 | & + delh(-2) & 185 | & + delh(-1) ) / xhat 186 | xmap(-2) = -( delh(-2) & 187 | & + delh(-1) ) / xhat 188 | xmap(-1) = - delh(-1) / xhat 189 | xmap(+0) = + 0.d0 190 | xmap(+1) = + delh(+0) / xhat 191 | xmap(+2) = +( delh(+0) & 192 | & + delh(+1) ) / xhat 193 | xmap(+3) = +( delh(+0) & 194 | & + delh(+1) & 195 | & + delh(+2) ) / xhat 196 | 197 | !--------------------------- calc. integral basis vec. ! 198 | 199 | do idof = -3, +3 200 | 201 | ivec(1,idof) = & 202 | & xmap(idof) ** 1 / 1.0d+0 203 | ivec(2,idof) = & 204 | & xmap(idof) ** 2 / 2.0d+0 205 | ivec(3,idof) = & 206 | & xmap(idof) ** 3 / 3.0d+0 207 | ivec(4,idof) = & 208 | & xmap(idof) ** 4 / 4.0d+0 209 | ivec(5,idof) = & 210 | & xmap(idof) ** 5 / 5.0d+0 211 | ivec(6,idof) = & 212 | & xmap(idof) ** 6 / 6.0d+0 213 | 214 | end do 215 | 216 | !--------------------------- linear system: lhs matrix ! 217 | 218 | do idof = +1, +6 219 | 220 | cmat(1,idof) = ivec(idof,-2) & 221 | & - ivec(idof,-3) 222 | cmat(2,idof) = ivec(idof,-1) & 223 | & - ivec(idof,-2) 224 | cmat(3,idof) = ivec(idof,+0) & 225 | & - ivec(idof,-1) 226 | cmat(4,idof) = ivec(idof,+1) & 227 | & - ivec(idof,+0) 228 | cmat(5,idof) = ivec(idof,+2) & 229 | & - ivec(idof,+1) 230 | cmat(6,idof) = ivec(idof,+3) & 231 | & - ivec(idof,+2) 232 | 233 | end do 234 | 235 | !--------------------------- linear system: rhs vector ! 236 | 237 | do ivar = +1, nvar 238 | 239 | fhat(+1,ivar) = & 240 | & delx(ipos-3) * & 241 | & fdat(+1,ivar,ipos-3) / xhat 242 | fhat(+2,ivar) = & 243 | & delx(ipos-2) * & 244 | & fdat(+1,ivar,ipos-2) / xhat 245 | fhat(+3,ivar) = & 246 | & delx(ipos-1) * & 247 | & fdat(+1,ivar,ipos-1) / xhat 248 | fhat(+4,ivar) = & 249 | & delx(ipos+0) * & 250 | & fdat(+1,ivar,ipos+0) / xhat 251 | fhat(+5,ivar) = & 252 | & delx(ipos+1) * & 253 | & fdat(+1,ivar,ipos+1) / xhat 254 | fhat(+6,ivar) = & 255 | & delx(ipos+2) * & 256 | & fdat(+1,ivar,ipos+2) / xhat 257 | 258 | end do 259 | 260 | !------------------------- factor/solve linear systems ! 261 | 262 | call slv_6x6(cmat,NSIZ,fhat, & 263 | & NSIZ,nvar,fEPS, & 264 | & okay) 265 | 266 | if (okay .eqv. .true.) then 267 | 268 | do ivar = +1, nvar 269 | 270 | edge(ivar,ipos) = fhat(1,ivar) 271 | 272 | dfdx(ivar,ipos) = fhat(2,ivar) & 273 | & / xhat 274 | 275 | end do 276 | 277 | else 278 | 279 | !------------------------- fallback if system singular ! 280 | 281 | # ifdef __PPR_PIVOT__ 282 | 283 | write(*,*) & 284 | & "WARNING::P5E - matrix-is-singular!" 285 | 286 | # endif 287 | 288 | do ivar = +1, nvar 289 | 290 | edge(ivar,ipos) = & 291 | & fdat(1,ivar,ipos-1) * 0.5d+0 + & 292 | & fdat(1,ivar,ipos-0) * 0.5d+0 293 | 294 | dfdx(ivar,ipos) = & 295 | & fdat(1,ivar,ipos-0) * 0.5d+0 - & 296 | & fdat(1,ivar,ipos-1) * 0.5d+0 297 | 298 | dfdx(ivar,ipos) = & 299 | & dfdx(ivar,ipos) / xhat 300 | 301 | end do 302 | 303 | end if 304 | 305 | end do 306 | 307 | end if 308 | 309 | return 310 | 311 | end subroutine 312 | 313 | 314 | 315 | -------------------------------------------------------------------------------- /src/ffsl1d.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! FFSL1D.f90: upwind-biased flux-reconstruction scheme. 31 | ! 32 | ! Darren Engwirda 33 | ! 25-Jun-2020 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | subroutine ffsl1d(npos,nvar,ndof,spac,tDEL, & 39 | & mask,uvel,qbar,qedg,bclo, & 40 | & bchi,work,opts) 41 | 42 | ! 43 | ! NPOS no. edges over grid. 44 | ! NVAR no. state variables. 45 | ! NDOF no. degrees-of-freedom per grid-cell. 46 | ! SPAC grid-cell spacing array. LENGTH(SPAC) == +1 if 47 | ! spacing is uniform . 48 | ! TDEL time-step . 49 | ! MASK logical grid-cell masking array. 50 | ! UVEL edge-centred velocity vectors. UVEL has SIZE = 51 | ! NPOS-by-1 . 52 | ! QBAR cell-centred integral moments. QBAR has SIZE = 53 | ! NDOF-by-NVAR-by-NPOS-1 . 54 | ! QEDG edge-centred upwind flux eval. QEDG has SIZE = 55 | ! NVAR-by-NPOS . 56 | ! BCLO boundary condition at lower endpoint . 57 | ! BCHI boundary condition at upper endpoint . 58 | ! WORK method work-space. See RCON-WORK for details . 59 | ! OPTS method parameters. See RCON-OPTS for details . 60 | ! 61 | 62 | implicit none 63 | 64 | !------------------------------------------- arguments ! 65 | integer , intent(in) :: npos,nvar,ndof 66 | class(rmap_work), intent(inout) :: work 67 | class(rmap_opts), intent(inout) :: opts 68 | real(kind=dp) , intent(in) :: spac(:) 69 | real(kind=dp) , intent(in) :: tDEL 70 | logical , intent(in) :: mask(:) 71 | real(kind=dp) , intent(in) :: qbar(:,:,:) 72 | real(kind=dp) , intent(in) :: uvel(:) 73 | real(kind=dp) , intent(out) :: qedg(:,:) 74 | class(rcon_ends), intent(in) :: bclo(:) 75 | class(rcon_ends), intent(in) :: bchi(:) 76 | 77 | !------------------------------------------- variables ! 78 | integer :: head,tail,nprt 79 | 80 | head = +0 ; tail = +0 ; qedg = 0.d+0 81 | 82 | do while (.true.) 83 | 84 | !--------------------------------- 1. find active part ! 85 | 86 | do head = tail+1, npos-1 87 | if (mask(head) .eqv..true.) exit 88 | end do 89 | 90 | do tail = head+1, npos-1 91 | if (mask(tail).neqv..true.) exit 92 | end do 93 | tail = tail - 1 94 | 95 | if (head.ge.npos) exit 96 | 97 | !--------------------------------- 2. rcon active part ! 98 | 99 | nprt = tail - head + 1 100 | 101 | if (size(spac).ne.+1) then 102 | 103 | call rcon1d(nprt+1,nvar,ndof , & 104 | & spac( head:tail), & 105 | & qbar(:,:,head:tail), & 106 | & bclo,bchi,work%cell_func, & 107 | & work,opts ) 108 | 109 | else 110 | 111 | call rcon1d(nprt+1,nvar,ndof , & 112 | & spac,qbar(:,:,head:tail), & 113 | & bclo,bchi,work%cell_func, & 114 | & work,opts ) 115 | 116 | end if 117 | 118 | !--------------------------------- 3. int. active part ! 119 | 120 | select case(opts%cell_meth) 121 | case(pcm_method) !! 1st-order scheme 122 | 123 | if (size(spac).ne.+1) then 124 | 125 | call flux1d(nprt+1,nvar,1, & 126 | & spac( head:tail+0) , & 127 | & tDEL, & 128 | & uvel( head:tail+1) , & 129 | & work%cell_func, & 130 | & qedg(:,head:tail+1) ) 131 | 132 | else 133 | 134 | call flux1d(nprt+1,nvar,1, & 135 | & spac,tDEL , & 136 | & uvel( head:tail+1) , & 137 | & work%cell_func, & 138 | & qedg(:,head:tail+1) ) 139 | 140 | end if 141 | 142 | case(plm_method) !! 2nd-order scheme 143 | 144 | if (size(spac).ne.+1) then 145 | 146 | call flux1d(nprt+1,nvar,2, & 147 | & spac( head:tail+0) , & 148 | & tDEL, & 149 | & uvel( head:tail+1) , & 150 | & work%cell_func, & 151 | & qedg(:,head:tail+1) ) 152 | 153 | else 154 | 155 | call flux1d(nprt+1,nvar,2, & 156 | & spac,tDEL , & 157 | & uvel( head:tail+1) , & 158 | & work%cell_func, & 159 | & qedg(:,head:tail+1) ) 160 | 161 | end if 162 | 163 | case(ppm_method) !! 3rd-order scheme 164 | 165 | if (size(spac).ne.+1) then 166 | 167 | call flux1d(nprt+1,nvar,3, & 168 | & spac( head:tail+0) , & 169 | & tDEL, & 170 | & uvel( head:tail+1) , & 171 | & work%cell_func, & 172 | & qedg(:,head:tail+1) ) 173 | 174 | else 175 | 176 | call flux1d(nprt+1,nvar,3, & 177 | & spac,tDEL , & 178 | & uvel( head:tail+1) , & 179 | & work%cell_func, & 180 | & qedg(:,head:tail+1) ) 181 | 182 | end if 183 | 184 | case(pqm_method) !! 5th-order scheme 185 | 186 | if (size(spac).ne.+1) then 187 | 188 | call flux1d(nprt+1,nvar,5, & 189 | & spac( head:tail+0) , & 190 | & tDEL, & 191 | & uvel( head:tail+1) , & 192 | & work%cell_func, & 193 | & qedg(:,head:tail+1) ) 194 | 195 | else 196 | 197 | call flux1d(nprt+1,nvar,5, & 198 | & spac,tDEL , & 199 | & uvel( head:tail+1) , & 200 | & work%cell_func, & 201 | & qedg(:,head:tail+1) ) 202 | 203 | end if 204 | 205 | end select 206 | 207 | end do 208 | 209 | return 210 | 211 | end subroutine 212 | 213 | ! FLUX1D: a degree-k, upwind-type flux reconstruction. ! 214 | 215 | pure subroutine flux1d(npos,nvar,mdof,SPAC, & 216 | & tDEL,uvel,QHAT,qedg) 217 | 218 | ! 219 | ! NPOS no. edges over grid. 220 | ! NVAR no. state variables. 221 | ! MDOF no. degrees-of-freedom per QHAT. 222 | ! SPAC grid spacing vector. SIZE(SPAC)==+1 if uniform . 223 | ! TDEL time-step . 224 | ! UVEL edge-centred velocity vectors. UVEL has SIZE = 225 | ! NPOS-by-1 . 226 | ! QHAT cell-centred polynomial recon. QHAT has SIZE = 227 | ! NDOF-by-NVAR-by-NPOS-1 . 228 | ! QEDG edge-centred upwind flux eval. QEDG has SIZE = 229 | ! NVAR-by-NPOS . 230 | ! 231 | 232 | implicit none 233 | 234 | !------------------------------------------- arguments ! 235 | integer , intent(in) :: npos,nvar,mdof 236 | real(kind=dp), intent(in) :: SPAC(:) 237 | real(kind=dp), intent(in) :: tDEL 238 | real(kind=dp), intent(in) :: uvel(:) 239 | real(kind=dp), intent(in) :: QHAT(:,:,:) 240 | real(kind=dp), intent(out) :: qedg(:,:) 241 | 242 | !------------------------------------------- variables ! 243 | integer :: ipos,ivar 244 | real(kind=dp) :: uCFL,xhat,ss11,ss22,flux 245 | real(kind=dp) :: vv11(1:5) 246 | real(kind=dp) :: vv22(1:5) 247 | real(kind=dp) :: ivec(1:5) 248 | 249 | !----------- single-cell, lagrangian-type upwind rcon. ! 250 | 251 | vv11 = 0.d+0; vv22 = 0.d+0; ivec = 0.d+0 252 | 253 | do ipos = +2 , npos - 1 254 | 255 | if (uvel(ipos) .gt. +0.d0) then 256 | 257 | !----------- integrate profile over upwind cell IPOS-1 ! 258 | 259 | if (size(SPAC).ne.+1) then 260 | xhat = .5d0 * SPAC(ipos-1) 261 | uCFL = uvel(ipos) & 262 | & * tDEL / SPAC(ipos-1) 263 | else 264 | xhat = .5d0 * SPAC( +1) 265 | uCFL = uvel(ipos) & 266 | & * tDEL / SPAC( +1) 267 | end if 268 | 269 | ss11 = +1.d0 - 2.d0 * uCFL 270 | ss22 = +1.d0 271 | 272 | call bfun1d(-1,mdof,ss11,vv11) 273 | call bfun1d(-1,mdof,ss22,vv22) 274 | 275 | ivec = vv22 - vv11 276 | 277 | do ivar = +1, nvar 278 | 279 | flux = dot_product ( & 280 | & ivec(1:mdof), & 281 | & QHAT(1:mdof,ivar,ipos-1) ) 282 | 283 | flux = flux * xhat 284 | 285 | qedg(ivar,ipos) = flux 286 | 287 | end do 288 | 289 | else & 290 | & if (uvel(ipos) .lt. -0.d0) then 291 | 292 | !----------- integrate profile over upwind cell IPOS+0 ! 293 | 294 | if (size(SPAC).ne.+1) then 295 | xhat = .5d0 * SPAC(ipos-0) 296 | uCFL = uvel(ipos) & 297 | & * tDEL / SPAC(ipos-0) 298 | else 299 | xhat = .5d0 * SPAC( +1) 300 | uCFL = uvel(ipos) & 301 | & * tDEL / SPAC( +1) 302 | end if 303 | 304 | ss11 = -1.d0 - 2.d0 * uCFL 305 | ss22 = -1.d0 306 | 307 | call bfun1d(-1,mdof,ss11,vv11) 308 | call bfun1d(-1,mdof,ss22,vv22) 309 | 310 | ivec = vv22 - vv11 311 | 312 | do ivar = +1, nvar 313 | 314 | flux = dot_product ( & 315 | & ivec(1:mdof), & 316 | & QHAT(1:mdof,ivar,ipos-0) ) 317 | 318 | flux = flux * xhat 319 | 320 | qedg(ivar,ipos) = flux 321 | 322 | end do 323 | 324 | end if 325 | 326 | end do 327 | 328 | return 329 | 330 | end subroutine 331 | 332 | 333 | 334 | -------------------------------------------------------------------------------- /src/ppr_1d.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | module ppr_1d 30 | 31 | ! 32 | ! PPR-1D.f90: 1-d piecewise polynomial reconstructions. 33 | ! 34 | ! Darren Engwirda 35 | ! 25-Oct-2021 36 | ! d [dot] engwirda [at] gmail [dot] com 37 | ! 38 | ! 39 | 40 | implicit none 41 | 42 | integer, parameter :: sp = kind(+1.0e+00) 43 | integer, parameter :: dp = kind(+1.0d+00) 44 | 45 | !------------------------------------ compile-time def ! 46 | 47 | ! define __PPR_PIVOT__ 48 | ! define __PPR_TIMER__ 49 | 50 | # ifdef __PPR_TIMER__ 51 | 52 | # define __TIC__ \ 53 | call system_clock (ttic,rate) 54 | 55 | # define __TOC__(time, mark) \ 56 | call system_clock (ttoc,rate) ; \ 57 | if ( present(time) ) \ 58 | time%mark=time%mark+(ttoc-ttic) 59 | 60 | # else 61 | 62 | # define __TIC__ 63 | # define __TOC__(time, mark) \ 64 | if ( present(time) ) time%mark = + 0 65 | 66 | # endif 67 | 68 | !------------------------------------ method selection ! 69 | 70 | integer(kind=4), parameter :: p1e_method = +100 71 | integer(kind=4), parameter :: p3e_method = +101 72 | integer(kind=4), parameter :: p5e_method = +102 73 | 74 | integer(kind=4), parameter :: pcm_method = +200 75 | integer(kind=4), parameter :: plm_method = +201 76 | integer(kind=4), parameter :: ppm_method = +202 77 | integer(kind=4), parameter :: pqm_method = +203 78 | 79 | integer(kind=4), parameter :: null_limit = +300 80 | integer(kind=4), parameter :: mono_limit = +301 81 | integer(kind=4), parameter :: weno_limit = +302 82 | 83 | integer(kind=4), parameter :: bcon_loose = +400 84 | integer(kind=4), parameter :: bcon_value = +401 85 | integer(kind=4), parameter :: bcon_slope = +402 86 | 87 | type rmap_tics 88 | !------------------------------- tCPU timer for RCON1D ! 89 | integer(kind=8) :: rmap_time 90 | integer(kind=8) :: edge_time 91 | integer(kind=8) :: cell_time 92 | integer(kind=8) :: oscl_time 93 | end type rmap_tics 94 | 95 | type rcon_opts 96 | !------------------------------- parameters for RCON1D ! 97 | integer(kind=4) :: edge_meth 98 | integer(kind=4) :: cell_meth 99 | integer(kind=4) :: cell_lims 100 | integer(kind=4) :: wall_lims 101 | end type rcon_opts 102 | 103 | type rcon_ends 104 | !------------------------------- end-conditions struct ! 105 | integer :: bcopt 106 | real(kind=dp) :: value 107 | real(kind=dp) :: slope 108 | end type rcon_ends 109 | 110 | type rcon_work 111 | !------------------------------- work-space for RCON1D ! 112 | real(kind=dp), allocatable :: edge_func(:,:) 113 | real(kind=dp), allocatable :: edge_dfdx(:,:) 114 | real(kind=dp), allocatable :: cell_oscl(:,:,:) 115 | contains 116 | procedure :: init => init_rcon_work 117 | procedure :: free => free_rcon_work 118 | end type rcon_work 119 | 120 | type, extends(rcon_opts) :: rmap_opts 121 | !------------------------------- parameters for RMAP1D ! 122 | end type rmap_opts 123 | 124 | type, extends(rcon_work) :: rmap_work 125 | !------------------------------- work-space for RMAP1D ! 126 | real(kind=dp), allocatable :: cell_spac(:) 127 | real(kind=dp), allocatable :: cell_func(:,:,:) 128 | contains 129 | procedure :: init => init_rmap_work 130 | procedure :: free => free_rmap_work 131 | end type rmap_work 132 | 133 | contains 134 | 135 | !------------------------------------------------------! 136 | ! INIT-RCON-WORK: init. work-space for RCON1D. ! 137 | !------------------------------------------------------! 138 | 139 | subroutine init_rcon_work(this,npos,nvar,opts) 140 | 141 | ! 142 | ! THIS work-space structure for RCON1D . 143 | ! NPOS no. edges over grid. 144 | ! NVAR no. state variables. 145 | ! OPTS parameters structure for RCON1D . 146 | ! 147 | 148 | implicit none 149 | 150 | !------------------------------------------- arguments ! 151 | class(rcon_work) , intent(inout) :: this 152 | integer, intent(in):: npos 153 | integer, intent(in):: nvar 154 | class(rcon_opts) , optional :: opts 155 | 156 | !------------------------------------------- variables ! 157 | integer :: okay,ndof 158 | 159 | ndof = ndof1d(opts%cell_meth) 160 | 161 | allocate(this% & 162 | & edge_func( nvar,npos), & 163 | & this% & 164 | & edge_dfdx( nvar,npos), & 165 | & this% & 166 | & cell_oscl(2,nvar,npos), & 167 | & stat=okay) 168 | 169 | end subroutine 170 | 171 | !------------------------------------------------------! 172 | ! INIT-RMAP-WORK: init. work-space for RMAP1D. ! 173 | !------------------------------------------------------! 174 | 175 | subroutine init_rmap_work(this,npos,nvar,opts) 176 | 177 | ! 178 | ! THIS work-space structure for RMAP1D . 179 | ! NPOS no. edges over grid. 180 | ! NVAR no. state variables. 181 | ! OPTS parameters structure for RMAP1D . 182 | ! 183 | 184 | implicit none 185 | 186 | !------------------------------------------- arguments ! 187 | class(rmap_work) , intent(inout) :: this 188 | integer, intent(in) :: npos 189 | integer, intent(in) :: nvar 190 | class(rcon_opts) , optional :: opts 191 | 192 | !------------------------------------------- variables ! 193 | integer :: okay,ndof 194 | 195 | ndof = ndof1d(opts%cell_meth) 196 | 197 | allocate(this% & 198 | & edge_func( nvar,npos), & 199 | & this% & 200 | & edge_dfdx( nvar,npos), & 201 | & this% & 202 | & cell_oscl(2,nvar,npos), & 203 | & this% & 204 | & cell_spac( npos), & 205 | & this% & 206 | & cell_func(ndof,nvar,npos) , & 207 | & stat=okay) 208 | 209 | end subroutine 210 | 211 | !------------------------------------------------------! 212 | ! FREE-RCON-WORK: free work-space for RCON1D . ! 213 | !------------------------------------------------------! 214 | 215 | subroutine free_rcon_work(this) 216 | 217 | implicit none 218 | 219 | !------------------------------------------- arguments ! 220 | class(rcon_work), intent(inout) :: this 221 | 222 | deallocate(this%edge_func, & 223 | & this%edge_dfdx, & 224 | & this%cell_oscl) 225 | 226 | end subroutine 227 | 228 | !------------------------------------------------------! 229 | ! FREE-RMAP-WORK: free work-space for RMAP1D . ! 230 | !------------------------------------------------------! 231 | 232 | subroutine free_rmap_work(this) 233 | 234 | implicit none 235 | 236 | !------------------------------------------- arguments ! 237 | class(rmap_work), intent(inout) :: this 238 | 239 | 240 | deallocate(this%edge_func, & 241 | & this%edge_dfdx, & 242 | & this%cell_oscl, & 243 | & this%cell_func, & 244 | & this%cell_spac) 245 | 246 | end subroutine 247 | 248 | !------------------------------------------------------! 249 | ! NDOF1D : no. degrees-of-freedom per polynomial . ! 250 | !------------------------------------------------------! 251 | 252 | pure function ndof1d(meth) result(rdof) 253 | 254 | implicit none 255 | 256 | !------------------------------------------- arguments ! 257 | integer, intent( in) :: meth 258 | 259 | !------------------------------------------- variables ! 260 | integer :: rdof 261 | 262 | !-------------------------------- edge reconstructions ! 263 | if (meth.eq.p1e_method) then 264 | rdof = +2 265 | else if (meth.eq.p3e_method) then 266 | rdof = +4 267 | else if (meth.eq.p5e_method) then 268 | rdof = +6 269 | 270 | !-------------------------------- cell reconstructions ! 271 | else if (meth.eq.pcm_method) then 272 | rdof = +1 273 | else if (meth.eq.plm_method) then 274 | rdof = +2 275 | else if (meth.eq.ppm_method) then 276 | rdof = +3 277 | else if (meth.eq.pqm_method) then 278 | rdof = +5 279 | 280 | else 281 | rdof = +0 ! default 282 | 283 | end if 284 | 285 | end function ndof1d 286 | 287 | !------------------------------------------------------! 288 | ! BFUN1D : one-dimensional poly. basis-functions . ! 289 | !------------------------------------------------------! 290 | 291 | # include "bfun1d.f90" 292 | 293 | !------------------------------------------------------! 294 | ! UTIL1D : one-dimensional grid manip. utilities . ! 295 | !------------------------------------------------------! 296 | 297 | # include "util1d.f90" 298 | 299 | !------------------------------------------------------! 300 | ! WENO1D : "essentially" non-oscillatory limiter . ! 301 | !------------------------------------------------------! 302 | 303 | # include "weno1d.f90" 304 | 305 | # include "oscl1d.f90" 306 | 307 | !------------------------------------------------------! 308 | ! RCON1D : one-dimensional poly. reconstructions . ! 309 | !------------------------------------------------------! 310 | 311 | # include "rcon1d.f90" 312 | 313 | # include "inv.f90" 314 | 315 | # include "pbc.f90" 316 | # include "p1e.f90" 317 | # include "p3e.f90" 318 | # include "p5e.f90" 319 | 320 | # include "root1d.f90" 321 | 322 | # include "pcm.f90" 323 | # include "plm.f90" 324 | # include "ppm.f90" 325 | # include "pqm.f90" 326 | 327 | !------------------------------------------------------! 328 | ! RMAP1D : one-dimensional conservative "re-map" . ! 329 | !------------------------------------------------------! 330 | 331 | # include "rmap1d.f90" 332 | 333 | !------------------------------------------------------! 334 | ! FFSL1D : one-dimensional FFSL scalar transport . ! 335 | !------------------------------------------------------! 336 | 337 | # include "ffsl1d.f90" 338 | 339 | 340 | !------------------------------------------ end ppr_1d ! 341 | 342 | # undef __TIC__ 343 | # undef __TOC__ 344 | 345 | end module 346 | 347 | 348 | 349 | -------------------------------------------------------------------------------- /src/ppm.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! PPM.f90: 1d slope-limited, piecewise parabolic recon. 31 | ! 32 | ! Darren Engwirda 33 | ! 06-Nov-2021 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | ! P. Colella and PR. Woodward, The Piecewise Parabolic 39 | ! Method (PPM) for gas-dynamical simulations., J. Comp. 40 | ! Phys., 54 (1), 1984, 174-201, 41 | ! https://doi.org/10.1016/0021-9991(84)90143-8 42 | ! 43 | 44 | pure subroutine ppm(npos,nvar,ndof,delx, & 45 | & fdat,fhat,edge, & 46 | & oscl,ilim,wlim,halo) 47 | 48 | ! 49 | ! NPOS no. edges over grid. 50 | ! NVAR no. state variables. 51 | ! NDOF no. degrees-of-freedom per grid-cell. 52 | ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if 53 | ! spacing is uniform . 54 | ! FDAT grid-cell moments array. FDAT is an array with 55 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 56 | ! FHAT grid-cell re-con. array. FHAT is an array with 57 | ! SIZE = MDOF-by-NVAR-by-NPOS-1 . 58 | ! EDGE edge-centred interp. for function-value. EDGE 59 | ! is an array with SIZE = NVAR-by-NPOS . 60 | ! OSCL grid-cell oscil. dof.'s. OSCL is an array with 61 | ! SIZE = +2 -by-NVAR-by-NPOS-1 . 62 | ! ILIM cell slope-limiting selection . 63 | ! WLIM wall slope-limiting selection . 64 | ! HALO width of re-con. stencil, symmetric about mid. . 65 | ! 66 | 67 | implicit none 68 | 69 | !------------------------------------------- arguments ! 70 | integer , intent(in) :: npos,nvar,ndof 71 | real(kind=dp), intent(out) :: fhat(:,:,:) 72 | real(kind=dp), intent(in) :: oscl(:,:,:) 73 | real(kind=dp), intent(in) :: delx(:) 74 | real(kind=dp), intent(in) :: fdat(:,:,:) 75 | real(kind=dp), intent(in) :: edge(:,:) 76 | integer , intent(in) :: ilim,wlim,halo 77 | 78 | !------------------------------------------- variables ! 79 | integer :: ipos,ivar,iill,iirr,head,tail 80 | real(kind=dp) :: ff00,ffll,ffrr,hh00,hhll,hhrr 81 | integer :: mono 82 | real(kind=dp) :: fell,ferr 83 | real(kind=dp) :: dfds(-1:+1) 84 | real(kind=dp) :: wval(+1:+2) 85 | real(kind=dp) :: uhat(+1:+3) 86 | real(kind=dp) :: lhat(+1:+3) 87 | 88 | head = +1; tail = npos - 1 89 | 90 | if (npos.eq.2) then 91 | !----- default to reduced order if insufficient points ! 92 | do ivar = +1, nvar 93 | fhat(1,ivar,+1) = & 94 | & fdat(1,ivar,+1) 95 | fhat(2,ivar,+1) = 0.d0 96 | fhat(3,ivar,+1) = 0.d0 97 | end do 98 | end if 99 | 100 | if (ndof.le.0) return 101 | if (npos.le.2) return 102 | 103 | !------------------- reconstruct function on each cell ! 104 | 105 | uhat = +0.d+0 106 | lhat = +0.d+0 107 | 108 | do ipos = +1 , npos-1 109 | 110 | iill = max(head,ipos-1) 111 | iirr = min(tail,ipos+1) 112 | 113 | do ivar = +1 , nvar-0 114 | 115 | !----------------------------- cell mean + edge values ! 116 | 117 | ff00 = fdat(1,ivar,ipos) 118 | ffll = fdat(1,ivar,iill) 119 | ffrr = fdat(1,ivar,iirr) 120 | 121 | fell = edge(ivar,ipos+0) 122 | ferr = edge(ivar,ipos+1) 123 | 124 | !----------------------------- calc. LL/00/RR gradient ! 125 | 126 | if (size(delx).gt.+1) then 127 | 128 | hh00 = delx(ipos) 129 | hhll = delx(iill) 130 | hhrr = delx(iirr) 131 | 132 | call plsv (dfds,mono_limit, & 133 | & ffll,hhll,ff00 , & 134 | & hh00,ffrr,hhrr) 135 | else 136 | 137 | call plsc (dfds,mono_limit, & 138 | & ffll,ff00,ffrr) 139 | 140 | end if 141 | 142 | !----------------------------- calc. cell-wise profile ! 143 | 144 | select case(ilim) 145 | case (null_limit) 146 | 147 | !----------------------------- calc. unlimited profile ! 148 | 149 | call ppmfn(ff00,ffll,ffrr, & 150 | & fell,ferr,dfds, & 151 | & uhat,lhat,mono) 152 | 153 | !----------------------------- pref. unlimited profile ! 154 | 155 | wval(1) = +1.d+0 156 | wval(2) = +0.d+0 157 | 158 | case (mono_limit) 159 | 160 | !----------------------------- calc. monotonic profile ! 161 | 162 | call ppmfn(ff00,ffll,ffrr, & 163 | & fell,ferr,dfds, & 164 | & uhat,lhat,mono) 165 | 166 | !----------------------------- pref. monotonic profile ! 167 | 168 | wval(1) = +0.d+0 169 | wval(2) = +1.d+0 170 | 171 | case (weno_limit) 172 | 173 | !----------------------------- calc. unlimited profile ! 174 | 175 | call ppmfn(ff00,ffll,ffrr, & 176 | & fell,ferr,dfds, & 177 | & uhat,lhat,mono) 178 | 179 | if (mono.gt.+0) then 180 | 181 | !----------------------------- calc. WENO-type weights ! 182 | 183 | call wenoi(npos,delx,oscl, & 184 | & ipos,ivar,halo, & 185 | & wlim,wval) 186 | 187 | else 188 | 189 | !----------------------------- pref. unlimited profile ! 190 | 191 | wval(1) = +1.d+0 192 | wval(2) = +0.d+0 193 | 194 | end if 195 | 196 | end select 197 | 198 | !----------------------------- blend "null" and "mono" ! 199 | 200 | fhat(1,ivar,ipos) = & 201 | & wval(1) * uhat(1) + & 202 | & wval(2) * lhat(1) 203 | fhat(2,ivar,ipos) = & 204 | & wval(1) * uhat(2) + & 205 | & wval(2) * lhat(2) 206 | fhat(3,ivar,ipos) = & 207 | & wval(1) * uhat(3) + & 208 | & wval(2) * lhat(3) 209 | 210 | end do 211 | 212 | end do 213 | 214 | return 215 | 216 | end subroutine 217 | 218 | !--------- assemble piecewise parabolic reconstruction ! 219 | 220 | pure subroutine ppmfn(ff00,ffll,ffrr,fell,& 221 | & ferr,dfds,uhat,lhat,& 222 | & mono) 223 | 224 | ! 225 | ! FF00 centred grid-cell mean. 226 | ! FFLL left -biased grid-cell mean. 227 | ! FFRR right-biased grid-cell mean. 228 | ! FELL left -biased edge interp. 229 | ! FERR right-biased edge interp. 230 | ! DFDS piecewise linear gradients in local co-ord.'s. 231 | ! DFDS(+0) is a centred, slope-limited estimate, 232 | ! DFDS(-1), DFDS(+1) are left- and right-biased 233 | ! estimates (unlimited). 234 | ! UHAT unlimited PPM reconstruction coefficients . 235 | ! LHAT monotonic PPM reconstruction coefficients . 236 | ! MONO slope-limiting indicator, MONO > +0 if some 237 | ! limiting has occured . 238 | ! 239 | 240 | implicit none 241 | 242 | !------------------------------------------- arguments ! 243 | real(kind=dp), intent(in) :: ff00 244 | real(kind=dp), intent(in) :: ffll,ffrr 245 | real(kind=dp), intent(inout) :: fell,ferr 246 | real(kind=dp), intent(in) :: dfds(-1:+1) 247 | real(kind=dp), intent(out) :: uhat(+1:+3) 248 | real(kind=dp), intent(out) :: lhat(+1:+3) 249 | integer , intent(out) :: mono 250 | 251 | !------------------------------------------- variables ! 252 | real(kind=dp) :: turn,fmid,fmin,fmax 253 | 254 | mono = 0 255 | 256 | !-------------------------------- "null" slope-limiter ! 257 | 258 | uhat( 1 ) = & 259 | & + (3.0d+0 / 2.0d+0) * ff00 & 260 | & - (1.0d+0 / 4.0d+0) *(ferr+fell) 261 | uhat( 2 ) = & 262 | & + (1.0d+0 / 2.0d+0) *(ferr-fell) 263 | uhat( 3 ) = & 264 | & - (3.0d+0 / 2.0d+0) * ff00 & 265 | & + (3.0d+0 / 4.0d+0) *(ferr+fell) 266 | 267 | !-------------------------------- "mono" slope-limiter ! 268 | 269 | if((ffrr - ff00) * & 270 | & (ff00 - ffll) .lt. 0.d+0) then 271 | 272 | !----------------------------------- "flatten" extrema ! 273 | 274 | mono = +1 275 | 276 | lhat(1) = ff00 277 | lhat(2) = 0.d0 278 | lhat(3) = 0.d0 279 | 280 | return 281 | 282 | end if 283 | 284 | !----------------------------------- limit edge values ! 285 | 286 | if((ffll - fell) * & 287 | & (fell - ff00) .le. 0.d+0) then 288 | 289 | mono = +1 290 | fell = ff00 - dfds(0) 291 | 292 | end if 293 | 294 | if((ffrr - ferr) * & 295 | & (ferr - ff00) .le. 0.d+0) then 296 | 297 | mono = +1 298 | ferr = ff00 + dfds(0) 299 | 300 | end if 301 | 302 | !----------------------------------- update ppm coeff. ! 303 | 304 | lhat( 1 ) = & 305 | & + (3.0d+0 / 2.0d+0) * ff00 & 306 | & - (1.0d+0 / 4.0d+0) *(ferr+fell) 307 | lhat( 2 ) = & 308 | & + (1.0d+0 / 2.0d+0) *(ferr-fell) 309 | lhat( 3 ) = & 310 | & - (3.0d+0 / 2.0d+0) * ff00 & 311 | & + (3.0d+0 / 4.0d+0) *(ferr+fell) 312 | 313 | !----------------------------------- limit cell values ! 314 | 315 | if (abs(lhat(3)) .gt. & 316 | & abs(lhat(2))*.5d+0) then 317 | 318 | turn = -0.5d+0 * lhat(2) & 319 | & / lhat(3) 320 | 321 | if ((turn .ge. -1.d+0)& 322 | & .and.(turn .le. +0.d+0)) then 323 | 324 | mono = +2 325 | 326 | !--------------------------- push TURN onto lower edge ! 327 | 328 | fell = & ! steepening... 329 | & + (1.0d+0 / 2.0d+0) * ffll & 330 | & + (1.0d+0 / 2.0d+0) * fell 331 | 332 | ferr = +3.0d+0 * ff00 & 333 | & -2.0d+0 * fell 334 | 335 | if((ffrr - ferr) * & ! double-check monotonicity ! 336 | & (ferr - ff00) .le. 0.d+0) then 337 | 338 | lhat(1) = ff00 ! reduce to PLM 339 | lhat(2) = dfds(0) 340 | lhat(3) = 0.0d+0 341 | 342 | else 343 | 344 | lhat( 1 ) = & ! update to PPM 345 | & + (3.0d+0 / 2.0d+0) * ff00 & 346 | & - (1.0d+0 / 4.0d+0) *(ferr+fell) 347 | lhat( 2 ) = & 348 | & + (1.0d+0 / 2.0d+0) *(ferr-fell) 349 | lhat( 3 ) = & 350 | & - (3.0d+0 / 2.0d+0) * ff00 & 351 | & + (3.0d+0 / 4.0d+0) *(ferr+fell) 352 | 353 | end if 354 | 355 | else & 356 | & if ((turn .le. +1.d+0)) then 357 | 358 | mono = +2 359 | 360 | !--------------------------- push TURN onto upper edge ! 361 | 362 | ferr = & ! steepening... 363 | & + (1.0d+0 / 2.0d+0) * ffrr & 364 | & + (1.0d+0 / 2.0d+0) * ferr 365 | 366 | fell = +3.0d+0 * ff00 & 367 | & -2.0d+0 * ferr 368 | 369 | if((ffll - fell) * & ! double-check monotonicity ! 370 | & (fell - ff00) .le. 0.d+0) then 371 | 372 | lhat(1) = ff00 ! reduce to PLM 373 | lhat(2) = dfds(0) 374 | lhat(3) = 0.0d+0 375 | 376 | else 377 | 378 | lhat( 1 ) = & ! update to PPM 379 | & + (3.0d+0 / 2.0d+0) * ff00 & 380 | & - (1.0d+0 / 4.0d+0) *(ferr+fell) 381 | lhat( 2 ) = & 382 | & + (1.0d+0 / 2.0d+0) *(ferr-fell) 383 | lhat( 3 ) = & 384 | & - (3.0d+0 / 2.0d+0) * ff00 & 385 | & + (3.0d+0 / 4.0d+0) *(ferr+fell) 386 | 387 | end if 388 | 389 | end if 390 | 391 | end if 392 | 393 | return 394 | 395 | end subroutine 396 | 397 | 398 | 399 | -------------------------------------------------------------------------------- /src/weno1d.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! WENO1D.f90: WENO-style slope-limiting for 1d reconst. 31 | ! 32 | ! Darren Engwirda 33 | ! 08-Sep-2016 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | pure subroutine wenoi (npos,delx,oscl,ipos, & 39 | & ivar,halo,& 40 | & wlim,wval ) 41 | 42 | ! 43 | ! NPOS no. edges over grid. 44 | ! DELX grid-cell spacing array. SIZE(DELX) == +1 if 45 | ! the grid is uniformly spaced . 46 | ! OSCL cell-centred oscillation-detectors, where OSCL 47 | ! has SIZE = +2-by-NVAR-by-NPOS-1. OSCL is given 48 | ! by calls to OSCLI(). 49 | ! IPOS grid-cell index for which to calc. weights . 50 | ! IVAR state-var index for which to calc/ weights . 51 | ! HALO width of recon. stencil, symmetric about IPOS . 52 | ! WLIM limiter treatment at endpoints, monotonic or 53 | ! otherwise . 54 | ! WVAL WENO weights vector, such that FHAT = WVAL(1) * 55 | ! UHAT + WVAL(2) * LHAT, where UHAT and LHAT are 56 | ! the unlimited and monotonic grid-cell profiles 57 | ! respectively . 58 | ! 59 | 60 | implicit none 61 | 62 | !------------------------------------------- arguments ! 63 | integer , intent(in) :: npos,halo 64 | integer , intent(in) :: ipos,ivar 65 | integer , intent(in) :: wlim 66 | real(kind=dp), intent(in) :: delx(:) 67 | real(kind=dp), intent(in) :: oscl(:,:,:) 68 | real(kind=dp), intent(out) :: wval(2) 69 | 70 | !------------------------------------------- variables ! 71 | real(kind=dp) :: omin,omax,wsum 72 | 73 | real(kind=dp), parameter :: ZERO = +1.d-16 74 | 75 | if (size(delx).gt.+1) then 76 | 77 | !------------------- use variable grid spacing variant ! 78 | 79 | call wenov(npos,delx,oscl, & 80 | & ipos,ivar,halo, & 81 | & wlim,omin,omax) 82 | 83 | else 84 | 85 | !------------------- use constant grid spacing variant ! 86 | 87 | call wenoc(npos,delx,oscl, & 88 | & ipos,ivar,halo, & 89 | & wlim,omin,omax) 90 | 91 | end if 92 | 93 | !------------------ compute WENO-style profile weights ! 94 | 95 | omax = omax + ZERO 96 | omin = omin + ZERO 97 | 98 | if (halo .ge. +3) then 99 | 100 | wval(1) = +1.0d+7 / omax ** 3 101 | wval(2) = +1.0d+0 / omin ** 3 102 | 103 | else & 104 | & if (halo .le. +2) then 105 | 106 | wval(1) = +1.0d+5 / omax ** 3 107 | wval(2) = +1.0d+0 / omin ** 3 108 | 109 | end if 110 | 111 | wsum = wval(1) + wval(2) + ZERO 112 | wval(1) = wval(1) / wsum 113 | ! wval(2) = wval(2) / wsum 114 | wval(2) =-wval(1) + 1.d0 ! wval(2)/wsum but robust ! 115 | 116 | return 117 | 118 | end subroutine 119 | 120 | pure subroutine wenov (npos,delx,oscl,ipos, & 121 | & ivar,halo,& 122 | & wlim,omin,omax) 123 | 124 | ! 125 | ! *this is the variable grid-spacing variant . 126 | ! 127 | ! NPOS no. edges over grid. 128 | ! DELX grid-cell spacing array. SIZE(DELX) == +1 if 129 | ! the grid is uniformly spaced . 130 | ! OSCL cell-centred oscillation-detectors, where OSCL 131 | ! has SIZE = +2-by-NVAR-by-NPOS-1. OSCL is given 132 | ! by calls to OSCLI(). 133 | ! IPOS grid-cell index for which to calc. weights . 134 | ! IVAR state-var index for which to calc/ weights . 135 | ! HALO width of recon. stencil, symmetric about IPOS . 136 | ! WLIM limiter treatment at endpoints, monotonic or 137 | ! otherwise . 138 | ! OMIN min. and max. oscillation indicators over the 139 | ! OMAX local re-con. stencil . 140 | ! 141 | 142 | implicit none 143 | 144 | !------------------------------------------- arguments ! 145 | integer , intent(in) :: npos,halo 146 | integer , intent(in) :: ipos,ivar 147 | integer , intent(in) :: wlim 148 | real(kind=dp), intent(in) :: delx(:) 149 | real(kind=dp), intent(in) :: oscl(:,:,:) 150 | real(kind=dp), intent(out) :: omin,omax 151 | 152 | !------------------------------------------- variables ! 153 | integer :: hpos 154 | integer :: head,tail 155 | integer :: imin,imax 156 | real(kind=dp) :: deli,delh 157 | real(kind=dp) :: hh00,hsqr 158 | real(kind=dp) :: dfx1,dfx2 159 | real(kind=dp) :: oval 160 | 161 | !------------------- calc. lower//upper stencil bounds ! 162 | 163 | head = 1; tail = npos - 1 164 | 165 | if(wlim.eq.mono_limit) then 166 | 167 | !---------------------- deactivate WENO at boundaries ! 168 | 169 | if (ipos-halo.lt.head) then 170 | 171 | omax = 1.d0 172 | omin = 0.d0 ; return 173 | 174 | end if 175 | 176 | if (ipos+halo.gt.tail) then 177 | 178 | omax = 1.d0 179 | omin = 0.d0 ; return 180 | 181 | end if 182 | 183 | end if 184 | 185 | !---------------------- truncate stencil at boundaries ! 186 | 187 | imin = max(ipos-halo,head) 188 | imax = min(ipos+halo,tail) 189 | 190 | !------------------ find min/max indicators on stencil ! 191 | 192 | dfx1 = oscl(1,ivar,ipos) 193 | dfx2 = oscl(2,ivar,ipos) 194 | 195 | hh00 = delx(ipos+0)**1 196 | hsqr = delx(ipos+0)**2 197 | 198 | oval =(hh00 * dfx1)**2 & 199 | & +(hsqr * dfx2)**2 200 | 201 | omin = oval 202 | omax = oval 203 | 204 | !---------------------------------------- "lower" part ! 205 | 206 | delh = 0.d0 207 | 208 | do hpos = ipos-1, imin, -1 209 | 210 | !------------------ calc. derivatives centred on IPOS. ! 211 | 212 | deli = delx(hpos+0) & 213 | & + delx(hpos+1) 214 | 215 | delh = delh + deli*.5d0 216 | 217 | dfx1 = oscl(1,ivar,hpos) 218 | dfx2 = oscl(2,ivar,hpos) 219 | 220 | dfx1 = dfx1 + dfx2*delh 221 | 222 | !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! 223 | 224 | oval = (hh00 * dfx1)**2 & 225 | & + (hsqr * dfx2)**2 226 | 227 | if (oval .lt. omin) then 228 | omin = oval 229 | else & 230 | & if (oval .gt. omax) then 231 | omax = oval 232 | end if 233 | 234 | end do 235 | 236 | !---------------------------------------- "upper" part ! 237 | 238 | delh = 0.d0 239 | 240 | do hpos = ipos+1, imax, +1 241 | 242 | !------------------ calc. derivatives centred on IPOS. ! 243 | 244 | deli = delx(hpos+0) & 245 | & + delx(hpos-1) 246 | 247 | delh = delh - deli*.5d0 248 | 249 | dfx1 = oscl(1,ivar,hpos) 250 | dfx2 = oscl(2,ivar,hpos) 251 | 252 | dfx1 = dfx1 + dfx2*delh 253 | 254 | !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! 255 | 256 | oval = (hh00 * dfx1)**2 & 257 | & + (hsqr * dfx2)**2 258 | 259 | if (oval .lt. omin) then 260 | omin = oval 261 | else & 262 | & if (oval .gt. omax) then 263 | omax = oval 264 | end if 265 | 266 | end do 267 | 268 | return 269 | 270 | end subroutine 271 | 272 | pure subroutine wenoc (npos,delx,oscl,ipos, & 273 | & ivar,halo,& 274 | & wlim,omin,omax) 275 | 276 | ! 277 | ! *this is the constant grid-spacing variant . 278 | ! 279 | ! NPOS no. edges over grid. 280 | ! DELX grid-cell spacing array. SIZE(DELX) == +1 if 281 | ! the grid is uniformly spaced . 282 | ! OSCL cell-centred oscillation-detectors, where OSCL 283 | ! has SIZE = +2-by-NVAR-by-NPOS-1. OSCL is given 284 | ! by calls to OSCLI(). 285 | ! IPOS grid-cell index for which to calc. weights . 286 | ! IVAR state-var index for which to calc/ weights . 287 | ! HALO width of recon. stencil, symmetric about IPOS . 288 | ! WLIM limiter treatment at endpoints, monotonic or 289 | ! otherwise . 290 | ! OMIN min. and max. oscillation indicators over the 291 | ! OMAX local re-con. stencil . 292 | ! 293 | 294 | implicit none 295 | 296 | !------------------------------------------- arguments ! 297 | integer , intent(in) :: npos,halo 298 | integer , intent(in) :: ipos,ivar 299 | integer , intent(in) :: wlim 300 | real(kind=dp), intent(in) :: delx(1) 301 | real(kind=dp), intent(in) :: oscl(:,:,:) 302 | real(kind=dp), intent(out) :: omin,omax 303 | 304 | !------------------------------------------- variables ! 305 | integer :: hpos 306 | integer :: head,tail 307 | integer :: imin,imax 308 | real(kind=dp) :: delh 309 | real(kind=dp) :: dfx1,dfx2 310 | real(kind=dp) :: oval 311 | 312 | !------------------- calc. lower//upper stencil bounds ! 313 | 314 | head = 1; tail = npos - 1 315 | 316 | if(wlim.eq.mono_limit) then 317 | 318 | !---------------------- deactivate WENO at boundaries ! 319 | 320 | if (ipos-halo.lt.head) then 321 | 322 | omax = 1.d0 323 | omin = 0.d0 ; return 324 | 325 | end if 326 | 327 | if (ipos+halo.gt.tail) then 328 | 329 | omax = 1.d0 330 | omin = 0.d0 ; return 331 | 332 | end if 333 | 334 | end if 335 | 336 | !---------------------- truncate stencil at boundaries ! 337 | 338 | imin = max(ipos-halo,head) 339 | imax = min(ipos+halo,tail) 340 | 341 | !------------------ find min/max indicators on stencil ! 342 | 343 | dfx1 = oscl(1,ivar,ipos) 344 | dfx2 = oscl(2,ivar,ipos) 345 | 346 | oval = (2.d0**1*dfx1)**2 & 347 | & + (2.d0**2*dfx2)**2 348 | 349 | omin = oval 350 | omax = oval 351 | 352 | !---------------------------------------- "lower" part ! 353 | 354 | delh = 0.d0 * delx(1) 355 | 356 | do hpos = ipos-1, imin, -1 357 | 358 | !------------------ calc. derivatives centred on IPOS. ! 359 | 360 | delh = delh + 2.d0 361 | 362 | dfx1 = oscl(1,ivar,hpos) 363 | dfx2 = oscl(2,ivar,hpos) 364 | 365 | dfx1 = dfx1 + dfx2*delh 366 | 367 | !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! 368 | 369 | oval = (2.d0**1*dfx1)**2 & 370 | & + (2.d0**2*dfx2)**2 371 | 372 | if (oval .lt. omin) then 373 | omin = oval 374 | else & 375 | & if (oval .gt. omax) then 376 | omax = oval 377 | end if 378 | 379 | end do 380 | 381 | !---------------------------------------- "upper" part ! 382 | 383 | delh = 0.d0 * delx(1) 384 | 385 | do hpos = ipos+1, imax, +1 386 | 387 | !------------------ calc. derivatives centred on IPOS. ! 388 | 389 | delh = delh - 2.d0 390 | 391 | dfx1 = oscl(1,ivar,hpos) 392 | dfx2 = oscl(2,ivar,hpos) 393 | 394 | dfx1 = dfx1 + dfx2*delh 395 | 396 | !------------------ indicator: NORM(H^N * D^N/DX^N(F)) ! 397 | 398 | oval = (2.d0**1*dfx1)**2 & 399 | & + (2.d0**2*dfx2)**2 400 | 401 | if (oval .lt. omin) then 402 | omin = oval 403 | else & 404 | & if (oval .gt. omax) then 405 | omax = oval 406 | end if 407 | 408 | end do 409 | 410 | return 411 | 412 | end subroutine 413 | 414 | 415 | 416 | -------------------------------------------------------------------------------- /src/plm.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! PLM.f90: a 1d, slope-limited piecewise linear method. 31 | ! 32 | ! Darren Engwirda 33 | ! 25-Oct-2021 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | pure subroutine plm(npos,nvar,ndof,delx, & 39 | & fdat,fhat,ilim) 40 | 41 | ! 42 | ! NPOS no. edges over grid. 43 | ! NVAR no. state variables. 44 | ! NDOF no. degrees-of-freedom per grid-cell . 45 | ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if 46 | ! spacing is uniform . 47 | ! FDAT grid-cell moments array. FDAT is an array with 48 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 49 | ! FHAT grid-cell re-con. array. FHAT is an array with 50 | ! SIZE = MDOF-by-NVAR-by-NPOS-1 . 51 | ! ILIM cell slope-limiting selection . 52 | ! 53 | 54 | implicit none 55 | 56 | !------------------------------------------- arguments ! 57 | integer , intent( in) :: npos,nvar 58 | integer , intent( in) :: ndof,ilim 59 | real(kind=dp), intent( in) :: delx(:) 60 | real(kind=dp), intent(out) :: fhat(:,:,:) 61 | real(kind=dp), intent( in) :: fdat(:,:,:) 62 | 63 | if (size(delx).gt.+1) then 64 | 65 | !------------------------------- variable grid-spacing ! 66 | 67 | call plmv(npos,nvar,ndof,fdat,fhat,ilim, & 68 | & delx) 69 | 70 | else 71 | 72 | !------------------------------- constant grid-spacing ! 73 | 74 | call plmc(npos,nvar,ndof,fdat,fhat,ilim) 75 | 76 | end if 77 | 78 | return 79 | 80 | end subroutine 81 | 82 | !------------------------- assemble PLM reconstruction ! 83 | 84 | pure subroutine plmv(npos,nvar,ndof,fdat,fhat,ilim, & 85 | & delx) 86 | 87 | ! 88 | ! *this is the variable grid-spacing variant . 89 | ! 90 | ! NPOS no. edges over grid. 91 | ! NVAR no. state variables. 92 | ! NDOF no. degrees-of-freedom per grid-cell . 93 | ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if 94 | ! spacing is uniform . 95 | ! FDAT grid-cell moments array. FDAT is an array with 96 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 97 | ! FHAT grid-cell re-con. array. FHAT is an array with 98 | ! SIZE = MDOF-by-NVAR-by-NPOS-1 . 99 | ! ILIM cell slope-limiting selection . 100 | ! 101 | 102 | implicit none 103 | 104 | !------------------------------------------- arguments ! 105 | integer , intent( in) :: npos,nvar 106 | integer , intent( in) :: ndof,ilim 107 | real(kind=dp), intent( in) :: delx(:) 108 | real(kind=dp), intent(out) :: fhat(:,:,:) 109 | real(kind=dp), intent( in) :: fdat(:,:,:) 110 | 111 | !------------------------------------------- variables ! 112 | integer :: ipos,ivar 113 | integer :: head,tail 114 | real(kind=dp) :: dfds(-1:+1) 115 | 116 | head = +1; tail = npos - 1 117 | 118 | if (npos.eq.2) then 119 | !----------------------- reduce order if small stencil ! 120 | do ivar = +1, nvar 121 | fhat(1,ivar,1) = & 122 | & fdat(1,ivar,1) 123 | fhat(2,ivar,1) = 0.d+0 124 | end do 125 | end if 126 | 127 | if (ndof.le.0) return 128 | if (npos.le.2) return 129 | 130 | !-------------------------------------- lower-endpoint ! 131 | 132 | do ivar = +1 , nvar-0 133 | 134 | call plsv(dfds,ilim , & 135 | & fdat(1,ivar,head+0) , & 136 | & delx(head+0), & 137 | & fdat(1,ivar,head+0) , & 138 | & delx(head+0), & 139 | & fdat(1,ivar,head+1) , & 140 | & delx(head+1)) 141 | 142 | fhat(1,ivar,head) = & 143 | & fdat(1,ivar,head) 144 | fhat(2,ivar,head) = dfds(0) 145 | 146 | end do 147 | 148 | !-------------------------------------- upper-endpoint ! 149 | 150 | do ivar = +1 , nvar-0 151 | 152 | call plsv(dfds,ilim , & 153 | & fdat(1,ivar,tail-1) , & 154 | & delx(tail-1), & 155 | & fdat(1,ivar,tail+0) , & 156 | & delx(tail+0), & 157 | & fdat(1,ivar,tail+0) , & 158 | & delx(tail+0)) 159 | 160 | fhat(1,ivar,tail) = & 161 | & fdat(1,ivar,tail) 162 | fhat(2,ivar,tail) = dfds(0) 163 | 164 | end do 165 | 166 | !-------------------------------------- interior cells ! 167 | 168 | do ipos = +2 , npos-2 169 | do ivar = +1 , nvar-0 170 | 171 | call plsv(dfds,ilim , & 172 | & fdat(1,ivar,ipos-1) , & 173 | & delx(ipos-1), & 174 | & fdat(1,ivar,ipos+0) , & 175 | & delx(ipos+0), & 176 | & fdat(1,ivar,ipos+1) , & 177 | & delx(ipos+1)) 178 | 179 | fhat(1,ivar,ipos) = & 180 | & fdat(1,ivar,ipos) 181 | fhat(2,ivar,ipos) = dfds(0) 182 | 183 | end do 184 | end do 185 | 186 | return 187 | 188 | end subroutine 189 | 190 | !------------------------- assemble PLM reconstruction ! 191 | 192 | pure subroutine plmc(npos,nvar,ndof,fdat,fhat,ilim) 193 | 194 | ! 195 | ! *this is the constant grid-spacing variant . 196 | ! 197 | ! NPOS no. edges over grid. 198 | ! NVAR no. state variables. 199 | ! NDOF no. degrees-of-freedom per grid-cell . 200 | ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if 201 | ! spacing is uniform . 202 | ! FDAT grid-cell moments array. FDAT is an array with 203 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 204 | ! FHAT grid-cell re-con. array. FHAT is an array with 205 | ! SIZE = MDOF-by-NVAR-by-NPOS-1 . 206 | ! ILIM cell slope-limiting selection . 207 | ! 208 | 209 | implicit none 210 | 211 | !------------------------------------------- arguments ! 212 | integer , intent( in) :: npos,nvar 213 | integer , intent( in) :: ndof,ilim 214 | real(kind=dp), intent(out) :: fhat(:,:,:) 215 | real(kind=dp), intent( in) :: fdat(:,:,:) 216 | 217 | !------------------------------------------- variables ! 218 | integer :: ipos,ivar 219 | integer :: head,tail 220 | real(kind=dp) :: dfds(-1:+1) 221 | 222 | head = +1; tail = npos - 1 223 | 224 | if (npos.eq.2) then 225 | !----------------------- reduce order if small stencil ! 226 | do ivar = +1, nvar 227 | fhat(1,ivar,1) = & 228 | & fdat(1,ivar,1) 229 | fhat(2,ivar,1) = 0.d+0 230 | end do 231 | end if 232 | 233 | if (ndof.le.0) return 234 | if (npos.le.2) return 235 | 236 | !-------------------------------------- lower-endpoint ! 237 | 238 | do ivar = +1 , nvar-0 239 | 240 | call plsc(dfds,ilim , & 241 | & fdat(1,ivar,head+0) , & 242 | & fdat(1,ivar,head+0) , & 243 | & fdat(1,ivar,head+1)) 244 | 245 | fhat(1,ivar,head) = & 246 | & fdat(1,ivar,head) 247 | fhat(2,ivar,head) = dfds(0) 248 | 249 | end do 250 | 251 | !-------------------------------------- upper-endpoint ! 252 | 253 | do ivar = +1 , nvar-0 254 | 255 | call plsc(dfds,ilim , & 256 | & fdat(1,ivar,tail-1) , & 257 | & fdat(1,ivar,tail+0) , & 258 | & fdat(1,ivar,tail+0)) 259 | 260 | fhat(1,ivar,tail) = & 261 | & fdat(1,ivar,tail) 262 | fhat(2,ivar,tail) = dfds(0) 263 | 264 | end do 265 | 266 | !-------------------------------------- interior cells ! 267 | 268 | do ipos = +2 , npos-2 269 | do ivar = +1 , nvar-0 270 | 271 | call plsc(dfds,ilim , & 272 | & fdat(1,ivar,ipos-1) , & 273 | & fdat(1,ivar,ipos+0) , & 274 | & fdat(1,ivar,ipos+1)) 275 | 276 | fhat(1,ivar,ipos) = & 277 | & fdat(1,ivar,ipos) 278 | fhat(2,ivar,ipos) = dfds(0) 279 | 280 | end do 281 | end do 282 | 283 | return 284 | 285 | end subroutine 286 | 287 | !------------------------------- assemble PLM "slopes" ! 288 | 289 | pure subroutine plsv(dfds,ilim,ffll,hhll, & 290 | & ff00,hh00,ffrr,hhrr) 291 | 292 | ! 293 | ! *this is the variable grid-spacing variant . 294 | ! 295 | ! DFDS piecewise linear gradients in local co-ord.'s. 296 | ! DFDS(+0) is a centred, slope-limited estimate, 297 | ! DFDS(-1), DFDS(+1) are left- and right-biased 298 | ! estimates (un-limited). 299 | ! FFLL left -biased grid-cell mean. 300 | ! HHLL left -biased grid-cell spac. 301 | ! FF00 centred grid-cell mean. 302 | ! HH00 centred grid-cell spac. 303 | ! FFRR right-biased grid-cell mean. 304 | ! HHRR right-biased grid-cell spac. 305 | ! 306 | 307 | implicit none 308 | 309 | !------------------------------------------- arguments ! 310 | integer , intent( in) :: ilim 311 | real(kind=dp), intent( in) :: ffll,ff00,ffrr 312 | real(kind=dp), intent( in) :: hhll,hh00,hhrr 313 | real(kind=dp), intent(out) :: dfds(-1:+1) 314 | 315 | !------------------------------------------- variables ! 316 | real(kind=dp) :: fell,ferr,scal 317 | 318 | real(kind=dp), parameter :: ZERO = 1.d-14 319 | 320 | !---------------------------- 2nd-order approximations ! 321 | 322 | if (ilim .eq. null_limit) then 323 | 324 | !---------------------------- calc. centred derivative ! 325 | 326 | fell = (hh00*ffll+hhll*ff00) & 327 | & / (hhll+hh00) 328 | ferr = (hhrr*ff00+hh00*ffrr) & 329 | & / (hh00+hhrr) 330 | 331 | dfds(-1) = (ff00 - ffll) & 332 | & / (hhll + hh00) * hh00 333 | dfds(+1) = (ffrr - ff00) & 334 | & / (hh00 + hhrr) * hh00 335 | 336 | dfds(+0) = & 337 | & 0.5d+0 * (ferr - fell) 338 | 339 | return 340 | 341 | end if 342 | 343 | !---------------------------- calc. limited PLM slopes ! 344 | 345 | dfds(-1) = ff00-ffll 346 | dfds(+1) = ffrr-ff00 347 | 348 | if (dfds(-1) * & 349 | & dfds(+1) .gt. 0.0d+0) then 350 | 351 | !---------------------------- calc. ll//rr edge values ! 352 | 353 | fell = (hh00*ffll+hhll*ff00) & 354 | & / (hhll+hh00) 355 | ferr = (hhrr*ff00+hh00*ffrr) & 356 | & / (hh00+hhrr) 357 | 358 | !---------------------------- calc. centred derivative ! 359 | 360 | dfds(+0) = & 361 | & 0.5d+0 * (ferr - fell) 362 | 363 | !---------------------------- monotonic slope-limiting ! 364 | 365 | scal = min(abs(dfds(-1)), & 366 | & abs(dfds(+1))) & 367 | & / max(abs(dfds(+0)), & 368 | ZERO) 369 | scal = min(scal,+1.0d+0) 370 | 371 | dfds(+0) = scal * dfds(+0) 372 | 373 | else 374 | 375 | !---------------------------- flatten if local extrema ! 376 | 377 | dfds(+0) = +0.0d+0 378 | 379 | end if 380 | 381 | !---------------------------- scale onto local co-ord. ! 382 | 383 | dfds(-1) = dfds(-1) & 384 | & / (hhll + hh00) * hh00 385 | dfds(+1) = dfds(+1) & 386 | & / (hh00 + hhrr) * hh00 387 | 388 | return 389 | 390 | end subroutine 391 | 392 | !------------------------------- assemble PLM "slopes" ! 393 | 394 | pure subroutine plsc(dfds,ilim,ffll,ff00,ffrr) 395 | 396 | ! 397 | ! *this is the constant grid-spacing variant . 398 | ! 399 | ! DFDS piecewise linear gradients in local co-ord.'s. 400 | ! DFDS(+0) is a centred, slope-limited estimate, 401 | ! DFDS(-1), DFDS(+1) are left- and right-biased 402 | ! estimates (un-limited). 403 | ! FFLL left -biased grid-cell mean. 404 | ! FF00 centred grid-cell mean. 405 | ! FFRR right-biased grid-cell mean. 406 | ! 407 | 408 | implicit none 409 | 410 | !------------------------------------------- arguments ! 411 | integer , intent( in) :: ilim 412 | real(kind=dp), intent( in) :: ffll,ff00,ffrr 413 | real(kind=dp), intent(out) :: dfds(-1:+1) 414 | 415 | !------------------------------------------- variables ! 416 | real(kind=dp) :: fell,ferr,scal 417 | 418 | real(kind=dp), parameter :: ZERO = 1.d-14 419 | 420 | !---------------------------- 2nd-order approximations ! 421 | 422 | if (ilim .eq. null_limit) then 423 | 424 | !---------------------------- calc. centred derivative ! 425 | 426 | fell = (ffll+ff00) * .5d+0 427 | ferr = (ff00+ffrr) * .5d+0 428 | 429 | dfds(-1) = & 430 | & 0.5d+0 * (ff00 - ffll) 431 | dfds(+1) = & 432 | & 0.5d+0 * (ffrr - ff00) 433 | 434 | dfds(+0) = & 435 | & 0.5d+0 * (ferr - fell) 436 | 437 | return 438 | 439 | end if 440 | 441 | !---------------------------- calc. limited PLM slopes ! 442 | 443 | dfds(-1) = ff00-ffll 444 | dfds(+1) = ffrr-ff00 445 | 446 | if (dfds(-1) * & 447 | & dfds(+1) .gt. 0.0d+0) then 448 | 449 | !---------------------------- calc. ll//rr edge values ! 450 | 451 | fell = (ffll+ff00) * .5d+0 452 | ferr = (ff00+ffrr) * .5d+0 453 | 454 | !---------------------------- calc. centred derivative ! 455 | 456 | dfds(+0) = & 457 | & 0.5d+0 * (ferr - fell) 458 | 459 | !---------------------------- monotonic slope-limiting ! 460 | 461 | scal = min(abs(dfds(-1)), & 462 | & abs(dfds(+1))) & 463 | & / max(abs(dfds(+0)), & 464 | ZERO) 465 | scal = min(scal,+1.0d+0) 466 | 467 | dfds(+0) = scal * dfds(+0) 468 | 469 | else 470 | 471 | !---------------------------- flatten if local extrema ! 472 | 473 | dfds(+0) = +0.0d+0 474 | 475 | end if 476 | 477 | !---------------------------- scale onto local co-ord. ! 478 | 479 | dfds(-1) = + 0.5d+0 * dfds(-1) 480 | dfds(+1) = + 0.5d+0 * dfds(+1) 481 | 482 | return 483 | 484 | end subroutine 485 | 486 | 487 | 488 | -------------------------------------------------------------------------------- /src/rmap1d.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! RMAP1D.f90: high-order integral re-mapping operators. 31 | ! 32 | ! Darren Engwirda 33 | ! 25-Oct-2021 34 | ! ​d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | subroutine rmap1d(npos,nnew,nvar,ndof,xpos, & 39 | & xnew,fdat,fnew,bclo,bcup, & 40 | & work,opts,tCPU) 41 | 42 | ! 43 | ! NPOS no. edges in old grid. 44 | ! NNEW no. edges in new grid. 45 | ! NVAR no. discrete variables to remap. 46 | ! NDOF no. degrees-of-freedom per cell. 47 | ! XPOS old grid edge positions. XPOS is a length NPOS 48 | ! array . 49 | ! XNEW new grid edge positions. XNEW is a length NNEW 50 | ! array . 51 | ! FDAT grid-cell moments on old grid. FNEW has SIZE = 52 | ! NDOF-by-NVAR-by-NNEW-1 . 53 | ! FNEW grid-cell moments on new grid. FNEW has SIZE = 54 | ! NDOF-by-NVAR-by-NNEW-1 . 55 | ! BCLO boundary condition at lower endpoint . 56 | ! BCHI boundary condition at upper endpoint . 57 | ! WORK method work-space. See RCON-WORK for details . 58 | ! OPTS method parameters. See RCON-OPTS for details . 59 | ! TCPU method tcpu-timer. 60 | ! 61 | 62 | implicit none 63 | 64 | !------------------------------------------- arguments ! 65 | integer , intent(in) :: npos,nnew 66 | integer , intent(in) :: nvar,ndof 67 | class(rmap_work), intent(inout) :: work 68 | class(rmap_opts), intent(inout) :: opts 69 | real(kind=dp) , intent(in) :: xpos(:) 70 | real(kind=dp) , intent(in) :: xnew(:) 71 | real(kind=dp) , intent(in) :: fdat(:,:,:) 72 | real(kind=dp) , intent(out) :: fnew(:,:,:) 73 | type (rcon_ends), intent(in) :: bclo(:) 74 | type (rcon_ends), intent(in) :: bcup(:) 75 | type (rmap_tics), & 76 | & intent(inout) , optional :: tCPU 77 | 78 | if (xpos(npos) .ge. xpos(1)) then ! +ve xdir 79 | 80 | call xmap1d(npos,nnew,nvar,ndof, & 81 | & xpos(+1:npos:+1), & 82 | & xnew(+1:nnew:+1), & 83 | & fdat(:,:,+1:npos-1:+1), & 84 | & fnew(:,:,+1:nnew-1:+1), & 85 | & bclo,bcup,work,opts,tCPU) 86 | 87 | else ! -ve xdir 88 | 89 | call xmap1d(npos,nnew,nvar,ndof, & 90 | & xpos(npos:+1:-1), & 91 | & xnew(nnew:+1:-1), & 92 | & fdat(:,:,npos-1:+1:-1), & 93 | & fnew(:,:,nnew-1:+1:-1), & 94 | & bcup,bclo,work,opts,tCPU) ! bc. flip 95 | 96 | end if 97 | 98 | return 99 | 100 | end subroutine 101 | 102 | subroutine xmap1d(npos,nnew,nvar,ndof,xpos, & 103 | & xnew,fdat,fnew,bclo,bcup, & 104 | & work,opts,tCPU) 105 | 106 | ! 107 | ! NPOS no. edges in old grid. 108 | ! NNEW no. edges in new grid. 109 | ! NVAR no. discrete variables to remap. 110 | ! NDOF no. degrees-of-freedom per cell. 111 | ! XPOS old grid edge positions. XPOS is a length NPOS 112 | ! array . 113 | ! XNEW new grid edge positions. XNEW is a length NNEW 114 | ! array . 115 | ! FDAT grid-cell moments on old grid. FNEW has SIZE = 116 | ! NDOF-by-NVAR-by-NNEW-1 . 117 | ! FNEW grid-cell moments on new grid. FNEW has SIZE = 118 | ! NDOF-by-NVAR-by-NNEW-1 . 119 | ! BCLO boundary condition at lower endpoint . 120 | ! BCHI boundary condition at upper endpoint . 121 | ! WORK method work-space. See RCON-WORK for details . 122 | ! OPTS method parameters. See RCON-OPTS for details . 123 | ! TCPU method tcpu-timer. 124 | ! 125 | 126 | implicit none 127 | 128 | !------------------------------------------- arguments ! 129 | integer , intent(in) :: npos,nnew 130 | integer , intent(in) :: nvar,ndof 131 | class(rmap_work), intent(inout) :: work 132 | class(rmap_opts), intent(inout) :: opts 133 | real(kind=dp) , intent(in) :: xpos(:) 134 | real(kind=dp) , intent(in) :: xnew(:) 135 | real(kind=dp) , intent(in) :: fdat(:,:,:) 136 | real(kind=dp) , intent(out) :: fnew(:,:,:) 137 | type (rcon_ends), intent(in) :: bclo(:) 138 | type (rcon_ends), intent(in) :: bcup(:) 139 | type (rmap_tics), & 140 | & intent(inout) , optional :: tCPU 141 | 142 | real(kind=dp), parameter :: RTOL = +1.d-14 143 | 144 | !------------------------------------------- variables ! 145 | integer :: ipos 146 | real(kind=dp) :: diff,spac 147 | real(kind=dp) :: same,xtol 148 | real(kind=dp) :: delx(1) 149 | logical :: uniform 150 | 151 | # ifdef __PPR_TIMER__ 152 | integer(kind=8) :: ttic,ttoc,rate 153 | # endif 154 | 155 | if (ndof.lt.1) return 156 | if (npos.lt.2) return 157 | if (nnew.lt.2) return 158 | if (nvar.lt.1) return 159 | 160 | !------------- calc. grid-spacing and check uniformity ! 161 | 162 | same = (xpos(npos)& 163 | - xpos( +1)) / (npos-1) 164 | 165 | uniform = .true. 166 | 167 | xtol = same * RTOL 168 | 169 | do ipos = +1 , npos-1, +1 170 | 171 | spac = xpos(ipos+1) & 172 | & - xpos(ipos+0) 173 | 174 | diff = abs(spac - same) 175 | 176 | if (diff.gt.xtol) then 177 | 178 | uniform = .false. 179 | 180 | end if 181 | 182 | work% & 183 | & cell_spac(ipos) = spac 184 | 185 | end do 186 | 187 | !uniform = .false. 188 | 189 | !------------- reconstruct FHAT over all cells in XPOS ! 190 | 191 | if (.not. uniform) then 192 | 193 | !------------------------------------ variable spacing ! 194 | call rcon1d(npos,nvar,ndof, & 195 | & work%cell_spac, & 196 | & fdat,bclo,bcup, & 197 | & work%cell_func, & 198 | & work,opts,tCPU) 199 | 200 | else 201 | 202 | !------------------------------------ constant spacing ! 203 | delx(1) = work%cell_spac(1) 204 | 205 | call rcon1d(npos,nvar,ndof, & 206 | & delx, & 207 | & fdat,bclo,bcup, & 208 | & work%cell_func, & 209 | & work,opts,tCPU) 210 | 211 | end if 212 | 213 | !------------- remap FDAT from XPOS to XNEW using FHAT ! 214 | 215 | __TIC__ 216 | 217 | select case(opts%cell_meth) 218 | case(pcm_method) 219 | !------------------------------------ 1st-order method ! 220 | call imap1d(npos,nnew,nvar, & 221 | & ndof, +1, & 222 | & xpos,xnew, & 223 | & work%cell_func, & 224 | & fdat,fnew,xtol) 225 | 226 | case(plm_method) 227 | !------------------------------------ 2nd-order method ! 228 | call imap1d(npos,nnew,nvar, & 229 | & ndof, +2, & 230 | & xpos,xnew, & 231 | & work%cell_func, & 232 | & fdat,fnew,xtol) 233 | 234 | case(ppm_method) 235 | !------------------------------------ 3rd-order method ! 236 | call imap1d(npos,nnew,nvar, & 237 | & ndof, +3, & 238 | & xpos,xnew, & 239 | & work%cell_func, & 240 | & fdat,fnew,xtol) 241 | 242 | case(pqm_method) 243 | !------------------------------------ 5th-order method ! 244 | call imap1d(npos,nnew,nvar, & 245 | & ndof, +5, & 246 | & xpos,xnew, & 247 | & work%cell_func, & 248 | & fdat,fnew,xtol) 249 | 250 | end select 251 | 252 | __TOC__(tCPU,rmap_time) 253 | 254 | return 255 | 256 | end subroutine 257 | 258 | !------------ IMAP1D: 1-dimensional degree-k remapping ! 259 | 260 | pure subroutine imap1d(npos,nnew,nvar,ndof, & 261 | & mdof,xpos,xnew,fhat, & 262 | & fdat,fnew,XTOL) 263 | 264 | ! 265 | ! NPOS no. edges in old grid. 266 | ! NNEW no. edges in new grid. 267 | ! NVAR no. discrete variables to remap. 268 | ! NDOF no. degrees-of-freedom per cell. 269 | ! MDOF no. degrees-of-freedom per FHAT. 270 | ! XPOS old grid edge positions. XPOS is a length NPOS 271 | ! array . 272 | ! XNEW new grid edge positions. XNEW is a length NNEW 273 | ! array . 274 | ! FHAT reconstruction over old grid. FHAT has SIZE = 275 | ! MDOF-by-NVAR-by-NPOS-1 . 276 | ! FDAT grid-cell moments on old grid. FDAT has SIZE = 277 | ! NDOF-by-NVAR-by-NPOS-1 . 278 | ! FNEW grid-cell moments on new grid. FNEW has SIZE = 279 | ! NDOF-by-NVAR-by-NNEW-1 . 280 | ! XTOL min. grid-cell thickness . 281 | ! 282 | 283 | implicit none 284 | 285 | !------------------------------------------- arguments ! 286 | integer , intent( in) :: npos,nnew 287 | integer , intent( in) :: nvar 288 | integer , intent( in) :: ndof,mdof 289 | real(kind=dp), intent( in) :: xpos(:) 290 | real(kind=dp), intent( in) :: xnew(:) 291 | real(kind=dp), intent( in) :: fhat(:,:,:) 292 | real(kind=dp), intent( in) :: fdat(:,:,:) 293 | real(kind=dp), intent(out) :: fnew(:,:,:) 294 | real(kind=dp), intent( in) :: XTOL 295 | 296 | !------------------------------------------- variables ! 297 | integer :: kpos,ipos,ivar,idof 298 | integer :: pos0,pos1,vmin,vmax 299 | integer :: kmin(+1:nvar) 300 | integer :: kmax(+1:nvar) 301 | real(kind=dp) :: xmid,xhat,khat 302 | real(kind=dp) :: xxlo,xxhi,sslo,sshi 303 | real(kind=dp) :: intf 304 | real(kind=dp) :: vvlo(+1:+5) 305 | real(kind=dp) :: vvhi(+1:+5) 306 | real(kind=dp) :: ivec(+1:+5) 307 | real(kind=dp) :: sdat,snew,serr,stmp 308 | 309 | integer, parameter :: INTB = -1 ! integral basis 310 | 311 | !------------- remap FDAT from XPOS to XNEW using FHAT ! 312 | 313 | kmin = +1 ; kmax = +1 314 | pos0 = +1 ; pos1 = +1 315 | 316 | vvlo = 0.d+0; vvhi = 0.d+0; ivec = 0.d+0 317 | 318 | do kpos = +1, nnew-1 319 | 320 | !------ first cell in XPOS overlapping with XNEW(KPOS) ! 321 | 322 | pos1 = max(pos1,1) 323 | 324 | do pos0 = pos1, npos-1 325 | 326 | if (xpos(pos0+1)& 327 | & .gt. xnew(kpos+0)) exit 328 | 329 | end do 330 | 331 | !------ final cell in XPOS overlapping with XNEW(KPOS) ! 332 | 333 | do pos1 = pos0, npos-1 334 | 335 | if (xpos(pos1+0)& 336 | & .ge. xnew(kpos+1)) exit 337 | 338 | end do 339 | 340 | pos1 = pos1 - 1 341 | 342 | !------------- integrate FHAT across overlapping cells ! 343 | 344 | khat = xnew(kpos+1) & 345 | & - xnew(kpos+0) 346 | khat = max (khat , XTOL) 347 | 348 | do idof = +1,ndof 349 | do ivar = +1,nvar 350 | 351 | fnew(idof,ivar,kpos) = 0.d0 352 | 353 | end do 354 | end do 355 | 356 | do ipos = pos0, pos1 357 | 358 | !------------------------------- integration endpoints ! 359 | 360 | xxlo = max (xpos(ipos+0) , & 361 | & xnew(kpos+0)) 362 | xxhi = min (xpos(ipos+1) , & 363 | & xnew(kpos+1)) 364 | 365 | !------------------------------- local endpoint coords ! 366 | 367 | xmid = xpos(ipos+1) * .5d0 & 368 | & + xpos(ipos+0) * .5d0 369 | xhat = xpos(ipos+1) * .5d0 & 370 | & - xpos(ipos+0) * .5d0 371 | 372 | sslo = & 373 | & (xxlo-xmid) / max(xhat,XTOL) 374 | sshi = & 375 | & (xxhi-xmid) / max(xhat,XTOL) 376 | 377 | !------------------------------- integral basis vector ! 378 | 379 | call bfun1d(INTB,mdof, & 380 | sslo,vvlo) 381 | call bfun1d(INTB,mdof, & 382 | sshi,vvhi) 383 | 384 | ivec = vvhi - vvlo 385 | 386 | !--------- integrate FHAT across the overlap XXLO:XXHI ! 387 | 388 | do ivar = +1, nvar 389 | 390 | intf = dot_product ( & 391 | & ivec(1:mdof), & 392 | & fhat(1:mdof,ivar,ipos - 0)) 393 | 394 | intf = intf * xhat 395 | 396 | !--------- accumulate integral contributions from IPOS ! 397 | 398 | fnew( +1,ivar,kpos) = & 399 | & fnew( +1,ivar,kpos) + intf 400 | 401 | end do 402 | 403 | end do 404 | 405 | !------------------------------- finalise KPOS profile ! 406 | 407 | do ivar = +1, nvar 408 | 409 | fnew( +1,ivar,kpos) = & 410 | & fnew( +1,ivar,kpos) / khat 411 | 412 | !--------- keep track of MIN/MAX for defect correction ! 413 | 414 | vmax = kmax(ivar) 415 | vmin = kmin(ivar) 416 | 417 | if(fnew(1,ivar,kpos) & 418 | & .gt.fnew(1,ivar,vmax) ) then 419 | 420 | kmax(ivar) = kpos 421 | 422 | else & 423 | & if(fnew(1,ivar,kpos) & 424 | & .lt.fnew(1,ivar,vmin) ) then 425 | 426 | kmin(ivar) = kpos 427 | 428 | end if 429 | 430 | end do 431 | 432 | end do 433 | 434 | !--------- defect corrections: approx. FP conservation ! 435 | 436 | do ivar = +1, nvar-0 437 | 438 | ! Carefully compute column sums, leading to a defect 439 | ! wrt. column-wise conservation. Use KBN approach to 440 | ! account for FP roundoff. 441 | 442 | sdat = 0.d0; serr = 0.d0 443 | do ipos = +1, npos-1 444 | 445 | !------------------------------- integrate old profile ! 446 | 447 | xhat = xpos(ipos+1) & 448 | & - xpos(ipos+0) 449 | 450 | intf = xhat * fdat(+1,ivar,ipos) 451 | 452 | stmp = sdat + intf 453 | 454 | if (abs(sdat).ge.abs(intf)) then 455 | 456 | serr = & 457 | & serr + ((sdat-stmp)+intf) 458 | 459 | else 460 | 461 | serr = & 462 | & serr + ((intf-stmp)+sdat) 463 | 464 | end if 465 | 466 | sdat = stmp 467 | 468 | end do 469 | 470 | sdat = sdat + serr 471 | 472 | snew = 0.d0; serr = 0.d0 473 | do ipos = +1, nnew-1 474 | 475 | !------------------------------- integrate new profile ! 476 | 477 | khat = xnew(ipos+1) & 478 | & - xnew(ipos+0) 479 | 480 | intf = khat * fnew(+1,ivar,ipos) 481 | 482 | stmp = snew + intf 483 | 484 | if (abs(snew).ge.abs(intf)) then 485 | 486 | serr = & 487 | & serr + ((snew-stmp)+intf) 488 | 489 | else 490 | 491 | serr = & 492 | & serr + ((intf-stmp)+snew) 493 | 494 | end if 495 | 496 | snew = stmp 497 | 498 | end do 499 | 500 | snew = snew + serr 501 | 502 | ! Add a correction to remapped state to impose exact 503 | ! conservation. Via sign(correction), nudge min/max. 504 | ! cell means, such that monotonicity is not violated 505 | ! near extrema... 506 | 507 | serr = sdat - snew 508 | 509 | if (serr .gt. 0.d0) then 510 | 511 | vmin = kmin(ivar) 512 | 513 | fnew(1,ivar,vmin) = & 514 | & fnew(1,ivar,vmin) + & 515 | & serr/(xnew(vmin+1)-xnew(vmin+0)) 516 | 517 | else 518 | 519 | vmax = kmax(ivar) 520 | 521 | fnew(1,ivar,vmax) = & 522 | & fnew(1,ivar,vmax) + & 523 | & serr/(xnew(vmax+1)-xnew(vmax+0)) 524 | 525 | end if 526 | 527 | !------------------------------- new profile now final ! 528 | 529 | end do 530 | 531 | return 532 | 533 | end subroutine 534 | 535 | 536 | 537 | -------------------------------------------------------------------------------- /src/pqm.f90: -------------------------------------------------------------------------------- 1 | 2 | ! 3 | ! This program may be freely redistributed under the 4 | ! condition that the copyright notices (including this 5 | ! entire header) are not removed, and no compensation 6 | ! is received through use of the software. Private, 7 | ! research, and institutional use is free. You may 8 | ! distribute modified versions of this code UNDER THE 9 | ! CONDITION THAT THIS CODE AND ANY MODIFICATIONS MADE 10 | ! TO IT IN THE SAME FILE REMAIN UNDER COPYRIGHT OF THE 11 | ! ORIGINAL AUTHOR, BOTH SOURCE AND OBJECT CODE ARE 12 | ! MADE FREELY AVAILABLE WITHOUT CHARGE, AND CLEAR 13 | ! NOTICE IS GIVEN OF THE MODIFICATIONS. Distribution 14 | ! of this code as part of a commercial system is 15 | ! permissible ONLY BY DIRECT ARRANGEMENT WITH THE 16 | ! AUTHOR. (If you are not directly supplying this 17 | ! code to a customer, and you are instead telling them 18 | ! how they can obtain it for free, then you are not 19 | ! required to make any arrangement with me.) 20 | ! 21 | ! Disclaimer: Neither I nor: Columbia University, the 22 | ! National Aeronautics and Space Administration, nor 23 | ! the Massachusetts Institute of Technology warrant 24 | ! or certify this code in any way whatsoever. This 25 | ! code is provided "as-is" to be used at your own risk. 26 | ! 27 | ! 28 | 29 | ! 30 | ! PQM.f90: a 1d slope-limited, piecewise quartic recon. 31 | ! 32 | ! Darren Engwirda 33 | ! 06-Nov-2021 34 | ! d [dot] engwirda [at] gmail [dot] com 35 | ! 36 | ! 37 | 38 | ! White, L. and Adcroft, A., A high-order finite volume 39 | ! remapping scheme for nonuniform grids: The piecewise 40 | ! quartic method (PQM), J. Comp. Phys., 227 (15), 2008, 41 | ! 7394-7422, https://doi.org/10.1016/j.jcp.2008.04.026. 42 | ! 43 | 44 | pure subroutine pqm(npos,nvar,ndof,delx, & 45 | & fdat,fhat,edge,dfdx, & 46 | & oscl,ilim,wlim,halo) 47 | 48 | ! 49 | ! NPOS no. edges over grid. 50 | ! NVAR no. state variables. 51 | ! NDOF no. degrees-of-freedom per grid-cell. 52 | ! DELX grid-cell spacing array. LENGTH(DELX) == +1 if 53 | ! spacing is uniform . 54 | ! FDAT grid-cell moments array. FDAT is an array with 55 | ! SIZE = NDOF-by-NVAR-by-NPOS-1 . 56 | ! FHAT grid-cell re-con. array. FHAT is an array with 57 | ! SIZE = MDOF-by-NVAR-by-NPOS-1 . 58 | ! EDGE edge-centred interp. for function-value. EDGE 59 | ! is an array with SIZE = NVAR-by-NPOS . 60 | ! DFDX edge-centred interp. for 1st-derivative. DFDX 61 | ! is an array with SIZE = NVAR-by-NPOS . 62 | ! OSCL grid-cell oscil. dof.'s. OSCL is an array with 63 | ! SIZE = +2 -by-NVAR-by-NPOS-1 . 64 | ! ILIM cell slope-limiting selection . 65 | ! WLIM wall slope-limiting selection . 66 | ! HALO width of re-con. stencil, symmetric about mid. . 67 | ! 68 | 69 | implicit none 70 | 71 | !------------------------------------------- arguments ! 72 | integer , intent(in) :: npos,nvar,ndof 73 | integer , intent(in) :: ilim,wlim,halo 74 | real(kind=dp), intent(out) :: fhat(:,:,:) 75 | real(kind=dp), intent(in) :: oscl(:,:,:) 76 | real(kind=dp), intent(in) :: delx(:) 77 | real(kind=dp), intent(in) :: fdat(:,:,:) 78 | real(kind=dp), intent(in) :: edge(:,:) 79 | real(kind=dp), intent(in) :: dfdx(:,:) 80 | 81 | !------------------------------------------- variables ! 82 | integer :: ipos,ivar,iill,iirr,head,tail 83 | real(kind=dp) :: ff00,ffll,ffrr,hh00,hhll,hhrr 84 | real(kind=dp) :: xhat 85 | integer :: mono 86 | real(kind=dp) :: fell,ferr 87 | real(kind=dp) :: dell,derr 88 | real(kind=dp) :: dfds(-1:+1) 89 | real(kind=dp) :: uhat(+1:+5) 90 | real(kind=dp) :: lhat(+1:+5) 91 | real(kind=dp) :: wval(+1:+2) 92 | 93 | head = +1; tail = npos - 1 94 | 95 | if (npos.le.2) then 96 | !----- default to reduced order if insufficient points ! 97 | do ivar = +1, nvar 98 | fhat(1,ivar,+1) = fdat(1,ivar,+1) 99 | fhat(2,ivar,+1) = 0.d0 100 | fhat(3,ivar,+1) = 0.d0 101 | fhat(4,ivar,+1) = 0.d0 102 | fhat(5,ivar,+1) = 0.d0 103 | end do 104 | end if 105 | 106 | if (ndof.le.0) return 107 | if (npos.le.2) return 108 | 109 | !------------------- reconstruct function on each cell ! 110 | 111 | do ipos = +1 , npos-1 112 | 113 | iill = max(head,ipos-1) 114 | iirr = min(tail,ipos+1) 115 | 116 | do ivar = +1 , nvar-0 117 | 118 | !----------------------------- cell mean + edge values ! 119 | 120 | ff00 = fdat(1,ivar,ipos) 121 | ffll = fdat(1,ivar,iill) 122 | ffrr = fdat(1,ivar,iirr) 123 | 124 | fell = edge(ivar,ipos+0) 125 | ferr = edge(ivar,ipos+1) 126 | 127 | !----------------------------- calc. LL/00/RR gradient ! 128 | 129 | if (size(delx).gt.+1) then 130 | 131 | hh00 = delx(ipos) 132 | hhll = delx(iill) 133 | hhrr = delx(iirr) 134 | 135 | xhat = delx(ipos+0)*.5d+0 136 | 137 | call plsv (dfds,mono_limit, & 138 | & ffll,hhll,ff00 , & 139 | & hh00,ffrr,hhrr) 140 | else 141 | 142 | xhat = delx( +1)*.5d+0 143 | 144 | call plsc (dfds,mono_limit, & 145 | & ffll,ff00,ffrr) 146 | 147 | end if 148 | 149 | dell = dfdx (ivar,ipos+0) 150 | dell = dell * xhat 151 | 152 | derr = dfdx (ivar,ipos+1) 153 | derr = derr * xhat 154 | 155 | !----------------------------- calc. cell-wise profile ! 156 | 157 | select case(ilim) 158 | case (null_limit) 159 | 160 | !----------------------------- calc. unlimited profile ! 161 | 162 | call pqmfn(ff00,ffll,ffrr, & 163 | & fell,ferr,dell, & 164 | & derr,dfds,uhat, & 165 | & lhat,mono) 166 | 167 | !----------------------------- pref. unlimited profile ! 168 | 169 | wval(1) = +1.d+0 170 | wval(2) = +0.d+0 171 | 172 | case (mono_limit) 173 | 174 | !----------------------------- calc. monotonic profile ! 175 | 176 | call pqmfn(ff00,ffll,ffrr, & 177 | & fell,ferr,dell, & 178 | & derr,dfds,uhat, & 179 | & lhat,mono) 180 | 181 | !----------------------------- pref. monotonic profile ! 182 | 183 | wval(1) = +0.d+0 184 | wval(2) = +1.d+0 185 | 186 | case (weno_limit) 187 | 188 | !----------------------------- calc. monotonic profile ! 189 | 190 | call pqmfn(ff00,ffll,ffrr, & 191 | & fell,ferr,dell, & 192 | & derr,dfds,uhat, & 193 | & lhat,mono) 194 | 195 | if (mono.gt.+0) then 196 | 197 | !----------------------------- calc. WENO-type weights ! 198 | 199 | call wenoi(npos,delx,oscl, & 200 | & ipos,ivar,halo, & 201 | & wlim,wval) 202 | 203 | else 204 | 205 | !----------------------------- pref. unlimited profile ! 206 | 207 | wval(1) = +1.d+0 208 | wval(2) = +0.d+0 209 | 210 | end if 211 | 212 | end select 213 | 214 | !----------------------------- blend "null" and "mono" ! 215 | 216 | fhat(1,ivar,ipos) = & 217 | & wval(1) * uhat(1) + & 218 | & wval(2) * lhat(1) 219 | fhat(2,ivar,ipos) = & 220 | & wval(1) * uhat(2) + & 221 | & wval(2) * lhat(2) 222 | fhat(3,ivar,ipos) = & 223 | & wval(1) * uhat(3) + & 224 | & wval(2) * lhat(3) 225 | fhat(4,ivar,ipos) = & 226 | & wval(1) * uhat(4) + & 227 | & wval(2) * lhat(4) 228 | fhat(5,ivar,ipos) = & 229 | & wval(1) * uhat(5) + & 230 | & wval(2) * lhat(5) 231 | 232 | end do 233 | 234 | end do 235 | 236 | return 237 | 238 | end subroutine 239 | 240 | !----------- assemble piecewise quartic reconstruction ! 241 | 242 | pure subroutine pqmfn(ff00,ffll,ffrr,fell, & 243 | & ferr,dell,derr,dfds, & 244 | & uhat,lhat,mono) 245 | 246 | ! 247 | ! FF00 centred grid-cell mean. 248 | ! FFLL left -biased grid-cell mean. 249 | ! FFRR right-biased grid-cell mean. 250 | ! FELL left -biased edge interp. 251 | ! FERR right-biased edge interp. 252 | ! DELL left -biased edge df//dx. 253 | ! DERR right-biased edge df//dx. 254 | ! DFDS piecewise linear gradients in local co-ord.'s. 255 | ! DFDS(+0) is a centred, slope-limited estimate, 256 | ! DFDS(-1), DFDS(+1) are left- and right-biased 257 | ! estimates (unlimited). 258 | ! UHAT unlimited PPM reconstruction coefficients . 259 | ! LHAT monotonic PPM reconstruction coefficients . 260 | ! MONO slope-limiting indicator, MONO > +0 if some 261 | ! limiting has occured . 262 | ! 263 | 264 | implicit none 265 | 266 | !------------------------------------------- arguments ! 267 | real(kind=dp), intent(in) :: ff00 268 | real(kind=dp), intent(in) :: ffll,ffrr 269 | real(kind=dp), intent(inout) :: fell,ferr 270 | real(kind=dp), intent(inout) :: dell,derr 271 | real(kind=dp), intent(in) :: dfds(-1:+1) 272 | real(kind=dp), intent(out) :: uhat(+1:+5) 273 | real(kind=dp), intent(out) :: lhat(+1:+5) 274 | integer , intent(out) :: mono 275 | 276 | !------------------------------------------- variables ! 277 | integer :: turn 278 | real(kind=dp) :: grad 279 | real(kind=dp) :: iflx(+1:+2) 280 | real(kind=dp) :: junk(+1:+3) 281 | logical :: haveroot 282 | 283 | !-------------------------------- "null" slope-limiter ! 284 | 285 | mono = 0 286 | 287 | uhat(1) = & 288 | & + (30.d+0 / 16.d+0) * ff00 & 289 | & - ( 7.d+0 / 16.d+0) *(ferr+fell) & 290 | & + ( 1.d+0 / 16.d+0) *(derr-dell) 291 | uhat(2) = & 292 | & + ( 3.d+0 / 4.d+0) *(ferr-fell) & 293 | & - ( 1.d+0 / 4.d+0) *(derr+dell) 294 | uhat(3) = & 295 | & - (30.d+0 / 8.d+0) * ff00 & 296 | & + (15.d+0 / 8.d+0) *(ferr+fell) & 297 | & - ( 3.d+0 / 8.d+0) *(derr-dell) 298 | uhat(4) = & 299 | & - ( 1.d+0 / 4.d+0) *(ferr-fell & 300 | & -derr-dell) 301 | uhat(5) = & 302 | & + (30.d+0 / 16.d+0) * ff00 & 303 | & - (15.d+0 / 16.d+0) *(ferr+fell) & 304 | & + ( 5.d+0 / 16.d+0) *(derr-dell) 305 | 306 | !-------------------------------- "mono" slope-limiter ! 307 | 308 | if((ffrr - ff00) * & 309 | & (ff00 - ffll) .le. 0.d+0) then 310 | 311 | !----------------------------------- "flatten" extrema ! 312 | 313 | mono = +1 314 | 315 | lhat(1) = ff00 316 | lhat(2) = 0.d0 317 | lhat(3) = 0.d0 318 | lhat(4) = 0.d0 319 | lhat(5) = 0.d0 320 | 321 | return 322 | 323 | end if 324 | 325 | !----------------------------------- limit edge slopes ! 326 | 327 | if (dell * dfds(-1) .lt. 0.d+0) then 328 | 329 | lhat(:) = 0.0d+0 330 | call ppmfn(ff00,ffll,ffrr,fell,& 331 | & ferr,dfds,junk,lhat,& 332 | & mono) 333 | mono = +1; return 334 | 335 | end if 336 | 337 | if (derr * dfds(+1) .lt. 0.d+0) then 338 | 339 | lhat(:) = 0.0d+0 340 | call ppmfn(ff00,ffll,ffrr,fell,& 341 | & ferr,dfds,junk,lhat,& 342 | & mono) 343 | mono = +1; return 344 | 345 | end if 346 | 347 | !----------------------------------- limit edge values ! 348 | 349 | if((ffll - fell) * & 350 | & (fell - ff00) .le. 0.d+0) then 351 | 352 | mono = +1 353 | fell = ff00 - dfds(0) 354 | 355 | end if 356 | 357 | if((ffrr - ferr) * & 358 | & (ferr - ff00) .le. 0.d+0) then 359 | 360 | mono = +1 361 | ferr = ff00 + dfds(0) 362 | 363 | end if 364 | 365 | !----------------------------------- limit cell values ! 366 | 367 | lhat(1) = & 368 | & + (30.d+0 / 16.d+0) * ff00 & 369 | & - ( 7.d+0 / 16.d+0) *(ferr+fell) & 370 | & + ( 1.d+0 / 16.d+0) *(derr-dell) 371 | lhat(2) = & 372 | & + ( 3.d+0 / 4.d+0) *(ferr-fell) & 373 | & - ( 1.d+0 / 4.d+0) *(derr+dell) 374 | lhat(3) = & 375 | & - (30.d+0 / 8.d+0) * ff00 & 376 | & + (15.d+0 / 8.d+0) *(ferr+fell) & 377 | & - ( 3.d+0 / 8.d+0) *(derr-dell) 378 | lhat(4) = & 379 | & - ( 1.d+0 / 4.d+0) *(ferr-fell & 380 | & -derr-dell) 381 | lhat(5) = & 382 | & + (30.d+0 / 16.d+0) * ff00 & 383 | & - (15.d+0 / 16.d+0) *(ferr+fell) & 384 | & + ( 5.d+0 / 16.d+0) *(derr-dell) 385 | 386 | !------------------ calc. inflexion via 2nd-derivative ! 387 | 388 | call roots_2(12.d+0 * lhat(5), & 389 | & 6.d+0 * lhat(4), & 390 | & 2.d+0 * lhat(3), & 391 | & iflx , haveroot ) 392 | 393 | if (haveroot) then 394 | 395 | turn = +0 396 | 397 | if ( ( iflx(1) .ge. -1.d+0 ) & 398 | & .and. ( iflx(1) .le. +1.d+0 ) ) then 399 | 400 | !------------------ check for non-monotonic inflection ! 401 | 402 | grad = lhat(2) & 403 | &+ (iflx(1)**1) * 2.d+0* lhat(3) & 404 | &+ (iflx(1)**2) * 3.d+0* lhat(4) & 405 | &+ (iflx(1)**3) * 4.d+0* lhat(5) 406 | 407 | if (grad * dfds(0) .le. 0.d+0) then 408 | 409 | ferr = ffrr 410 | fell = ffll 411 | 412 | lhat(:) = 0.0d+0 413 | call ppmfn(ff00,ffll,ffrr,fell,& 414 | & ferr,dfds,junk,lhat,& 415 | & mono) 416 | mono = +2; return 417 | 418 | 419 | 420 | if (abs(dfds(-1)) & 421 | & .lt. abs(dfds(+1)) ) then 422 | 423 | turn = -1 ! modify L 424 | 425 | else 426 | 427 | turn = +1 ! modify R 428 | 429 | end if 430 | 431 | end if 432 | 433 | end if 434 | 435 | if ( ( iflx(2) .ge. -1.d+0 ) & 436 | & .and. ( iflx(2) .le. +1.d+0 ) ) then 437 | 438 | !------------------ check for non-monotonic inflection ! 439 | 440 | grad = lhat(2) & 441 | &+ (iflx(2)**1) * 2.d+0* lhat(3) & 442 | &+ (iflx(2)**2) * 3.d+0* lhat(4) & 443 | &+ (iflx(2)**3) * 4.d+0* lhat(5) 444 | 445 | if (grad * dfds(0) .le. 0.d+0) then 446 | 447 | ferr = ffrr 448 | fell = ffll 449 | 450 | lhat(:) = 0.0d+0 451 | call ppmfn(ff00,ffll,ffrr,fell,& 452 | & ferr,dfds,junk,lhat,& 453 | & mono) 454 | mono = +2; return 455 | 456 | 457 | 458 | 459 | if (abs(dfds(-1)) & 460 | & .lt. abs(dfds(+1)) ) then 461 | 462 | turn = -1 ! modify L 463 | 464 | else 465 | 466 | turn = +1 ! modify R 467 | 468 | end if 469 | 470 | end if 471 | 472 | end if 473 | 474 | !------------------ pop non-monotone inflexion to edge ! 475 | 476 | if (turn .eq. -1) then 477 | 478 | !------------------ pop inflection points onto -1 edge ! 479 | 480 | mono = +2 481 | 482 | ferr = ffrr 483 | fell = ffll 484 | derr = & 485 | & - ( 5.d+0 / 1.d+0) * ff00 & 486 | & + ( 3.d+0 / 1.d+0) * ferr & 487 | & + ( 2.d+0 / 1.d+0) * fell 488 | dell = & 489 | & + ( 5.d+0 / 3.d+0) * ff00 & 490 | & - ( 1.d+0 / 3.d+0) * ferr & 491 | & - ( 4.d+0 / 3.d+0) * fell 492 | 493 | if (dell*dfds(-1) .lt. 0.d+0) then 494 | 495 | lhat(:) = 0.0d+0 496 | call ppmfn(ff00,ffll,ffrr,fell,& 497 | & ferr,dfds,junk,lhat,& 498 | & mono) 499 | mono = +2; return 500 | 501 | else & 502 | & if (derr*dfds(+1) .lt. 0.d+0) then 503 | 504 | lhat(:) = 0.0d+0 505 | call ppmfn(ff00,ffll,ffrr,fell,& 506 | & ferr,dfds,junk,lhat,& 507 | & mono) 508 | mono = +2; return 509 | 510 | end if 511 | 512 | lhat(1) = & 513 | & + (30.d+0 / 16.d+0) * ff00 & 514 | & - ( 7.d+0 / 16.d+0) *(ferr+fell) & 515 | & + ( 1.d+0 / 16.d+0) *(derr-dell) 516 | lhat(2) = & 517 | & + ( 3.d+0 / 4.d+0) *(ferr-fell) & 518 | & - ( 1.d+0 / 4.d+0) *(derr+dell) 519 | lhat(3) = & 520 | & - (30.d+0 / 8.d+0) * ff00 & 521 | & + (15.d+0 / 8.d+0) *(ferr+fell) & 522 | & - ( 3.d+0 / 8.d+0) *(derr-dell) 523 | lhat(4) = & 524 | & - ( 1.d+0 / 4.d+0) *(ferr-fell & 525 | & -derr-dell) 526 | lhat(5) = & 527 | & + (30.d+0 / 16.d+0) * ff00 & 528 | & - (15.d+0 / 16.d+0) *(ferr+fell) & 529 | & + ( 5.d+0 / 16.d+0) *(derr-dell) 530 | 531 | end if 532 | 533 | if (turn .eq. +1) then 534 | 535 | !------------------ pop inflection points onto +1 edge ! 536 | 537 | mono = +2 538 | 539 | ferr = ffrr 540 | fell = ffll 541 | derr = & 542 | & - ( 5.d+0 / 3.d+0) * ff00 & 543 | & + ( 4.d+0 / 3.d+0) * ferr & 544 | & + ( 1.d+0 / 3.d+0) * fell 545 | dell = & 546 | & + ( 5.d+0 / 1.d+0) * ff00 & 547 | & - ( 2.d+0 / 1.d+0) * ferr & 548 | & - ( 3.d+0 / 1.d+0) * fell 549 | 550 | if (dell*dfds(-1) .lt. 0.d+0) then 551 | 552 | lhat(:) = 0.0d+0 553 | call ppmfn(ff00,ffll,ffrr,fell,& 554 | & ferr,dfds,junk,lhat,& 555 | & mono) 556 | mono = +2; return 557 | 558 | else & 559 | & if (derr*dfds(+1) .lt. 0.d+0) then 560 | 561 | lhat(:) = 0.0d+0 562 | call ppmfn(ff00,ffll,ffrr,fell,& 563 | & ferr,dfds,junk,lhat,& 564 | & mono) 565 | mono = +2; return 566 | 567 | end if 568 | 569 | lhat(1) = & 570 | & + (30.d+0 / 16.d+0) * ff00 & 571 | & - ( 7.d+0 / 16.d+0) *(ferr+fell) & 572 | & + ( 1.d+0 / 16.d+0) *(derr-dell) 573 | lhat(2) = & 574 | & + ( 3.d+0 / 4.d+0) *(ferr-fell) & 575 | & - ( 1.d+0 / 4.d+0) *(derr+dell) 576 | lhat(3) = & 577 | & - (30.d+0 / 8.d+0) * ff00 & 578 | & + (15.d+0 / 8.d+0) *(ferr+fell) & 579 | & - ( 3.d+0 / 8.d+0) *(derr-dell) 580 | lhat(4) = & 581 | & - ( 1.d+0 / 4.d+0) *(ferr-fell & 582 | & -derr-dell) 583 | lhat(5) = & 584 | & + (30.d+0 / 16.d+0) * ff00 & 585 | & - (15.d+0 / 16.d+0) *(ferr+fell) & 586 | & + ( 5.d+0 / 16.d+0) *(derr-dell) 587 | 588 | end if 589 | 590 | end if ! haveroot 591 | 592 | return 593 | 594 | end subroutine 595 | 596 | 597 | 598 | --------------------------------------------------------------------------------