diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 715152e..88c9b42 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -224,7 +224,7 @@ jobs: fi elif test "$FC" = "lfortran" ; then echo "FPM_FC=lfortran" >> "$GITHUB_ENV" - echo "FFLAGS=--cpp --separate-compilation --realloc-lhs-arrays $FFLAGS" >> "$GITHUB_ENV" + echo "FFLAGS=--cpp --realloc-lhs-arrays $FFLAGS" >> "$GITHUB_ENV" echo "FPM_FLAGS=--profile debug --verbose" >> "$GITHUB_ENV" ; : fpm 0.13 workaround else echo "FPM_FC=gfortran-${COMPILER_VERSION}" >> "$GITHUB_ENV" diff --git a/.gitignore b/.gitignore index c73fb8d..780a618 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,9 @@ +# Scratch directory +scratch + +# macOS folder display format +.DS_Store + # Prerequisites *.d diff --git a/README.md b/README.md index 938adbf..7d5341d 100644 --- a/README.md +++ b/README.md @@ -76,7 +76,7 @@ Building and testing GCC | `gfortran` | 14-15 | `fpm test --compiler gfortran --profile release` GCC | `gfortran` | 13 | `fpm test --compiler gfortran --profile release --flag "-ffree-line-length-none"` Intel | `ifx` | 2025.1.2 | `FOR_COARRAY_NUM_IMAGES=1 fpm test --compiler ifx --flag "-fpp -O3 -coarray" --profile release` - LFortran | `lfortran` | 0.60.0-421-ge2c448c79 | `fpm test --compiler lfortran --flag "--cpp --realloc-lhs-arrays"` + LFortran | `lfortran` | latest | `fpm test --compiler lfortran --flag "--cpp --realloc-lhs-arrays"` LLVM | `flang` | 20-21 | `fpm test --compiler flang --profile release LLVM | `flang` | 19 | `fpm test --compiler flang --profile release --flag "-mmlir -allow-assumed-rank"` NAG | `nagfor` | 7.2 Build 7242 | `fpm test --compiler nagfor --flag "-O3 -fpp"` diff --git a/example/2D-sink.F90 b/example/2D-sink.F90 new file mode 100644 index 0000000..f6bbfcb --- /dev/null +++ b/example/2D-sink.F90 @@ -0,0 +1,59 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +#include "julienne-assert-macros.h" + +module sink_2D_functions_m + use julienne_m, only : call_julienne_assert_ + implicit none + + integer, parameter :: space_dimension = 2 + double precision, parameter :: pi = acos(-1D0) + +contains + + pure function velocity(x,y) result(v) + double precision, intent(in) :: x(:), y(:) + double precision v(size(x),size(y),space_dimension), theta + double precision, parameter :: Q = 1D0 + do concurrent(integer :: i=1:size(x), j=1:size(y)) + associate(r => sqrt(x(i)**2 + y(j)**2)) + call_julienne_assert(r /= 0D0) + v(i,j,:) = -(Q/(2*pi))*[x(i), y(j)]/(x(i)**2 + y(j)**2) + end associate + end do + end function + + pure function divergence(x,y) result(div_v) + double precision, intent(in) :: x(:), y(:) + double precision div_v(size(x),size(y)) + call_julienne_assert(.not. any(x == 0D0 .and. y == 0D0)) + div_v = 0D0 + end function + +end module + +program sink_2D + use julienne_m, only : file_t + use sink_2D_functions_m, only : velocity, divergence, pi + use formal_m, only : vector_2D_t, divergence_2D_t, divergence_2D_initializer_i, vector_2D_initializer_i + implicit none + + integer, parameter :: order = 4 + procedure(vector_2D_initializer_i), pointer :: vector_2D_initializer + procedure(divergence_2D_initializer_i), pointer :: divergence_2D_initializer + + divergence_2D_initializer => divergence + vector_2D_initializer => velocity + + associate(v => vector_2D_t(vector_2D_initializer, order=order, cells=[11,11], x_min=[-1D0,-1D0], x_max=[1D0,1D0])) + associate(div_v => .div. v, expected_divergence => divergence_2D_t(divergence_2D_initializer, mold=v)) + associate(v_file => v%to_file(),div_v_file => div_v%to_file(), expected_divergence_file => expected_divergence%to_file()) + call v_file%write_lines("example/scripts/sink-velocity.csv") + call div_v_file%write_lines("example/scripts/sink-divergence.csv") + call expected_divergence_file%write_lines("example/scripts/expected-divergence.csv") + end associate + end associate + end associate + +end program \ No newline at end of file diff --git a/example/2D-vortex.F90 b/example/2D-vortex.F90 new file mode 100644 index 0000000..6aae958 --- /dev/null +++ b/example/2D-vortex.F90 @@ -0,0 +1,58 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +module velocity_potential_m + implicit none + + integer, parameter :: space_dimension = 2 + +contains + + pure function potential(x,y) result(phi) + double precision, intent(in) :: x(:), y(:) + double precision phi(size(x),size(y)) + do concurrent(integer :: j=1:size(y)) default(none) shared(x,y,phi) + phi(:,j) = atan(y(j)/x) + end do + end function + + pure function velocity(x,y) result(grad_phi) + double precision, intent(in) :: x(:), y(:) + double precision grad_phi(size(x),size(y),space_dimension) + do concurrent(integer :: i=1:size(x), j=1:size(y)) + grad_phi(i,j,:) = [-y(j)/(x(i)**2 + y(j)**2), x(i)/(x(i)**2 + y(j)**2)] + end do + end function + +end module + +program vortex_2D + use julienne_m, only : file_t + use velocity_potential_m, only : potential, velocity + use formal_m, only : scalar_2D_t, vector_2D_t, scalar_2D_initializer_i, vector_2D_initializer_i + implicit none + + integer, parameter :: order = 4 + double precision, parameter :: pi = acos(-1D0) + procedure(scalar_2D_initializer_i), pointer :: scalar_2D_initializer + procedure(vector_2D_initializer_i), pointer :: vector_2D_initializer + + scalar_2D_initializer => potential + vector_2D_initializer => velocity + + associate(phi => scalar_2D_t(scalar_2D_initializer, order=order, cells=[11,11], x_min=[-pi,-pi], x_max=[pi,pi])) + associate( velocity => .grad. phi & + ,expected_velocity => vector_2D_t(vector_2D_initializer, mold=phi) & + ) + associate(velocity_potential_file => phi%to_file() & + ,velocity_file => velocity%to_file() & + ,expected_velocity_file => expected_velocity%to_file() & + ) + call velocity_potential_file%write_lines("example/scripts/velocity-potential.csv") + call velocity_file%write_lines("example/scripts/velocity.csv") + call expected_velocity_file%write_lines("example/scripts/expected-velocity.csv") + end associate + end associate + end associate + +end program \ No newline at end of file diff --git a/example/burgers-1D.F90 b/example/burgers-1D.F90 index a62b191..9ae6076 100644 --- a/example/burgers-1D.F90 +++ b/example/burgers-1D.F90 @@ -33,9 +33,6 @@ program burgers_1D use iso_fortran_env, only : output_unit implicit none -#ifdef __GFORTRAN__ - procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer -#endif character(len=:), allocatable :: order_string type(command_line_t) command_line integer order @@ -68,9 +65,7 @@ program burgers_1D block -#ifndef __GFORTRAN__ procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer -#endif double precision, parameter :: pi = acos(-1D0), nu=1D0, t_final=0.6D0 double precision, allocatable :: u_surface(:,:), time(:) double precision dt @@ -149,10 +144,6 @@ program burgers_1D end associate end block -#ifdef __GFORTRAN__ - stop -#endif - contains pure function d_dt(u, nu) result(du_dt) diff --git a/example/div-grad-laplacian-1D.F90 b/example/div-grad-laplacian-1D.F90 index 00caf76..6a8f749 100644 --- a/example/div-grad-laplacian-1D.F90 +++ b/example/div-grad-laplacian-1D.F90 @@ -42,9 +42,6 @@ program div_grad_laplacian_1D use functions_m, only : f, df_dx, d2f_dx2 use julienne_m, only : file_t, string_t, operator(.separatedBy.), command_line_t use formal_m, only : scalar_1D_t, scalar_1D_initializer_i -#ifdef __GFORTRAN__ - use formal_m, only : vector_1D_t, laplacian_1D_t, gradient_1D_t -#endif implicit none procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer => f @@ -93,8 +90,6 @@ program div_grad_laplacian_1D contains -#ifndef __GFORTRAN__ - subroutine output(order) integer, intent(in) :: order @@ -125,44 +120,6 @@ subroutine output(order) end associate end subroutine -#else - - subroutine output(order) - integer, intent(in) :: order - - type(scalar_1D_t) s - type(gradient_1D_t) grad_s - type(laplacian_1D_t) laplacian_s - type(file_t) s_table, grad_s_table, laplacian_s_table - double precision, allocatable,dimension(:) :: s_grid, grad_s_grid, laplacian_s_grid - - s = scalar_1D_t(scalar_1D_initializer, order=order, cells=20, x_min=0D0, x_max=20D0) - grad_s = .grad. s - laplacian_s = .laplacian. s - - s_grid = s%grid() - grad_s_grid = grad_s%grid() - laplacian_s_grid = laplacian_s%grid() - - s_table = tabulate( & - string_t([character(len=22)::"x", "f(x) expected" , "f(x) actual" ]) & - ,s_grid, f(s_grid), s%values() & - ) - grad_s_table = tabulate( & - string_t([character(len=22)::"x", ".grad. f expected" , ".grad. f actual" ]) & - ,grad_s_grid, df_dx(grad_s_grid), grad_s%values() & - ) - laplacian_s_table = tabulate( & - string_t([character(len=22)::"x", ".laplacian. f expected", ".laplacian. f actual"]) & - ,laplacian_s_grid, d2f_dx2(laplacian_s_grid), laplacian_s%values() & - ) - call s_table%write_lines() - call grad_s_table%write_lines() - call laplacian_s_table%write_lines() - end subroutine - -#endif - pure function tabulate(headings, abscissa, expected, actual) result(file) double precision, intent(in), dimension(:) :: abscissa, expected, actual type(string_t), intent(in) :: headings(:) diff --git a/example/extended-gauss-divergence.F90 b/example/extended-gauss-divergence.F90 index 89fc8fb..5a57c54 100644 --- a/example/extended-gauss-divergence.F90 +++ b/example/extended-gauss-divergence.F90 @@ -61,15 +61,8 @@ program extended_gauss_divergence call execute_command_line("grep '<-- scalar' example/extended-gauss-divergence.F90 | grep -v execute_command", wait=.true.) call execute_command_line("grep '<-- vector' example/extended-gauss-divergence.F90 | grep -v execute_command", wait=.true.) -#ifdef __GFORTRAN__ - command_line_arguments: & - block - type(numerical_arguments_t) args - args = get_numerical_arguments() -#else command_line_arguments: & associate(args => get_numerical_arguments()) -#endif text_flags: & associate(flags => text_flags_t( & div_ = command_line%argument_present( [ character(len=len("--div" )) :: "--div" , "-d" ] ) & @@ -114,39 +107,24 @@ program extended_gauss_divergence end associate integrand_factors end associate print_all end associate text_flags -#ifndef __GFORTRAN__ end associate command_line_arguments -#else - end block command_line_arguments -#endif contains function get_numerical_arguments() result(numerical_arguments) type(numerical_arguments_t) numerical_arguments -#ifdef __GFORTRAN__ - character(len=:), allocatable :: cells_string, order_string, x_min_string, x_max_string - cells_string = command_line%flag_value("--cells") - order_string = command_line%flag_value("--order") - x_min_string = command_line%flag_value("--x_min") - x_max_string = command_line%flag_value("--x_max") -#else associate( & cells_string => command_line%flag_value("--cells") & ,order_string => command_line%flag_value("--order") & ,x_min_string => command_line%flag_value("--x_min") & ,x_max_string => command_line%flag_value("--x_max") & ) -#endif if (len(cells_string)/=0) read(cells_string,*) numerical_arguments%cells_ if (len(order_string)/=0) read(order_string,*) numerical_arguments%order_ if (len(x_min_string)/=0) read(x_min_string,*) numerical_arguments%x_min_ if (len(x_max_string)/=0) read(x_max_string,*) numerical_arguments%x_max_ -#ifndef __GFORTRAN__ end associate -#endif - end function end program diff --git a/example/print-assembled-1D-operators.F90 b/example/print-assembled-1D-operators.F90 index dad3844..29b1831 100644 --- a/example/print-assembled-1D-operators.F90 +++ b/example/print-assembled-1D-operators.F90 @@ -40,9 +40,6 @@ program print_assembled_1D_operators if (print_all .or. (divergence .and. len(order)==0) .or. (divergence .and. order=="4")) call print_divergence_operator(k=4, dx=1D0, m=16) end associate default_usage -#ifdef __GFORTRAN__ - stop -#endif end associate command_line_settings contains diff --git a/example/scripts/2D-scalar-field.gnuplot b/example/scripts/2D-scalar-field.gnuplot new file mode 100644 index 0000000..b2e69b5 --- /dev/null +++ b/example/scripts/2D-scalar-field.gnuplot @@ -0,0 +1,37 @@ +# ============================================================================ +# 2D-scalar-field.gnuplot -- surface plot CSV +# Line 1: column labels +# Lines 2+: x, y, z data with blank lines between x-slices +# Usage: gnuplot -d "base_name='velocity-potential'" 2D-scalar-field.gnuplot +# Default: base_name='velocity-potential' +# ============================================================================ + +if (!exists("base_name")) base_name = "velocity-potential" + +datafile = base_name . ".csv" + +set datafile separator "," + +# --- 1. Read column headers from line 1 --- +xlabel = "" ; ylabel = "" ; zlabel = "" +set table $Dummy + plot datafile every ::0::0 \ + using (xlabel=strcol(1), ylabel=strcol(2), zlabel=strcol(3), 0):(0) \ + with table +unset table + +# --- 2. Plot --- +set title zlabel . "(" . xlabel . ", " . ylabel . ")" +set xlabel xlabel ; set ylabel ylabel +set zlabel zlabel offset 3,0 ; set cblabel zlabel +set hidden3d +set pm3d depthorder +set palette rgbformulae 33,13,10 +set ticslevel 0 ; set key off + +set terminal gif size 800,600 +set output base_name . ".gif" + +splot datafile every ::1 using 1:2:3 with pm3d title "" + +set output # flush and close the file diff --git a/example/scripts/2D-vector-field.gnuplot b/example/scripts/2D-vector-field.gnuplot new file mode 100644 index 0000000..1b09746 --- /dev/null +++ b/example/scripts/2D-vector-field.gnuplot @@ -0,0 +1,35 @@ +# =============================================================== +# vector-field.gnuplot -- 2D vector/quiver plot from a CSV +# Line 1: column labels +# Lines 2+: x, y, velocity_x, velocity_y data +# Usage: gnuplot -e "base_name='velocity'" vector-field.gnuplot +# Default: base_name='velocity' +# =============================================================== + +if (!exists("base_name")) base_name = "velocity" + +datafile = base_name . ".csv" +set datafile separator "," + +# --- 1. Read column headers from line 1 --- +xlabel = "" ; ylabel = "" ; dxlabel = "" ; dylabel = "" +set table $Dummy + plot datafile every ::0::0 \ + using (xlabel=strcol(1), ylabel=strcol(2), \ + dxlabel=strcol(3), dylabel=strcol(4), 0):(0) \ + with table +unset table + +# --- 2. Plot --- +set title dxlabel . "," . dylabel . " at each " . xlabel . "," . ylabel +set xlabel xlabel +set ylabel ylabel +set key off +set cblabel "magnitude" + +set terminal gif size 800,600 +set output base_name . ".gif" + +plot datafile every ::1 \ + using ($1-$3/2):($2-$4/2):3:4:(sqrt($3**2+$4**2)) \ + with vectors head filled size screen 0.02,15 lw 1.5 lc palette z title "" diff --git a/src/formal/differential_operators_1D_m.F90 b/src/formal/differential_operators_1D_m.F90 index 41f7bc2..0b77038 100644 --- a/src/formal/differential_operators_1D_m.F90 +++ b/src/formal/differential_operators_1D_m.F90 @@ -51,7 +51,7 @@ pure module function construct_matrix_operator(upper, inner, lower) result(diffe interface gradient_operator_1D_t - pure module function construct_1D_gradient_operator(k, dx, cells) result(gradient_operator_1D) + elemental module function construct_1D_gradient_operator(k, dx, cells) result(gradient_operator_1D) !! Construct a mimetic gradient operator implicit none integer, intent(in) :: k !! order of accuracy @@ -77,7 +77,7 @@ pure module function construct_1D_gradient_operator(k, dx, cells) result(gradien interface divergence_operator_1D_t - pure module function construct_1D_divergence_operator(k, dx, cells) result(divergence_operator_1D) + elemental module function construct_1D_divergence_operator(k, dx, cells) result(divergence_operator_1D) !! Construct a mimetic gradient operator implicit none integer, intent(in) :: k !! order of accuracy diff --git a/src/formal/divergence_1D_s.F90 b/src/formal/divergence_1D_s.F90 index b7aa0d4..bb52f6f 100644 --- a/src/formal/divergence_1D_s.F90 +++ b/src/formal/divergence_1D_s.F90 @@ -12,30 +12,16 @@ contains -#ifdef __GFORTRAN__ - - pure function cell_center_locations(x_min, x_max, cells) result(x) - double precision, intent(in) :: x_min, x_max - integer, intent(in) :: cells - double precision, allocatable:: x(:) - integer cell - - associate(dx => (x_max - x_min)/cells) - x = x_min + dx/2. + [((cell-1)*dx, cell = 1, cells)] - end associate - end function - -#endif + module procedure construct_1D_divergence_constant + integer i + divergence_1D%tensor_1D_t = tensor_1D_t([(constant, i=1,cells)], x_min, x_max, cells, order) + end procedure module procedure premultiply_scalar_1D call_julienne_assert(size(scalar_1D%values_) .equalsExpected. size(divergence_1D%values_) + 2) scalar_x_divergence_1D%tensor_1D_t = & tensor_1D_t(scalar_1D%values_(2:size(scalar_1D%values_)-1) * divergence_1D%values_, scalar_1D%x_min_, scalar_1D%x_max_, scalar_1D%cells_, scalar_1D%order_) -#ifndef __GFORTRAN__ scalar_x_divergence_1D%weights_ = divergence_1D%weights() -#else - scalar_x_divergence_1D%weights_ = divergence_1D%divergence_1D_weights() -#endif call_julienne_assert(size(scalar_x_divergence_1D%weights_) .equalsExpected. size(divergence_1D%values_)+2) end procedure @@ -48,7 +34,7 @@ pure function cell_center_locations(x_min, x_max, cells) result(x) end procedure module procedure divergence_1D_grid - cell_centers = cell_center_locations(self%x_min_, self%x_max_, self%cells_) + cell_centers = cell_centers_1D(self%x_min_, self%x_max_, self%cells_) end procedure module procedure divergence_1D_weights diff --git a/src/formal/divergence_2D_s.F90 b/src/formal/divergence_2D_s.F90 new file mode 100644 index 0000000..e1d5ac3 --- /dev/null +++ b/src/formal/divergence_2D_s.F90 @@ -0,0 +1,78 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +#include "julienne-assert-macros.h" + +submodule(tensors_2D_m) divergence_2D_s + use julienne_m, only : & + call_julienne_assert_ & + ,operator(.all.) & + ,operator(.equalsExpected.) & + ,operator(.greaterThan.) & + ,operator(.isAtLeast.) + use tensors_1D_m, only : divergence_1D_t, cell_centers_1D + use julienne_m, only : string_t, operator(.csv.) + implicit none + +contains + + module procedure divergence_2D_values + divergence_values = self%values_(:,:,1,1,1,1) + end procedure + + module procedure divergence_2D_grid + associate(divergence_1D => divergence_1D_t( & + constant = 0D0 & + ,cells = self%cells_(direction) & + ,x_min = self%x_min_(direction) & + ,x_max = self%x_max_(direction) & + ,order = self%order_ & + )) + divergence_grid_1D = divergence_1D%grid() + end associate + end procedure + + module procedure construct_2D_divergence_from_function + + call_julienne_assert(.all. ([size(cells), size(x_min), size(x_max)] .equalsExpected. space_dimension)) + call_julienne_assert(.all. (x_max .greaterThan. x_min)) + call_julienne_assert(.all. (cells .isAtLeast. 2*order)) + + associate(x => cell_centers_1D(x_min(1), x_max(1), cells(1)), y => cell_centers_1D(x_min(2), x_max(2), cells(2))) + divergence_2D%tensor_2D_t = tensor_2D_t( & + values = reshape(initializer(x,y), shape=[size(x),size(y),1,1,1,1]) & + ,cells = cells , x_min = x_min, x_max = x_max, order = order & + ) + end associate + end procedure + + module procedure construct_2D_divergence_from_vector_mold + divergence_2D = divergence_2D_t(initializer, cells = mold%cells_, x_min = mold%x_min_, x_max = mold%x_max_, order = mold%order_) + end procedure + + module procedure divergence_2D_to_file + type(string_t), allocatable :: lines(:) + integer i, j, l + + associate(x => self%grid(1), y => self%grid(2), header => [string_t("x,y,divergence")]) + associate(num_blank_lines => size(y)-1) + allocate(lines(size(header) + size(self%values_) + num_blank_lines)) + end associate + lines(1:size(header)) = header + l = size(header) + do j = 1, size(y) + do i = 1, size(x) + l = l + 1 + lines(l) = .csv. string_t([x(i), y(j), self%values_(i,j,1,1,1,1)]) + end do + if (j/=size(y)) then + l = l + 1 + lines(l) = "" + end if + end do + end associate + + file = file_t(lines) + end procedure + +end submodule divergence_2D_s \ No newline at end of file diff --git a/src/formal/divergence_3D_s.F90 b/src/formal/divergence_3D_s.F90 new file mode 100644 index 0000000..fa03ff1 --- /dev/null +++ b/src/formal/divergence_3D_s.F90 @@ -0,0 +1,89 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +#include "julienne-assert-macros.h" + +submodule(tensors_3D_m) divergence_3D_s + use julienne_m, only : & + call_julienne_assert_ & + ,operator(.all.) & + ,operator(.equalsExpected.) & + ,operator(.greaterThan.) & + ,operator(.isAtLeast.) + use tensors_1D_m, only : divergence_1D_t, cell_centers_1D + use julienne_m, only : string_t, operator(.csv.) + implicit none + +contains + + module procedure divergence_3D_values + divergence_values = self%values_(:,:,:,1,1,1,1) + end procedure + + module procedure divergence_3D_grid + associate(divergence_1D => divergence_1D_t( & + constant = 0D0 & + ,cells = self%cells_(direction) & + ,x_min = self%x_min_(direction) & + ,x_max = self%x_max_(direction) & + ,order = self%order_ & + )) + divergence_grid_1D = divergence_1D%grid() + end associate + end procedure + + module procedure construct_3D_divergence_from_function + + call_julienne_assert(.all. ([size(cells), size(x_min), size(x_max)] .equalsExpected. space_dimension)) + call_julienne_assert(.all. (x_max .greaterThan. x_min)) + call_julienne_assert(.all. (cells .isAtLeast. 2*order)) + + associate( & + x => cell_centers_1D(x_min(1), x_max(1), cells(1)) & + ,y => cell_centers_1D(x_min(2), x_max(2), cells(2)) & + ,z => cell_centers_1D(x_min(3), x_max(3), cells(3)) & + ) + divergence_3D%tensor_3D_t = tensor_3D_t( & + values = reshape(initializer(x,y,z), shape=[size(x),size(y),size(z),1,1,1,1]) & + ,cells = cells , x_min = x_min, x_max = x_max, order = order & + ) + end associate + end procedure + + module procedure construct_3D_divergence_from_vector_mold + divergence_3D = divergence_3D_t(initializer, cells = mold%cells_, x_min = mold%x_min_, x_max = mold%x_max_, order = mold%order_) + end procedure + + module procedure divergence_3D_to_file + type(string_t), allocatable :: lines(:) + integer i, j, k, l + + associate( & + x => self%grid(1) & + ,y => self%grid(2) & + ,z => self%grid(3) & + ,header => [string_t("x,y,z,divergence")] & + ) + associate(num_blank_lines => size(y)*size(z)-1) + allocate(lines(size(header) + size(self%values_) + num_blank_lines)) + end associate + lines(1:size(header)) = header + l = size(header) + do k = 1, size(z) + do j = 1, size(y) + do i = 1, size(x) + l = l + 1 + lines(l) = .csv. string_t([x(i), y(j), z(k), self%values_(i,j,k,1,1,1,1)]) + end do + if (j/=size(y) .or. k/=size(z)) then + l = l + 1 + lines(l) = "" + end if + end do + end do + end associate + + file = file_t(lines) + end procedure + +end submodule divergence_3D_s \ No newline at end of file diff --git a/src/formal/gradient_1D_s.F90 b/src/formal/gradient_1D_s.F90 index e3589f1..010a0ef 100644 --- a/src/formal/gradient_1D_s.F90 +++ b/src/formal/gradient_1D_s.F90 @@ -53,11 +53,7 @@ ,cells = gradient_1D%cells_ & ,order = gradient_1D%order_ & ) -#ifndef __GFORTRAN__ vector_dot_gradient_1D%weights_ = gradient_1D%weights() -#else - vector_dot_gradient_1D%weights_ = gradient_1D%gradient_1D_weights() -#endif end procedure end submodule gradient_1D_s diff --git a/src/formal/scalar_1D_s.F90 b/src/formal/scalar_1D_s.F90 index cabd16f..a785d08 100644 --- a/src/formal/scalar_1D_s.F90 +++ b/src/formal/scalar_1D_s.F90 @@ -21,50 +21,31 @@ contains - -#ifndef __GFORTRAN__ - module procedure construct_1D_scalar_from_function call_julienne_assert(x_max .greaterThan. x_min) call_julienne_assert(cells .isAtLeast. 2*order) - associate(values => initializer(scalar_1D_grid_locations(x_min, x_max, cells))) + associate(values => initializer(cell_centers_extended_1D(x_min, x_max, cells))) scalar_1D%tensor_1D_t = tensor_1D_t(values, x_min, x_max, cells, order) end associate scalar_1D%gradient_operator_1D_ = gradient_operator_1D_t(k=order, dx=(x_max - x_min)/cells, cells=cells) end procedure -#else + module procedure construct_1D_scalar_constant - pure module function construct_1D_scalar_from_function(initializer, order, cells, x_min, x_max) result(scalar_1D) - procedure(scalar_1D_initializer_i), pointer :: initializer - integer, intent(in) :: order !! order of accuracy - integer, intent(in) :: cells !! number of grid cells spanning the domain - double precision, intent(in) :: x_min !! grid location minimum - double precision, intent(in) :: x_max !! grid location maximum - type(scalar_1D_t) scalar_1D + integer i call_julienne_assert(x_max .greaterThan. x_min) call_julienne_assert(cells .isAtLeast. 2*order) - associate(values => initializer(scalar_1D_grid_locations(x_min, x_max, cells))) - scalar_1D%tensor_1D_t = tensor_1D_t(values, x_min, x_max, cells, order) - end associate - scalar_1D%gradient_operator_1D_ = gradient_operator_1D_t(k=order, dx=(x_max - x_min)/cells, cells=cells) - end function - - pure function cell_center_locations(x_min, x_max, cells) result(x) - double precision, intent(in) :: x_min, x_max - integer, intent(in) :: cells - double precision, allocatable:: x(:) - integer cell - - associate(dx => (x_max - x_min)/cells) - x = x_min + dx/2. + [((cell-1)*dx, cell = 1, cells)] - end associate - end function - -#endif + scalar_1D = scalar_1D_t( tensor_1D_t( & + values = [(constant, i = 1, size(cell_centers_extended_1D(x_min, x_max, cells)))] & + ,x_min = x_min & + ,x_max = x_max & + ,cells = cells & + ,order = order & + ) ) + end procedure module procedure divide_by_integer ratio%tensor_1D_t = tensor_1D_t( & @@ -75,19 +56,30 @@ pure function cell_center_locations(x_min, x_max, cells) result(x) ) end procedure - module procedure subtract_scalar_1D + pure logical function conformable(lhs, rhs) + type(scalar_1D_t), intent(in) :: lhs, rhs call_julienne_assert(size(lhs%values_) .equalsExpected. size(rhs%values_)) - call_julienne_assert(lhs%cells_ .equalsExpected. rhs%cells_) + call_julienne_assert(.all.([lhs%cells_,lhs%order_] .equalsExpected. [rhs%cells_,rhs%order_])) call_julienne_assert(.all.([lhs%x_min_,lhs%x_max_] .approximates. [rhs%x_min_,rhs%x_max_] .within. 1D-08)) + conformable = .true. + end function + + module procedure subtract_scalar_1D + call_julienne_assert(conformable(lhs,rhs)) difference%gradient_operator_1D_ = lhs%gradient_operator_1D_ difference%tensor_1D_t = & tensor_1D_t(values = lhs%values_ - rhs%values_, x_min = rhs%x_min_, x_max = rhs%x_max_, cells = rhs%cells_, order = rhs%order_) end procedure + module procedure multiply_1D_scalars + call_julienne_assert(conformable(lhs,rhs)) + lhs_x_rhs%gradient_operator_1D_ = lhs%gradient_operator_1D_ + lhs_x_rhs%tensor_1D_t = & + tensor_1D_t(values = lhs%values_ * rhs%values_, x_min = rhs%x_min_, x_max = rhs%x_max_, cells = rhs%cells_, order = rhs%order_) + end procedure + module procedure add_scalar_1D - call_julienne_assert(size(lhs%values_) .equalsExpected. size(rhs%values_)) - call_julienne_assert(lhs%cells_ .equalsExpected. rhs%cells_) - call_julienne_assert(.all.([lhs%x_min_,lhs%x_max_] .approximates. [rhs%x_min_,rhs%x_max_] .within. 1D-08)) + call_julienne_assert(conformable(lhs,rhs)) total%gradient_operator_1D_ = lhs%gradient_operator_1D_ total%tensor_1D_t = & tensor_1D_t(values = lhs%values_ + rhs%values_, x_min = rhs%x_min_, x_max = rhs%x_max_, cells = rhs%cells_, order = rhs%order_) @@ -143,14 +135,12 @@ pure function cell_center_locations(x_min, x_max, cells) result(x) integer c associate(dx => (self%x_max_ - self%x_min_)/self%cells_) - associate(G => gradient_operator_1D_t(self%order_, dx, self%cells_)) - gradient_1D%tensor_1D_t = tensor_1D_t(G .x. self%values_, self%x_min_, self%x_max_, cells=self%cells_, order=self%order_) - gradient_1D%divergence_operator_1D_ = divergence_operator_1D_t(self%order_, dx, self%cells_) - check_corbino_castillo_eq_17: & - associate(p => gradient_1D%weights(), b => [-1D0, [(0D0, c = 1, self%cells_)], 1D0]) - call_julienne_assert((.all. (matmul(transpose(G%assemble()), p) .approximates. b/dx .within. 2D-3))) - end associate check_corbino_castillo_eq_17 - end associate + gradient_1D%tensor_1D_t = tensor_1D_t(self%gradient_operator_1D_ .x. self%values_, self%x_min_, self%x_max_, cells=self%cells_, order=self%order_) + gradient_1D%divergence_operator_1D_ = divergence_operator_1D_t(self%order_, dx, self%cells_) + check_corbino_castillo_eq_17: & + associate(p => gradient_1D%weights(), b => [-1D0, [(0D0, c = 1, self%cells_)], 1D0]) + call_julienne_assert((.all. (matmul(transpose(self%gradient_operator_1D_%assemble()), p) .approximates. b/dx .within. 2D-3))) + end associate check_corbino_castillo_eq_17 end associate end procedure @@ -180,11 +170,7 @@ pure function cell_center_locations(x_min, x_max, cells) result(x) module procedure laplacian -#ifndef __GFORTRAN__ laplacian_1D%divergence_1D_t = .div. (.grad. self) -#else - laplacian_1D%divergence_1D_t = div(grad(self)) -#endif associate(divergence_operator_1D => divergence_operator_1D_t(self%order_, (self%x_max_ - self%x_min_)/self%cells_, self%cells_)) laplacian_1D%boundary_depth_ = divergence_operator_1D%submatrix_A_rows() + 1 @@ -196,19 +182,8 @@ pure function cell_center_locations(x_min, x_max, cells) result(x) cell_centers_extended_values = self%values_ end procedure - pure function scalar_1D_grid_locations(x_min, x_max, cells) result(x) - double precision, intent(in) :: x_min, x_max - integer, intent(in) :: cells - double precision, allocatable:: x(:) - integer cell - - associate(dx => (x_max - x_min)/cells) - x = [x_min, cell_center_locations(x_min, x_max, cells), x_max] - end associate - end function - module procedure scalar_1D_grid - cell_centers_extended = scalar_1D_grid_locations(self%x_min_, self%x_max_, self%cells_) + cell_centers_extended = cell_centers_extended_1D(self%x_min_, self%x_max_, self%cells_) end procedure end submodule scalar_1D_s \ No newline at end of file diff --git a/src/formal/scalar_2D_s.F90 b/src/formal/scalar_2D_s.F90 new file mode 100644 index 0000000..e6d23c6 --- /dev/null +++ b/src/formal/scalar_2D_s.F90 @@ -0,0 +1,110 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +#include "julienne-assert-macros.h" + +submodule(tensors_2D_m) scalar_2D_s + use julienne_m, only : & + call_julienne_assert_ & + ,operator(.all.) & + ,operator(.equalsExpected.) & + ,operator(.greaterThan.) & + ,operator(.isAtLeast.) + use tensors_1D_m, only : cell_centers_extended_1D, scalar_1D_t + use julienne_m, only : string_t, operator(.csv.) + implicit none + +contains + + module procedure scalar_2D_values + scalar_values = self%values_(:,:,1,1,1,1) + end procedure + + module procedure scalar_2D_grid + associate(scalar_1D => scalar_1D_t( & + constant = 0D0 & + ,cells = self%cells_(direction) & + ,x_min = self%x_min_(direction) & + ,x_max = self%x_max_(direction) & + ,order = self%order_ & + )) + scalar_grid_1D = scalar_1D%grid() + end associate + end procedure + + module procedure construct_2D_scalar_from_function + + call_julienne_assert(.all. ([size(cells), size(x_min), size(x_max)] .equalsExpected. space_dimension)) + call_julienne_assert(.all. (x_max .greaterThan. x_min)) + call_julienne_assert(.all. (cells .isAtLeast. 2*order)) + + associate(x => cell_centers_extended_1D(x_min(1), x_max(1), cells(1)), y => cell_centers_extended_1D(x_min(2), x_max(2), cells(2))) + scalar_2D%tensor_2D_t = tensor_2D_t( & + values = reshape(initializer(x,y), shape=[size(x),size(y),1,1,1,1]) & + ,cells = cells , x_min = x_min, x_max = x_max, order = order & + ) + scalar_2D%gradient_operator_1D_ = gradient_operator_1D_t(k=order, dx=(x_max - x_min)/cells, cells=cells) + end associate + end procedure + + module procedure construct_2D_scalar_from_mold + scalar_2D = scalar_2D_t(initializer, cells = mold%cells_, x_min = mold%x_min_, x_max = mold%x_max_, order = mold%order_) + end procedure + + module procedure scalar_2D_gradient + + integer c, i, j + + gradient_2D%x_min_ = self%x_min_ + gradient_2D%x_max_ = self%x_max_ + gradient_2D%cells_ = self%cells_ + gradient_2D%order_ = self%order_ + + allocate(gradient_2D%values_(self%cells_(1)+1, self%cells_(2)+1, space_dimension, 1, 1, 1)) + + gradient_x_component: & + do concurrent(integer :: j=1:size(gradient_2D%values_,2)) default(none) shared(gradient_2D, self) + gradient_2D%values_(:,j,1,1,1,1) = self%gradient_operator_1D_(1) .x. self%values_(:,j,1,1,1,1) + end do gradient_x_component + + gradient_y_component: & + do concurrent(integer :: i=1:size(gradient_2D%values_,1)) default(none) shared(gradient_2D, self) + gradient_2D%values_(i,:,2,1,1,1) = self%gradient_operator_1D_(2) .x. self%values_(i,:,1,1,1,1) + end do gradient_y_component + + associate(dx => (self%x_max_ - self%x_min_)/self%cells_) + gradient_2D%divergence_operator_1D_ = divergence_operator_1D_t(self%order_, dx, self%cells_) + !check_corbino_castillo_eq_17: & + !associate(p => gradient_1D%weights(), b => [-1D0, [(0D0, c = 1, self%cells_)], 1D0]) + ! call_julienne_assert((.all. (matmul(transpose(self%gradient_operator_1D_%assemble()), p) .approximates. b/dx .within. 2D-3))) + !end associate check_corbino_castillo_eq_17 + end associate + + end procedure + + module procedure scalar_2D_to_file + type(string_t), allocatable :: lines(:) + integer i, j, l + + associate(x => self%grid(1), y => self%grid(2), header => [string_t("x,y,scalar")]) + associate(num_blank_lines => size(y)-1) + allocate(lines(size(header) + size(self%values_) + num_blank_lines)) + end associate + lines(1:size(header)) = header + l = size(header) + do j = 1, size(y) + do i = 1, size(x) + l = l + 1 + lines(l) = .csv. string_t([x(i), y(j), self%values_(i,j,1,1,1,1)]) + end do + if (j/=size(y)) then + l = l + 1 + lines(l) = "" + end if + end do + end associate + + file = file_t(lines) + end procedure + +end submodule scalar_2D_s \ No newline at end of file diff --git a/src/formal/scalar_3D_s.F90 b/src/formal/scalar_3D_s.F90 new file mode 100644 index 0000000..28e4fc8 --- /dev/null +++ b/src/formal/scalar_3D_s.F90 @@ -0,0 +1,126 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +#include "julienne-assert-macros.h" + +submodule(tensors_3D_m) scalar_3D_s + use julienne_m, only : & + call_julienne_assert_ & + ,operator(.all.) & + ,operator(.equalsExpected.) & + ,operator(.greaterThan.) & + ,operator(.isAtLeast.) + use tensors_1D_m, only : cell_centers_extended_1D, scalar_1D_t + use julienne_m, only : string_t, operator(.csv.) + implicit none + +contains + + module procedure scalar_3D_values + scalar_values = self%values_(:,:,:,1,1,1,1) + end procedure + + module procedure scalar_3D_grid + associate(scalar_1D => scalar_1D_t( & + constant = 0D0 & + ,cells = self%cells_(direction) & + ,x_min = self%x_min_(direction) & + ,x_max = self%x_max_(direction) & + ,order = self%order_ & + )) + scalar_grid_1D = scalar_1D%grid() + end associate + end procedure + + module procedure construct_3D_scalar_from_function + + call_julienne_assert(.all. ([size(cells), size(x_min), size(x_max)] .equalsExpected. space_dimension)) + call_julienne_assert(.all. (x_max .greaterThan. x_min)) + call_julienne_assert(.all. (cells .isAtLeast. 2*order)) + + associate( & + x => cell_centers_extended_1D(x_min(1), x_max(1), cells(1)) & + ,y => cell_centers_extended_1D(x_min(2), x_max(2), cells(2)) & + ,z => cell_centers_extended_1D(x_min(3), x_max(3), cells(3)) & + ) + scalar_3D%tensor_3D_t = tensor_3D_t( & + values = reshape(initializer(x,y,z), shape=[size(x),size(y),size(z),1,1,1,1]) & + ,cells = cells , x_min = x_min, x_max = x_max, order = order & + ) + scalar_3D%gradient_operator_1D_ = gradient_operator_1D_t(k=order, dx=(x_max - x_min)/cells, cells=cells) + end associate + end procedure + + module procedure construct_3D_scalar_from_mold + scalar_3D = scalar_3D_t(initializer, cells = mold%cells_, x_min = mold%x_min_, x_max = mold%x_max_, order = mold%order_) + end procedure + + module procedure scalar_3D_gradient + + integer c, i, j + + gradient_3D%x_min_ = self%x_min_ + gradient_3D%x_max_ = self%x_max_ + gradient_3D%cells_ = self%cells_ + gradient_3D%order_ = self%order_ + + allocate(gradient_3D%values_(self%cells_(1)+1, self%cells_(2)+1, self%cells_(3)+1, space_dimension, 1, 1, 1)) + + gradient_x_component: & + do concurrent(integer :: j=1:size(gradient_3D%values_,2), k=1:size(gradient_3D%values_,3)) default(none) shared(gradient_3D, self) + gradient_3D%values_(:,j,k,1,1,1,1) = self%gradient_operator_1D_(1) .x. self%values_(:,j,k,1,1,1,1) + end do gradient_x_component + + gradient_y_component: & + do concurrent(integer :: i=1:size(gradient_3D%values_,1), k=1:size(gradient_3D%values_,3)) default(none) shared(gradient_3D, self) + gradient_3D%values_(i,:,k,2,1,1,1) = self%gradient_operator_1D_(2) .x. self%values_(i,:,k,1,1,1,1) + end do gradient_y_component + + gradient_z_component: & + do concurrent(integer :: i=1:size(gradient_3D%values_,1), j=1:size(gradient_3D%values_,2)) default(none) shared(gradient_3D, self) + gradient_3D%values_(i,j,:,3,1,1,1) = self%gradient_operator_1D_(3) .x. self%values_(i,j,:,1,1,1,1) + end do gradient_z_component + + associate(dx => (self%x_max_ - self%x_min_)/self%cells_) + gradient_3D%divergence_operator_1D_ = divergence_operator_1D_t(self%order_, dx, self%cells_) + !check_corbino_castillo_eq_17: & + !associate(p => gradient_1D%weights(), b => [-1D0, [(0D0, c = 1, self%cells_)], 1D0]) + ! call_julienne_assert((.all. (matmul(transpose(self%gradient_operator_1D_%assemble()), p) .approximates. b/dx .within. 3D-3))) + !end associate check_corbino_castillo_eq_17 + end associate + + end procedure + + module procedure scalar_3D_to_file + type(string_t), allocatable :: lines(:) + integer i, j, k, l + + associate( & + x => self%grid(1) & + ,y => self%grid(2) & + ,z => self%grid(3) & + ,header => [string_t("x,y,z,scalar")] & + ) + associate(num_blank_lines => size(y)*size(z) - 1) + allocate(lines(size(header) + size(self%values_) + num_blank_lines)) + end associate + lines(1:size(header)) = header + l = size(header) + do k = 1, size(z) + do j = 1, size(y) + do i = 1, size(x) + l = l + 1 + lines(l) = .csv. string_t([x(i), y(j), z(k), self%values_(i,j,k,1,1,1,1)]) + end do + if (j/=size(y) .or. k/=size(z)) then + l = l + 1 + lines(l) = "" + end if + end do + end do + end associate + + file = file_t(lines) + end procedure + +end submodule scalar_3D_s \ No newline at end of file diff --git a/src/formal/tensor_2D_s.F90 b/src/formal/tensor_2D_s.F90 new file mode 100644 index 0000000..cf2a2df --- /dev/null +++ b/src/formal/tensor_2D_s.F90 @@ -0,0 +1,14 @@ +submodule(tensors_2D_m) tensor_2D_s + implicit none + +contains + + module procedure construct_2D_tensor_from_components + tensor_2D%values_ = values + tensor_2D%cells_ = cells + tensor_2D%x_min_ = x_min + tensor_2D%x_max_ = x_max + tensor_2D%order_ = order + end procedure + +end submodule \ No newline at end of file diff --git a/src/formal/tensor_3D_s.F90 b/src/formal/tensor_3D_s.F90 new file mode 100644 index 0000000..e26a1c5 --- /dev/null +++ b/src/formal/tensor_3D_s.F90 @@ -0,0 +1,14 @@ +submodule(tensors_3D_m) tensor_3D_s + implicit none + +contains + + module procedure construct_3D_tensor_from_components + tensor_3D%values_ = values + tensor_3D%cells_ = cells + tensor_3D%x_min_ = x_min + tensor_3D%x_max_ = x_max + tensor_3D%order_ = order + end procedure + +end submodule \ No newline at end of file diff --git a/src/formal/tensors_1D_m.F90 b/src/formal/tensors_1D_m.F90 index 42b2823..e7fd6aa 100644 --- a/src/formal/tensors_1D_m.F90 +++ b/src/formal/tensors_1D_m.F90 @@ -7,7 +7,6 @@ module tensors_1D_m !! Define public 1D scalar and vector abstractions and associated mimetic gradient, !! divergence, and Laplacian operators as detailed by Corbino & Castillo (2020) !! https://doi.org/10.1016/j.cam.2019.06.042. - use julienne_m, only : file_t use differential_operators_1D_m, only : divergence_operator_1D_t, gradient_operator_1D_t implicit none @@ -23,6 +22,9 @@ module tensors_1D_m public :: vector_1D_initializer_i public :: d_dx public :: d2_dx2 + public :: cell_centers_extended_1D + public :: cell_centers_1D + public :: faces_1D abstract interface @@ -88,7 +90,7 @@ pure module function construct_1D_tensor_from_components(values, x_min, x_max, c generic :: operator(-) => subtract_scalar_1D generic :: operator(+) => add_scalar_1D generic :: operator(/) => divide_by_integer - generic :: operator(*) => premultiply_double, postmultiply_double, premultiply_integer, postmultiply_integer + generic :: operator(*) => premultiply_double, postmultiply_double, premultiply_integer, postmultiply_integer, multiply_1D_scalars generic :: operator(**) => exponentiate generic :: operator(.grad.) => grad generic :: operator(.laplacian.) => laplacian @@ -97,6 +99,7 @@ pure module function construct_1D_tensor_from_components(values, x_min, x_max, c procedure, non_overridable, private :: scalar_1D_values procedure, non_overridable, private :: scalar_1D_grid procedure, non_overridable, private :: divide_by_integer + procedure, non_overridable, private :: multiply_1D_scalars procedure, non_overridable, private, pass(rhs) :: premultiply_double procedure, non_overridable, private :: postmultiply_double procedure, non_overridable, private, pass(rhs) :: premultiply_integer @@ -119,6 +122,17 @@ pure module function construct_1D_scalar_from_function(initializer, order, cells type(scalar_1D_t) scalar_1D end function + pure module function construct_1D_scalar_constant(constant, order, cells, x_min, x_max) result(scalar_1D) + !! Result is a collection of cell-centered-extended values with a corresponding mimetic gradient operator + implicit none + double precision, intent(in) :: constant !! scalar value + integer, intent(in) :: order !! order of accuracy + integer, intent(in) :: cells !! number of grid cells spanning the domain + double precision, intent(in) :: x_min !! grid location minimum + double precision, intent(in) :: x_max !! grid location maximum + type(scalar_1D_t) scalar_1D + end function + pure module function construct_1D_scalar_from_parent(tensor_1D) result(scalar_1D) !! Result is a 1D vector with the provided parent component tensor_1D and the provided divergence operatror type(tensor_1D_t), intent(in) :: tensor_1D @@ -168,10 +182,20 @@ pure module function construct_1D_vector_from_function(initializer, order, cells type(vector_1D_t) vector_1D end function - pure module function construct_from_components(tensor_1D, divergence_operator_1D) result(vector_1D) + pure module function construct_1D_vector_from_parent(tensor_1D) result(vector_1D) !! Result is a 1D vector with the provided parent component tensor_1D and the provided divergence operatror type(tensor_1D_t), intent(in) :: tensor_1D - type(divergence_operator_1D_t), intent(in) :: divergence_operator_1D + type(vector_1D_t) vector_1D + end function + + pure module function construct_1D_vector_constant(constant, order, cells, x_min, x_max) result(vector_1D) + !! Result is a collection of cell-centered-extended values with a corresponding mimetic gradient operator + implicit none + double precision, intent(in) :: constant !! scalar value + integer, intent(in) :: order !! order of accuracy + integer, intent(in) :: cells !! number of grid cells spanning the domain + double precision, intent(in) :: x_min !! grid location minimum + double precision, intent(in) :: x_max !! grid location maximum type(vector_1D_t) vector_1D end function @@ -209,6 +233,20 @@ pure module function construct_from_components(tensor_1D, divergence_operator_1D procedure, non_overridable, private :: divergence_1D_grid end type + interface divergence_1D_t + + pure module function construct_1D_divergence_constant(constant, order, cells, x_min, x_max) result(divergence_1D) + implicit none + double precision, intent(in) :: constant !! scalar value + integer, intent(in) :: order !! order of accuracy + integer, intent(in) :: cells !! number of grid cells spanning the domain + double precision, intent(in) :: x_min !! grid location minimum + double precision, intent(in) :: x_max !! grid location maximum + type(divergence_1D_t) divergence_1D + end function + + end interface + type, extends(tensor_1D_t) :: scalar_x_divergence_1D_t !! product of a 1D scalar field and a 1D divergence field private @@ -370,6 +408,14 @@ pure module function add_scalar_1D(lhs, rhs) result(total) type(scalar_1D_t) total end function + pure module function multiply_1D_scalars(lhs, rhs) result(lhs_x_rhs) + !! Result is the product of scalar_1D_t lhs and rhs + implicit none + class(scalar_1D_t), intent(in) :: lhs + type(scalar_1D_t), intent(in) :: rhs + type(scalar_1D_t) lhs_x_rhs + end function + pure module function subtract_scalar_1D(lhs, rhs) result(difference) !! Result is the difference between scalar_1D_t lhs and rhs implicit none @@ -496,21 +542,34 @@ pure module function postmultiply_scalar_1D(divergence_1D, scalar_1D) result(sca end interface -#ifndef __GFORTRAN__ - contains - pure function cell_center_locations(x_min, x_max, cells) result(x) + pure function cell_centers_extended_1D(x_min, x_max, cells) result(x) double precision, intent(in) :: x_min, x_max integer, intent(in) :: cells double precision, allocatable:: x(:) integer cell + x = [x_min, cell_centers_1D(x_min, x_max, cells), x_max] + end function + pure function faces_1D(x_min, x_max, cells) result(x) + double precision, intent(in) :: x_min, x_max + integer, intent(in) :: cells + double precision, allocatable:: x(:) + integer cell associate(dx => (x_max - x_min)/cells) - x = x_min + dx/2. + [((cell-1)*dx, cell = 1, cells)] + x = [x_min, x_min + [(cell*dx, cell = 1, cells-1)], x_max] end associate end function -#endif + pure function cell_centers_1D(x_min, x_max, cells) result(x) + double precision, intent(in) :: x_min, x_max + integer, intent(in) :: cells + double precision, allocatable:: x(:) + integer cell + associate(dx => (x_max - x_min)/cells) + x = x_min + dx/2. + [((cell-1)*dx, cell = 1, cells)] + end associate + end function end module tensors_1D_m diff --git a/src/formal/tensors_2D_m.F90 b/src/formal/tensors_2D_m.F90 new file mode 100644 index 0000000..f5c5647 --- /dev/null +++ b/src/formal/tensors_2D_m.F90 @@ -0,0 +1,278 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +module tensors_2D_m + !! Define public 2D scalar and vector abstractions and associated mimetic gradient, + !! divergence, and Laplacian operators as detailed by Corbino & Castillo (2020) + !! https://doi.org/10.1016/j.cam.2019.06.042. + use differential_operators_1D_m, only : gradient_operator_1D_t, divergence_operator_1D_t + use julienne_m, only : file_t + implicit none + + private + public :: scalar_2D_t + public :: vector_2D_t + public :: gradient_2D_t + public :: divergence_2D_t + public :: scalar_2D_initializer_i + public :: vector_2D_initializer_i + public :: divergence_2D_initializer_i + + integer, parameter :: space_dimension = 2 + + abstract interface + + pure function scalar_2D_initializer_i(x,y) result(f) + !! Sampling function for initializing a scalar_2D_t object + implicit none + double precision, intent(in) :: x(:), y(:) + double precision f(size(x),size(y)) + end function + + pure function divergence_2D_initializer_i(x,y) result(f) + !! Sampling function for initializing a scalar_2D_t object + implicit none + double precision, intent(in) :: x(:), y(:) + double precision f(size(x),size(y)) + end function + + pure function vector_2D_initializer_i(x,y) result(v) + !! Sampling function for initializing a vector_2D_t object + import space_dimension + implicit none + double precision, intent(in) :: x(:), y(:) + double precision v(size(x),size(y),space_dimension) + end function + + end interface + + type tensor_2D_t + !! Encapsulate the components that are common to all 2D tensors. + !! Child types define the operations supported by each child, including + !! gradient (.grad.) for scalars and divergence (.div.) for vectors. + private + double precision, allocatable :: values_(:,:, :,:,:,:) !! tensor components for rank<=4 at 2D locations + double precision x_min_(space_dimension) !! domain lower boundary + double precision x_max_(space_dimension) !! domain upper boundary + integer cells_(space_dimension) !! number of grid cells spanning the domain + integer order_ !! order of accuracy of mimetic discretization + end type + + interface tensor_2D_t + + pure module function construct_2D_tensor_from_components(values, cells, x_min, x_max, order) result(tensor_2D) + implicit none + double precision, intent(in) :: values(:,:, :,:,:,:) !! tensor components at 2D spatial locations + double precision, intent(in) :: x_min(:) !! domain lower boundary + double precision, intent(in) :: x_max(:) !! domain upper boundary + integer, intent(in) :: cells(:) !! number of grid cells spanning the domain + integer, intent(in) :: order !! order of accuracy of mimetic discretization + type(tensor_2D_t) tensor_2D + end function + + end interface + + type, extends(tensor_2D_t) :: scalar_2D_t + !! Encapsulate scalar values at cell centers and boundaries + private + type(gradient_operator_1D_t) gradient_operator_1D_(space_dimension) + contains + generic :: operator(.grad.) => scalar_2D_gradient + generic :: values => scalar_2D_values + generic :: grid => scalar_2D_grid + generic :: to_file => scalar_2D_to_file + procedure, non_overridable, private :: scalar_2D_to_file + procedure, non_overridable, private :: scalar_2D_gradient + procedure, non_overridable, private :: scalar_2D_values + procedure, non_overridable, private :: scalar_2D_grid + end type + + interface scalar_2D_t + + pure module function construct_2D_scalar_from_function(initializer, order, cells, x_min, x_max) result(scalar_2D) + !! Result is a collection of cell-centered-extended values with a corresponding mimetic gradient operator + implicit none + procedure(scalar_2D_initializer_i), pointer :: initializer + integer, intent(in) :: order !! order of accuracy + integer, intent(in) :: cells(:) !! number of grid cells spanning each spatial direction + double precision, intent(in) :: x_min(:) !! grid location minima + double precision, intent(in) :: x_max(:) !! grid location maxima + type(scalar_2D_t) scalar_2D + end function + + pure module function construct_2D_scalar_from_mold(initializer, mold) result(scalar_2D) + !! Result is a 2D scalar field using a mold for all components other than the field values + implicit none + procedure(scalar_2D_initializer_i), pointer :: initializer + type(scalar_2D_t), intent(in) :: mold + type(scalar_2D_t) scalar_2D + end function + + end interface + + type, extends(tensor_2D_t) :: vector_2D_t + !! Encapsulate 2D vector values at cell faces (of unit area for 2D) and corresponding operators + private + type(divergence_operator_1D_t) divergence_operator_1D_(space_dimension) + contains + generic :: values => vector_2D_values + generic :: to_file => vector_2D_to_file + generic :: grid => vector_2D_grid + generic :: operator(.div.) => vector_2D_divergence + procedure, non_overridable, private :: vector_2D_values + procedure, non_overridable, private :: vector_2D_to_file + procedure, non_overridable, private :: vector_2D_grid + procedure, non_overridable, private :: vector_2D_divergence + end type + + interface vector_2D_t + + pure module function construct_2D_vector_from_function(initializer, order, cells, x_min, x_max) result(vector_2D) + !! Result is a 2D vector with values initialized by the provided procedure pointer sampled on the specified + !! number of evenly spaced cells covering [x_min, x_max] + implicit none + procedure(vector_2D_initializer_i), pointer :: initializer + integer, intent(in) :: order !! order of accuracy + integer, intent(in) :: cells(:) !! number of grid cells spanning each spatial direction + double precision, intent(in) :: x_min(:) !! grid location minima + double precision, intent(in) :: x_max(:) !! grid location maxima + type(vector_2D_t) vector_2D + end function + + pure module function construct_2D_vector_from_vector_mold(initializer, mold) result(vector_2D) + !! Result is a 2D vector with values initialized by the provided procedure pointer sampled on the + !! same grid as the mold + implicit none + procedure(vector_2D_initializer_i), pointer :: initializer + type(vector_2D_t), intent(in) :: mold + type(vector_2D_t) vector_2D + end function + + pure module function construct_2D_vector_from_scalar_mold(initializer, mold) result(vector_2D) + !! Result is a 2D vector with values initialized by the provided procedure pointer sampled on the + !! face-centered grid corresponding to the cell-centered grid of the mold + implicit none + procedure(vector_2D_initializer_i), pointer :: initializer + type(scalar_2D_t), intent(in) :: mold + type(vector_2D_t) vector_2D + end function + + end interface + + type, extends(vector_2D_t) :: gradient_2D_t + !! A 2D mimetic gradient vector field abstraction with a public method that produces corresponding numerical quadrature weights + end type + + type, extends(tensor_2D_t) :: divergence_2D_t + !! A 2D mimetic divergence field abstraction with a public method that produces corresponding numerical quadrature weights + contains + generic :: values => divergence_2D_values + generic :: grid => divergence_2D_grid + generic :: to_file => divergence_2D_to_file + procedure, private, non_overridable :: divergence_2D_values + procedure, private, non_overridable :: divergence_2D_grid + procedure, private, non_overridable :: divergence_2D_to_file + end type + + interface divergence_2D_t + + pure module function construct_2D_divergence_from_function(initializer, order, cells, x_min, x_max) result(divergence_2D) + !! Result is a 2D divergence initialized by sampling the initializer at cell centers defined by the other arguments + implicit none + procedure(scalar_2D_initializer_i), pointer, intent(in) :: initializer + integer, intent(in) :: order !! order of accuracy + integer, intent(in) :: cells(:) !! number of grid cells spanning each spatial direction + double precision, intent(in) :: x_min(:) !! grid location minima + double precision, intent(in) :: x_max(:) !! grid location maxima + type(divergence_2D_t) divergence_2D + end function + + pure module function construct_2D_divergence_from_vector_mold(initializer, mold) result(divergence_2D) + !! Result is a 2D divergence initialized by sampling the initializer on cell centers defined by the mold + implicit none + procedure(divergence_2D_initializer_i), pointer, intent(in) :: initializer + type(vector_2D_t), intent(in) :: mold + type(divergence_2D_t) divergence_2D + end function + + end interface + + interface + + pure module function scalar_2D_values(self) result(scalar_values) + !! Scalar values getter + class(scalar_2D_t), intent(in) :: self + double precision, allocatable :: scalar_values(:,:) + end function + + pure module function scalar_2D_grid(self, direction) result(scalar_grid_1D) + !! Result array contains scalar grid locations along the requested spatial direction + class(scalar_2D_t), intent(in) :: self + integer, intent(in) :: direction + double precision, allocatable :: scalar_grid_1D(:) + end function + + pure module function vector_2D_grid(self, direction) result(vector_grid_1D) + !! Result array contains scalar grid locations along the requested spatial direction + class(vector_2D_t), intent(in) :: self + integer, intent(in) :: direction + double precision, allocatable :: vector_grid_1D(:) !! grid points along the requested coordinate direction + end function + + pure module function divergence_2D_grid(self, direction) result(divergence_grid_1D) + !! Result array contains divergence grid locations along the requested spatial direction + class(divergence_2D_t), intent(in) :: self + integer, intent(in) :: direction + double precision, allocatable :: divergence_grid_1D(:) !! grid points along the requested coordinate direction + end function + + pure module function vector_2D_values(self) result(vector_values) + !! Vector values getter + class(vector_2D_t), intent(in) :: self + double precision, allocatable :: vector_values(:,:,:) + end function + + pure module function divergence_2D_values(self) result(divergence_values) + !! Vector values getter + class(divergence_2D_t), intent(in) :: self + double precision, allocatable :: divergence_values(:,:) + end function + + pure module function scalar_2D_gradient(self) result(gradient_2D) + !! Result is mimetic gradient of the scalar_2D_t "self" + implicit none + class(scalar_2D_t), intent(in) :: self + type(gradient_2D_t) gradient_2D + end function + + pure module function vector_2D_divergence(self) result(divergence_2D) + !! Result is mimetic divergence of the scalar_2D_t "self" + implicit none + class(vector_2D_t), intent(in) :: self + type(divergence_2D_t) divergence_2D + end function + + pure module function scalar_2D_to_file(self) result(file) + !! Result is a file_t object containing the grid points and the corresponding scalar values + implicit none + class(scalar_2D_t), intent(in) :: self + type(file_t) file + end function + + pure module function divergence_2D_to_file(self) result(file) + !! Result is a file_t object containing the grid points and the corresponding divergence values + implicit none + class(divergence_2D_t), intent(in) :: self + type(file_t) file + end function + + pure module function vector_2D_to_file(self) result(file) + !! Result is a file_t object containing the grid points and the corresponding vector components + implicit none + class(vector_2D_t), intent(in) :: self + type(file_t) file + end function + + end interface + +end module tensors_2D_m diff --git a/src/formal/tensors_3D_m.F90 b/src/formal/tensors_3D_m.F90 new file mode 100644 index 0000000..62e9779 --- /dev/null +++ b/src/formal/tensors_3D_m.F90 @@ -0,0 +1,280 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +module tensors_3D_m + !! Define public 3D scalar and vector abstractions and associated mimetic gradient, + !! divergence, and Laplacian operators as detailed by Corbino & Castillo (2020) + !! https://doi.org/10.1016/j.cam.2019.06.042. + use differential_operators_1D_m, only : gradient_operator_1D_t, divergence_operator_1D_t + use julienne_m, only : file_t + + implicit none + + private + + public :: scalar_3D_t + public :: vector_3D_t + public :: gradient_3D_t + public :: divergence_3D_t + public :: scalar_3D_initializer_i + public :: vector_3D_initializer_i + public :: divergence_3D_initializer_i + + integer, parameter :: space_dimension = 3 + + abstract interface + + pure function scalar_3D_initializer_i(x,y,z) result(f) + !! Sampling function for initializing a scalar_3D_t object + implicit none + double precision, intent(in) :: x(:), y(:), z(:) + double precision f(size(x),size(y),size(z)) + end function + + pure function divergence_3D_initializer_i(x,y,z) result(f) + !! Sampling function for initializing a divergence_3D_t object + implicit none + double precision, intent(in) :: x(:), y(:), z(:) + double precision f(size(x),size(y),size(z)) + end function + + pure function vector_3D_initializer_i(x,y,z) result(v) + !! Sampling function for initializing a vector_3D_t object + import space_dimension + implicit none + double precision, intent(in) :: x(:), y(:), z(:) + double precision v(size(x),size(y),size(z),space_dimension) + end function + + end interface + + type tensor_3D_t + !! Encapsulate the components that are common to all 3D tensors. + !! Child types define the operations supported by each child, including + !! gradient (.grad.) for scalars and divergence (.div.) for vectors. + private + double precision, allocatable :: values_(:,:,:, :,:,:,:) !! tensor components for rank<=4 at 3D locations + double precision x_min_(space_dimension) !! domain lower boundary + double precision x_max_(space_dimension) !! domain upper boundary + integer cells_(space_dimension) !! number of grid cells spanning the domain + integer order_ !! order of accuracy of mimetic discretization + end type + + interface tensor_3D_t + + pure module function construct_3D_tensor_from_components(values, cells, x_min, x_max, order) result(tensor_3D) + implicit none + double precision, intent(in) :: values(:,:,:, :,:,:,:) !! tensor components for rank<=4 at 3D locations + double precision, intent(in) :: x_min(:) !! domain lower boundary + double precision, intent(in) :: x_max(:) !! domain upper boundary + integer, intent(in) :: cells(:) !! number of grid cells spanning the domain + integer, intent(in) :: order !! order of accuracy of mimetic discretization + type(tensor_3D_t) tensor_3D + end function + + end interface + + type, extends(tensor_3D_t) :: scalar_3D_t + !! Encapsulate scalar values at cell centers and boundaries + private + type(gradient_operator_1D_t) gradient_operator_1D_(space_dimension) + contains + generic :: operator(.grad.) => scalar_3D_gradient + generic :: values => scalar_3D_values + generic :: grid => scalar_3D_grid + generic :: to_file => scalar_3D_to_file + procedure, non_overridable, private :: scalar_3D_to_file + procedure, non_overridable, private :: scalar_3D_gradient + procedure, non_overridable, private :: scalar_3D_values + procedure, non_overridable, private :: scalar_3D_grid + end type + + interface scalar_3D_t + + pure module function construct_3D_scalar_from_function(initializer, order, cells, x_min, x_max) result(scalar_3D) + !! Result is a collection of cell-centered-extended values with a corresponding mimetic gradient operator + implicit none + procedure(scalar_3D_initializer_i), pointer :: initializer + integer, intent(in) :: order !! order of accuracy + integer, intent(in) :: cells(:) !! number of grid cells spanning each spatial direction + double precision, intent(in) :: x_min(:) !! grid location minima + double precision, intent(in) :: x_max(:) !! grid location maxima + type(scalar_3D_t) scalar_3D + end function + + pure module function construct_3D_scalar_from_mold(initializer, mold) result(scalar_3D) + !! Result is a 3D scalar field using a mold for all components other than the field values + implicit none + procedure(scalar_3D_initializer_i), pointer :: initializer + type(scalar_3D_t), intent(in) :: mold + type(scalar_3D_t) scalar_3D + end function + + end interface + + type, extends(tensor_3D_t) :: vector_3D_t + !! Encapsulate 3D vector values at cell faces (of unit area for 3D) and corresponding operators + private + type(divergence_operator_1D_t) divergence_operator_1D_(space_dimension) + contains + generic :: values => vector_3D_values + generic :: to_file => vector_3D_to_file + generic :: grid => vector_3D_grid + generic :: operator(.div.) => vector_3D_divergence + procedure, non_overridable, private :: vector_3D_values + procedure, non_overridable, private :: vector_3D_to_file + procedure, non_overridable, private :: vector_3D_grid + procedure, non_overridable, private :: vector_3D_divergence + end type + + interface vector_3D_t + + pure module function construct_3D_vector_from_function(initializer, order, cells, x_min, x_max) result(vector_3D) + !! Result is a 3D vector with values initialized by the provided procedure pointer sampled on the faces of + !! the specified number of evenly spaced cells covering [x_min, x_max] + implicit none + procedure(vector_3D_initializer_i), pointer :: initializer + integer, intent(in) :: order !! order of accuracy + integer, intent(in) :: cells(:) !! number of grid cells spanning each spatial direction + double precision, intent(in) :: x_min(:) !! grid location minima + double precision, intent(in) :: x_max(:) !! grid location maxima + type(vector_3D_t) vector_3D + end function + + pure module function construct_3D_vector_from_vector_mold(initializer, mold) result(vector_3D) + !! Result is a 3D vector with values initialized by the provided procedure pointer sampled on the + !! same grid as the mold + implicit none + procedure(vector_3D_initializer_i), pointer :: initializer + type(vector_3D_t), intent(in) :: mold + type(vector_3D_t) vector_3D + end function + + pure module function construct_3D_vector_from_scalar_mold(initializer, mold) result(vector_3D) + !! Result is a 3D vector with values initialized by the provided procedure pointer sampled on the + !! face-centered grid corresponding to the cell-centered grid of the mold + implicit none + procedure(vector_3D_initializer_i), pointer :: initializer + type(scalar_3D_t), intent(in) :: mold + type(vector_3D_t) vector_3D + end function + + end interface + + type, extends(vector_3D_t) :: gradient_3D_t + !! A 3D mimetic gradient vector field abstraction with a public method that produces corresponding numerical quadrature weights + end type + + type, extends(tensor_3D_t) :: divergence_3D_t + !! A 3D mimetic divergence field abstraction with a public method that produces corresponding numerical quadrature weights + contains + generic :: values => divergence_3D_values + generic :: grid => divergence_3D_grid + generic :: to_file => divergence_3D_to_file + procedure, private, non_overridable :: divergence_3D_values + procedure, private, non_overridable :: divergence_3D_grid + procedure, private, non_overridable :: divergence_3D_to_file + end type + + interface divergence_3D_t + + pure module function construct_3D_divergence_from_function(initializer, order, cells, x_min, x_max) result(divergence_3D) + !! Result is a 3D divergence initialized by sampling the initializer at cell centers defined by the other arguments + implicit none + procedure(scalar_3D_initializer_i), pointer, intent(in) :: initializer + integer, intent(in) :: order !! order of accuracy + integer, intent(in) :: cells(:) !! number of grid cells spanning each spatial direction + double precision, intent(in) :: x_min(:) !! grid location minima + double precision, intent(in) :: x_max(:) !! grid location maxima + type(divergence_3D_t) divergence_3D + end function + + pure module function construct_3D_divergence_from_vector_mold(initializer, mold) result(divergence_3D) + !! Result is a 3D divergence initialized by sampling the initializer on cell centers defined by the mold + implicit none + procedure(divergence_3D_initializer_i), pointer, intent(in) :: initializer + type(vector_3D_t), intent(in) :: mold + type(divergence_3D_t) divergence_3D + end function + + end interface + + interface + + pure module function scalar_3D_values(self) result(scalar_values) + !! Scalar values getter + class(scalar_3D_t), intent(in) :: self + double precision, allocatable :: scalar_values(:,:,:) + end function + + pure module function scalar_3D_grid(self, direction) result(scalar_grid_1D) + !! Result contains scalar grid locations along the requested spatial direction + class(scalar_3D_t), intent(in) :: self + integer, intent(in) :: direction + double precision, allocatable :: scalar_grid_1D(:) + end function + + pure module function vector_3D_grid(self, direction) result(vector_grid_1D) + !! Result contains scalar grid locations along the requested spatial direction + class(vector_3D_t), intent(in) :: self + integer, intent(in) :: direction + double precision, allocatable :: vector_grid_1D(:) !! grid points along one the requested coordinate direction + end function + + pure module function vector_3D_values(self) result(vector_values) + !! Vector values getter + class(vector_3D_t), intent(in) :: self + double precision, allocatable :: vector_values(:,:,:,:) + end function + + pure module function scalar_3D_gradient(self) result(gradient_3D) + !! Result is the mimetic gradient of the scalar_3D_t "self" + implicit none + class(scalar_3D_t), intent(in) :: self + type(gradient_3D_t) gradient_3D + end function + + pure module function vector_3D_divergence(self) result(divergence_3D) + !! Result is mimetic divergence of the scalar_3D_t "self" + implicit none + class(vector_3D_t), intent(in) :: self + type(divergence_3D_t) divergence_3D + end function + + pure module function scalar_3D_to_file(self) result(file) + !! Result is a file_t object containing the grid points and the corresponding scalar values + implicit none + class(scalar_3D_t), intent(in) :: self + type(file_t) file + end function + + pure module function vector_3D_to_file(self) result(file) + !! Result is a file_t object containing the grid points and the corresponding vector components + implicit none + class(vector_3D_t), intent(in) :: self + type(file_t) file + end function + + pure module function divergence_3D_grid(self, direction) result(divergence_grid_1D) + !! Result array contains divergence grid locations along the requested spatial direction + class(divergence_3D_t), intent(in) :: self + integer, intent(in) :: direction + double precision, allocatable :: divergence_grid_1D(:) !! grid points along the requested coordinate direction + end function + + pure module function divergence_3D_values(self) result(divergence_values) + !! Vector values getter + class(divergence_3D_t), intent(in) :: self + double precision, allocatable :: divergence_values(:,:,:) + end function + + pure module function divergence_3D_to_file(self) result(file) + !! Result is a file_t object containing the grid points and the corresponding divergence values + implicit none + class(divergence_3D_t), intent(in) :: self + type(file_t) file + end function + + end interface + +end module tensors_3D_m diff --git a/src/formal/vector_1D_s.F90 b/src/formal/vector_1D_s.F90 index 8dc9e34..c8cf0db 100644 --- a/src/formal/vector_1D_s.F90 +++ b/src/formal/vector_1D_s.F90 @@ -27,67 +27,54 @@ v_dot_dS%divergence_operator_1D_ = vector_1D%divergence_operator_1D_ end procedure -#ifndef __GFORTRAN__ - module procedure construct_1D_vector_from_function call_julienne_assert(x_max .greaterThan. x_min) call_julienne_assert(cells .isAtLeast. 2*order+1) - associate(values => initializer(faces(x_min, x_max, cells))) + associate(values => initializer(faces_1D(x_min, x_max, cells))) vector_1D%tensor_1D_t = tensor_1D_t(values, x_min, x_max, cells, order) end associate vector_1D%divergence_operator_1D_ = divergence_operator_1D_t(k=order, dx=(x_max - x_min)/cells, cells=cells) end procedure -#else - - pure module function construct_1D_vector_from_function(initializer, order, cells, x_min, x_max) result(vector_1D) - procedure(vector_1D_initializer_i), pointer :: initializer - integer, intent(in) :: order !! order of accuracy - integer, intent(in) :: cells !! number of grid cells spanning the domain - double precision, intent(in) :: x_min !! grid location minimum - double precision, intent(in) :: x_max !! grid location maximum - type(vector_1D_t) vector_1D - - call_julienne_assert(x_max .greaterThan. x_min) - call_julienne_assert(cells .isAtLeast. 2*order+1) + module procedure construct_1D_vector_from_parent + vector_1D%tensor_1D_t = tensor_1D + vector_1D%divergence_operator_1D_ = divergence_operator_1D_t(k=tensor_1D%order_, dx=(tensor_1D%x_max_ - tensor_1D%x_min_)/tensor_1D%cells_, cells=tensor_1D%cells_) + end procedure - associate(values => initializer(faces(x_min, x_max, cells))) - vector_1D%tensor_1D_t = tensor_1D_t(values, x_min, x_max, cells, order) - end associate - vector_1D%divergence_operator_1D_ = divergence_operator_1D_t(k=order, dx=(x_max - x_min)/cells, cells=cells) - end function + module procedure construct_1D_vector_constant -#endif + integer i - module procedure construct_from_components - vector_1D%tensor_1D_t = tensor_1D - vector_1D%divergence_operator_1D_ = divergence_operator_1D + call_julienne_assert(x_max .greaterThan. x_min) + call_julienne_assert(cells .isAtLeast. 2*order) + + vector_1D = vector_1D_t( tensor_1D_t( & + values = [(constant, i = 1, size(faces_1D(x_min, x_max, cells)))] & + ,x_min = x_min & + ,x_max = x_max & + ,cells = cells & + ,order = order & + ) ) end procedure module procedure div integer center -#ifdef NAGFOR - associate(D => self%divergence_operator_1D_) -#else - associate(D => (self%divergence_operator_1D_)) -#endif - associate(Dv => D .x. self%values_) - divergence_1D%tensor_1D_t = tensor_1D_t(Dv(2:size(Dv)-1), self%x_min_, self%x_max_, self%cells_, self%order_) + associate(Dv => self%divergence_operator_1D_ .x. self%values_) + divergence_1D%tensor_1D_t = tensor_1D_t(Dv(2:size(Dv)-1), self%x_min_, self%x_max_, self%cells_, self%order_) #if ASSERTIONS - associate( & - q => divergence_1D%weights() & - ,dx => (self%x_max_ - self%x_min_)/self%cells_ & - ,b => [-1D0, [(0D0, center = 1, self%cells_-1)], 1D0] & - ) - call_julienne_assert(.all. ([size(Dv), size(q)] .equalsExpected. self%cells_+2)) - call_julienne_assert((.all. (matmul(transpose(D%assemble()), q) .approximates. b/dx .within. double_equivalence))) - ! Check D^T * a = b_{m+1}, Eq. (19), Corbino & Castillo (2020) - end associate -#endif + associate( & + q => divergence_1D%weights() & + ,dx => (self%x_max_ - self%x_min_)/self%cells_ & + ,b => [-1D0, [(0D0, center = 1, self%cells_-1)], 1D0] & + ) + call_julienne_assert(.all. ([size(Dv), size(q)] .equalsExpected. self%cells_+2)) + call_julienne_assert((.all. (matmul(transpose(self%divergence_operator_1D_%assemble()), q) .approximates. b/dx .within. double_equivalence))) + ! Check D^T * a = b_{m+1}, Eq. (19), Corbino & Castillo (2020) end associate +#endif end associate end procedure @@ -96,19 +83,8 @@ pure module function construct_1D_vector_from_function(initializer, order, cells face_centered_values = self%values_ end procedure - pure function faces(x_min, x_max, cells) result(x) - double precision, intent(in) :: x_min, x_max - integer, intent(in) :: cells - double precision, allocatable:: x(:) - integer cell - - associate(dx => (x_max - x_min)/cells) - x = [x_min, x_min + [(cell*dx, cell = 1, cells-1)], x_max] - end associate - end function - module procedure vector_1D_grid - cell_faces = faces(self%x_min_, self%x_max_, self%cells_) + cell_faces = faces_1D(self%x_min_, self%x_max_, self%cells_) end procedure module procedure weighted_premultiply diff --git a/src/formal/vector_2D_s.F90 b/src/formal/vector_2D_s.F90 new file mode 100644 index 0000000..2c4fc02 --- /dev/null +++ b/src/formal/vector_2D_s.F90 @@ -0,0 +1,148 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +#include "julienne-assert-macros.h" + +submodule(tensors_2D_m) vector_2D_s + use julienne_m, only : & + call_julienne_assert_ & + ,operator(.all.) & + ,operator(.csv.) & + ,operator(.equalsExpected.) & + ,operator(.greaterThan.) & + ,operator(.isAtLeast.) & + ,string_t + use tensors_1D_m, only : faces_1D, vector_1D_t + implicit none + + integer, parameter :: x_dir=1, y_dir=2 + +contains + + module procedure construct_2D_vector_from_function + + integer dir + + call_julienne_assert(.all. ([size(cells), size(x_min), size(x_max)] .equalsExpected. space_dimension)) + call_julienne_assert(.all. (x_max .greaterThan. x_min)) + call_julienne_assert(.all. (cells .isAtLeast. 2*order)) + + associate(x => faces_1D(x_min(1), x_max(1), cells(1)), y => faces_1D(x_min(2), x_max(2), cells(2))) + associate(vector_values => initializer(x,y)) + vector_2D%tensor_2D_t = tensor_2D_t( & + values = reshape(vector_values, shape=[shape(vector_values),1,1,1]) & + ,cells = cells, x_min = x_min, x_max = x_max, order = order & + ) + end associate + vector_2D%divergence_operator_1D_ = [(divergence_operator_1D_t(k=order, dx=((x_max(dir)-x_min(dir))/cells(dir)), cells=cells(dir)), dir=1,space_dimension)] + end associate + end procedure + + module procedure construct_2D_vector_from_vector_mold + integer dir + + call_julienne_assert(.all. ([size(mold%cells_), size(mold%x_min_), size(mold%x_max_)] .equalsExpected. space_dimension)) + call_julienne_assert(.all. (mold%x_max_ .greaterThan. mold%x_min_)) + call_julienne_assert(.all. (mold%cells_ .isAtLeast. 2*mold%order_)) + + associate(x => faces_1D(mold%x_min_(1), mold%x_max_(1), mold%cells_(1)), y => faces_1D(mold%x_min_(2), mold%x_max_(2), mold%cells_(2))) + associate(vector_values => initializer(x,y)) + vector_2D%tensor_2D_t = tensor_2D_t( & + values = reshape(vector_values, shape=[shape(vector_values),1,1,1]) & + ,cells = mold%cells_, x_min = mold%x_min_, x_max = mold%x_max_, order = mold%order_ & + ) + end associate + vector_2D%divergence_operator_1D_ = [(divergence_operator_1D_t(k=mold%order_, dx=((mold%x_max_(dir)-mold%x_min_(dir))/mold%cells_(dir)), cells=mold%cells_(dir)), dir=1,space_dimension)] + end associate + end procedure + + module procedure construct_2D_vector_from_scalar_mold + integer dir + + call_julienne_assert(.all. ([size(mold%cells_), size(mold%x_min_), size(mold%x_max_)] .equalsExpected. space_dimension)) + call_julienne_assert(.all. (mold%x_max_ .greaterThan. mold%x_min_)) + call_julienne_assert(.all. (mold%cells_ .isAtLeast. 2*mold%order_)) + + associate(x => faces_1D(mold%x_min_(1), mold%x_max_(1), mold%cells_(1)), y => faces_1D(mold%x_min_(2), mold%x_max_(2), mold%cells_(2))) + associate(vector_values => initializer(x,y)) + vector_2D%tensor_2D_t = tensor_2D_t( & + values = reshape(vector_values, shape=[shape(vector_values),1,1,1]) & + ,cells = mold%cells_, x_min = mold%x_min_, x_max = mold%x_max_, order = mold%order_ & + ) + end associate + vector_2D%divergence_operator_1D_ = [(divergence_operator_1D_t(k=mold%order_, dx=((mold%x_max_(dir)-mold%x_min_(dir))/mold%cells_(dir)), cells=mold%cells_(dir)), dir=1,space_dimension)] + end associate + end procedure + + module procedure vector_2D_values + call_julienne_assert(allocated(self%values_)) + vector_values = self%values_(:,:,:,1,1,1) + end procedure + + module procedure vector_2D_to_file + type(string_t), allocatable :: lines(:) + integer i, j, l + + call_julienne_assert(allocated(self%values_)) + + associate(x => self%grid(x_dir), y => self%grid(y_dir), header => [string_t("x,y,vector_x,vector_y")]) + associate(num_blank_lines => size(y)-1) + allocate(lines(size(header) + size(self%values_)/space_dimension + num_blank_lines)) + end associate + lines(1:size(header)) = header + l = size(header) + do j = 1, size(y) + do i = 1, size(x) + l = l + 1 + lines(l) = .csv. string_t([x(i), y(j), self%values_(i,j,1:space_dimension,1,1,1)]) + end do + if (j/=size(y)) then + l = l + 1 + lines(l) = "" + end if + end do + end associate + + file = file_t(lines) + end procedure + + module procedure vector_2D_grid + associate(vector_1D => vector_1D_t( & + constant = 0D0 & + ,cells = self%cells_(direction) & + ,x_min = self%x_min_(direction) & + ,x_max = self%x_max_(direction) & + ,order = self%order_ & + )) + vector_grid_1D = vector_1D%grid() + end associate + end procedure + + module procedure vector_2D_divergence + + call_julienne_assert(allocated(self%values_)) + + divergence_2D%x_min_ = self%x_min_ + divergence_2D%x_max_ = self%x_max_ + divergence_2D%cells_ = self%cells_ + divergence_2D%order_ = self%order_ + + allocate(divergence_2D%values_(self%cells_(x_dir), self%cells_(y_dir), 1, 1, 1, 1)) + + divergence_x_term: & + do concurrent(integer :: j=1:size(divergence_2D%values_,y_dir)) default(none) shared(divergence_2D, self) + associate(padded_divergence => self%divergence_operator_1D_(x_dir) .x. self%values_(:,j,x_dir,1,1,1)) + divergence_2D%values_(:,j,1,1,1,1) = padded_divergence(2:size(padded_divergence)-1) + end associate + end do divergence_x_term + + add_y_term: & + do concurrent(integer :: i=1:size(divergence_2D%values_,x_dir)) default(none) shared(divergence_2D, self) + associate(padded_divergence => self%divergence_operator_1D_(y_dir) .x. self%values_(i,:,y_dir,1,1,1)) + divergence_2D%values_(i,:,1,1,1,1) = divergence_2D%values_(i,:,1,1,1,1) + padded_divergence(2:size(padded_divergence)-1) + end associate + end do add_y_term + + end procedure + +end submodule vector_2D_s \ No newline at end of file diff --git a/src/formal/vector_3D_s.F90 b/src/formal/vector_3D_s.F90 new file mode 100644 index 0000000..0369f3e --- /dev/null +++ b/src/formal/vector_3D_s.F90 @@ -0,0 +1,173 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +#include "julienne-assert-macros.h" + +submodule(tensors_3D_m) vector_3D_s + use julienne_m, only : & + call_julienne_assert_ & + ,operator(.all.) & + ,operator(.csv.) & + ,operator(.equalsExpected.) & + ,operator(.greaterThan.) & + ,operator(.isAtLeast.) & + ,string_t + use tensors_1D_m, only : faces_1D, vector_1D_t + use differential_operators_1D_m, only : divergence_operator_1D_t + implicit none + + integer, parameter :: x_dir=1, y_dir=2, z_dir=3 + +contains + + module procedure construct_3D_vector_from_function + + integer dir + + call_julienne_assert(.all. ([size(cells), size(x_min), size(x_max)] .equalsExpected. space_dimension)) + call_julienne_assert(.all. (x_max .greaterThan. x_min)) + call_julienne_assert(.all. (cells .isAtLeast. 2*order)) + + associate( & + x => faces_1D(x_min(1), x_max(1), cells(1)) & + ,y => faces_1D(x_min(2), x_max(2), cells(2)) & + ,z => faces_1D(x_min(3), x_max(3), cells(3)) & + ) + associate(vector_values => initializer(x,y,z)) + vector_3D%tensor_3D_t = tensor_3D_t( & + values = reshape(vector_values, shape=[shape(vector_values),1,1,1]) & + ,cells = cells, x_min = x_min, x_max = x_max, order = order & + ) + end associate + vector_3D%divergence_operator_1D_ = & + [(divergence_operator_1D_t(k=order, dx=((x_max(dir)-x_min(dir))/cells(dir)), cells=cells(dir)), dir=1,space_dimension)] + end associate + end procedure + + module procedure construct_3D_vector_from_vector_mold + integer dir + + call_julienne_assert(.all. ([size(mold%cells_), size(mold%x_min_), size(mold%x_max_)] .equalsExpected. space_dimension)) + call_julienne_assert(.all. (mold%x_max_ .greaterThan. mold%x_min_)) + call_julienne_assert(.all. (mold%cells_ .isAtLeast. 2*mold%order_)) + + associate( & + x => faces_1D(mold%x_min_(1), mold%x_max_(1), mold%cells_(1)) & + ,y => faces_1D(mold%x_min_(2), mold%x_max_(2), mold%cells_(2)) & + ,z => faces_1D(mold%x_min_(3), mold%x_max_(3), mold%cells_(3)) & + ) + associate(vector_values => initializer(x,y,z)) + vector_3D%tensor_3D_t = tensor_3D_t( & + values = reshape(vector_values, shape=[shape(vector_values),1,1,1]) & + ,cells = mold%cells_, x_min = mold%x_min_, x_max = mold%x_max_, order = mold%order_ & + ) + end associate + vector_3D%divergence_operator_1D_ = & + [(divergence_operator_1D_t(k=mold%order_, dx=((mold%x_max_(dir)-mold%x_min_(dir))/mold%cells_(dir)), cells=mold%cells_(dir)), dir=1,space_dimension)] + end associate + end procedure + + module procedure construct_3D_vector_from_scalar_mold + integer dir + + call_julienne_assert(.all. ([size(mold%cells_), size(mold%x_min_), size(mold%x_max_)] .equalsExpected. space_dimension)) + call_julienne_assert(.all. (mold%x_max_ .greaterThan. mold%x_min_)) + call_julienne_assert(.all. (mold%cells_ .isAtLeast. 2*mold%order_)) + + associate( & + x => faces_1D(mold%x_min_(1), mold%x_max_(1), mold%cells_(1)) & + ,y => faces_1D(mold%x_min_(2), mold%x_max_(2), mold%cells_(2)) & + ,z => faces_1D(mold%x_min_(3), mold%x_max_(3), mold%cells_(3)) & + ) + associate(vector_values => initializer(x,y,z)) + vector_3D%tensor_3D_t = tensor_3D_t( & + values = reshape(vector_values, shape=[shape(vector_values),1,1,1]) & + ,cells = mold%cells_, x_min = mold%x_min_, x_max = mold%x_max_, order = mold%order_ & + ) + end associate + vector_3D%divergence_operator_1D_ = & + [(divergence_operator_1D_t(k=mold%order_, dx=((mold%x_max_(dir)-mold%x_min_(dir))/mold%cells_(dir)), cells=mold%cells_(dir)), dir=1,space_dimension)] + end associate + end procedure + + module procedure vector_3D_values + vector_values = self%values_(:,:,:,:,1,1,1) + end procedure + + module procedure vector_3D_to_file + type(string_t), allocatable :: lines(:) + integer i, j, k, l + + associate(x => self%grid(1), y => self%grid(2), z => self%grid(3), header => [string_t("x,y,vector_x,vector_y")]) + associate(num_blank_lines => size(y)*size(z) - 1) + allocate(lines(size(header) + size(self%values_) + num_blank_lines)) + end associate + lines(1:size(header)) = header + l = size(header) + do k = 1, size(z) + do j = 1, size(y) + do i = 1, size(x) + l = l + 1 + lines(l) = .csv. string_t([x(i), y(j), z(k), self%values_(i,j,k,1:space_dimension,1,1,1)]) + end do + if (j/=size(y) .or. k/=size(z)) then + l = l + 1 + lines(l) = "" + end if + end do + end do + end associate + + file = file_t(lines) + end procedure + + module procedure vector_3D_grid + associate(vector_1D => vector_1D_t( & + constant = 0D0 & + ,cells = self%cells_(direction) & + ,x_min = self%x_min_(direction) & + ,x_max = self%x_max_(direction) & + ,order = self%order_ & + )) + vector_grid_1D = vector_1D%grid() + end associate + end procedure + + module procedure vector_3D_divergence + + call_julienne_assert(allocated(self%values_)) + + divergence_3D%x_min_ = self%x_min_ + divergence_3D%x_max_ = self%x_max_ + divergence_3D%cells_ = self%cells_ + divergence_3D%order_ = self%order_ + + allocate(divergence_3D%values_(self%cells_(x_dir), self%cells_(y_dir), self%cells_(z_dir), 1, 1, 1, 1)) + + divergence_x_term: & + do concurrent(integer :: j=1:size(divergence_3D%values_,y_dir),k=1:size(divergence_3D%values_,z_dir)) & + default(none) shared(divergence_3D, self) + associate(padded_divergence => self%divergence_operator_1D_(x_dir) .x. self%values_(:,j,k,x_dir,1,1,1)) + divergence_3D%values_(:,j,k,1,1,1,1) = padded_divergence(2:size(padded_divergence)-1) + end associate + end do divergence_x_term + + add_y_term: & + do concurrent(integer :: i=1:size(divergence_3D%values_,x_dir), k=1:size(divergence_3D%values_,z_dir)) & + default(none) shared(divergence_3D, self) + associate(padded_divergence => self%divergence_operator_1D_(y_dir) .x. self%values_(i,:,k,y_dir,1,1,1)) + divergence_3D%values_(i,:,k,1,1,1,1) = divergence_3D%values_(i,:,k,1,1,1,1) + padded_divergence(2:size(padded_divergence)-1) + end associate + end do add_y_term + + add_z_term: & + do concurrent(integer :: i=1:size(divergence_3D%values_,x_dir), j=1:size(divergence_3D%values_,y_dir)) & + default(none) shared(divergence_3D, self) + associate(padded_divergence => self%divergence_operator_1D_(z_dir) .x. self%values_(i,j,:,z_dir,1,1,1)) + divergence_3D%values_(i,j,:,1,1,1,1) = divergence_3D%values_(i,j,:,1,1,1,1) + padded_divergence(2:size(padded_divergence)-1) + end associate + end do add_z_term + + end procedure + +end submodule vector_3D_s \ No newline at end of file diff --git a/src/formal_m.f90 b/src/formal_m.f90 index 2fc9526..0377f88 100644 --- a/src/formal_m.f90 +++ b/src/formal_m.f90 @@ -18,6 +18,24 @@ module formal_m ,d_dx & ! scalar_1D_t spatial derivative ,d2_dx2 ! scalar_1D_t spatial derivative + use tensors_2D_m, only : & + scalar_2D_t & ! discrete 2D scalar field derived type + ,vector_2D_t & ! discrete 2D vector field derived type + ,divergence_2D_t & ! discrete 2D divergence field derived type + ,gradient_2D_t & ! result of `.grad. s` for a scalar_2D_t s + ,scalar_2D_initializer_i & ! scalar_2D_t initializer abstract interface + ,vector_2D_initializer_i & ! vector_2D_t initializar abstract interface + ,divergence_2D_initializer_i ! divergence_2D_t initializar abstract interface + + use tensors_3D_m, only : & + scalar_3D_t & ! discrete 3D scalar field derived type + ,vector_3D_t & ! discrete 3D vector field derived type + ,divergence_3D_t & ! discrete 3D divergence field derived type + ,gradient_3D_t & ! result of `.grad. s` for a scalar_3D_t s + ,scalar_3D_initializer_i & ! scalar_3D_t initializer abstract interface + ,vector_3D_initializer_i & ! vector_3D_t initializar abstract interface + ,divergence_3D_initializer_i ! divergence_2D_t initializar abstract interface + use differential_operators_1D_m, only : & gradient_operator_1D_t & ! matrix operator defining a 1D mimetic gradient ,divergence_operator_1D_t ! matrix operator defining a 1D mimetic divergence diff --git a/test/divergence_operator_1D_test_m.F90 b/test/divergence_operator_1D_test_m.F90 index 87adb5a..5ecd49b 100644 --- a/test/divergence_operator_1D_test_m.F90 +++ b/test/divergence_operator_1D_test_m.F90 @@ -10,6 +10,7 @@ module divergence_operator_1D_test_m ,operator(.all.) & ,operator(.also.) & ,operator(.approximates.) & + ,operator(.equalsExpected.) & ,operator(.within.) & ,passing_test & ,string_t & @@ -19,9 +20,6 @@ module divergence_operator_1D_test_m ,test_result_t & ,usher use formal_m, only : vector_1D_t, vector_1D_initializer_i, scalar_1D_t, scalar_1D_initializer_i -#ifdef __GFORTRAN__ - use formal_m, only : divergence_1D_t -#endif implicit none type, extends(test_t) :: divergence_operator_1D_test_t @@ -69,40 +67,22 @@ function check_2nd_order_div_grad_parabola() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer => parabola double precision, parameter :: expected_divergence = 1D0 -#ifdef __GFORTRAN__ - type(divergence_1D_t) div_grad_scalar - div_grad_scalar = .div. (.grad. scalar_1D_t(scalar_1D_initializer, order=2, cells=16, x_min=0D0, x_max=5D0)) -#else associate(div_grad_scalar => .div. (.grad. scalar_1D_t(scalar_1D_initializer, order=2, cells=16, x_min=0D0, x_max=5D0))) -#endif - test_diagnosis = passing_test() test_diagnosis = test_diagnosis .also. (.all. (div_grad_scalar%values() .approximates. expected_divergence .within. tight_tolerance)) & // " (2nd-order .div. (.grad. (x**2)/2))" - -#ifndef __GFORTRAN__ end associate -#endif end function function check_4th_order_div_grad_parabola() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer => parabola double precision, parameter :: expected_divergence = 1D0 -#ifdef __GFORTRAN__ - type(divergence_1D_t) div_grad_scalar - div_grad_scalar = .div. (.grad. scalar_1D_t(scalar_1D_initializer, order=4, cells=16, x_min=0D0, x_max=9D0)) -#else associate(div_grad_scalar => .div. (.grad. scalar_1D_t(scalar_1D_initializer, order=4, cells=16, x_min=0D0, x_max=9D0))) -#endif - test_diagnosis = passing_test() test_diagnosis = test_diagnosis .also. (.all. (div_grad_scalar%values() .approximates. expected_divergence .within. tight_tolerance)) & // " (4th-order .div. (.grad. (x**2)/2))" - -#ifndef __GFORTRAN__ end associate -#endif end function pure function sinusoid(x) result(y) @@ -116,16 +96,13 @@ function check_2nd_order_div_sinusoid_convergence() result(test_diagnosis) procedure(vector_1D_initializer_i), pointer :: vector_1D_initializer => sinusoid double precision, parameter :: pi = 3.141592653589793D0 integer, parameter :: order_desired = 2, coarse_cells=100, fine_cells=coarse_cells+1 -#ifdef __GFORTRAN__ - type(divergence_1D_t) div_coarse, div_fine - div_coarse = .div. vector_1D_t(vector_1D_initializer , order=order_desired, cells=coarse_cells, x_min=0D0, x_max=2*pi) - div_fine = .div. vector_1D_t(vector_1D_initializer , order=order_desired, cells=fine_cells , x_min=0D0, x_max=2*pi) -#else associate( & div_coarse => .div. vector_1D_t(vector_1D_initializer , order=order_desired, cells=coarse_cells, x_min=0D0, x_max=2*pi) & ,div_fine => .div. vector_1D_t(vector_1D_initializer , order=order_desired, cells=fine_cells , x_min=0D0, x_max=2*pi) & ) -#endif + test_diagnosis = passing_test() + test_diagnosis = test_diagnosis .also. (size(div_coarse%values()) .equalsExpected. coarse_cells) + test_diagnosis = test_diagnosis .also. (size(div_fine%values()) .equalsExpected. fine_cells) associate( & x_coarse => div_coarse%grid() & ,x_fine => div_fine%grid()) @@ -135,7 +112,6 @@ function check_2nd_order_div_sinusoid_convergence() result(test_diagnosis) ,div_coarse_values => div_coarse%values() & ,div_fine_values => div_fine%values() & ) - test_diagnosis = passing_test() test_diagnosis = test_diagnosis .also. (.all. (div_coarse_values .approximates. grad_coarse .within. rough_tolerance)) & // " (coarse-grid 2nd-order .div. [sin(x) + cos(x)])" test_diagnosis = test_diagnosis .also. (.all. (div_fine_values .approximates. grad_fine .within. rough_tolerance)) & @@ -151,9 +127,7 @@ function check_2nd_order_div_sinusoid_convergence() result(test_diagnosis) end associate end associate end associate -#ifndef __GFORTRAN__ end associate -#endif end function function check_4th_order_div_sinusoid_convergence() result(test_diagnosis) @@ -161,16 +135,10 @@ function check_4th_order_div_sinusoid_convergence() result(test_diagnosis) procedure(vector_1D_initializer_i), pointer :: vector_1D_initializer => sinusoid double precision, parameter :: pi = 3.141592653589793D0 integer, parameter :: order_desired = 4, coarse_cells=500, fine_cells=coarse_cells+1 -#ifdef __GFORTRAN__ - type(divergence_1D_t) div_coarse, div_fine - div_coarse = .div. vector_1D_t(vector_1D_initializer , order=order_desired, cells=coarse_cells, x_min=0D0, x_max=2*pi) - div_fine = .div. vector_1D_t(vector_1D_initializer , order=order_desired, cells=fine_cells , x_min=0D0, x_max=2*pi) -#else associate( & div_coarse => .div. vector_1D_t(vector_1D_initializer , order=order_desired, cells=coarse_cells, x_min=0D0, x_max=2*pi) & ,div_fine => .div. vector_1D_t(vector_1D_initializer , order=order_desired, cells=fine_cells , x_min=0D0, x_max=2*pi) & ) -#endif associate( & x_coarse => div_coarse%grid() & ,x_fine => div_fine%grid() & @@ -183,6 +151,8 @@ function check_4th_order_div_sinusoid_convergence() result(test_diagnosis) ) test_diagnosis = passing_test() + test_diagnosis = test_diagnosis .also. (size(div_coarse_values) .equalsExpected. coarse_cells) + test_diagnosis = test_diagnosis .also. (size(div_fine_values) .equalsExpected. fine_cells) test_diagnosis = test_diagnosis .also. (.all. (div_coarse_values .approximates. div_coarse_expected .within. loose_tolerance)) & // " (coarse-grid 4th-order .div. [sin(x) + cos(x)])" test_diagnosis = test_diagnosis .also. (.all. (div_fine_values .approximates. div_fine_expected .within. loose_tolerance)) & @@ -199,9 +169,7 @@ function check_4th_order_div_sinusoid_convergence() result(test_diagnosis) end associate end associate end associate -#ifndef __GFORTRAN__ end associate -#endif end function end module divergence_operator_1D_test_m \ No newline at end of file diff --git a/test/driver.f90 b/test/driver.f90 index 65809b8..35d7202 100644 --- a/test/driver.f90 +++ b/test/driver.f90 @@ -10,6 +10,10 @@ program test_suite_driver use integration_operators_1D_test_m, only : integration_operators_1D_test_t use interpolator_1D_test_m, only : interpolator_1D_test_t use scalar_1D_test_m, only : scalar_1D_test_t + use scalar_2D_test_m, only : scalar_2D_test_t + use scalar_3D_test_m, only : scalar_3D_test_t + use vector_2D_test_m, only : vector_2D_test_t + use vector_3D_test_m, only : vector_3D_test_t implicit none associate(test_harness => test_harness_t([ & @@ -19,6 +23,10 @@ program test_suite_driver ,test_fixture_t(integration_operators_1D_test_t()) & ,test_fixture_t(interpolator_1D_test_t()) & ,test_fixture_t(scalar_1D_test_t()) & + ,test_fixture_t(scalar_2D_test_t()) & + ,test_fixture_t(scalar_3D_test_t()) & + ,test_fixture_t(vector_2D_test_t()) & + ,test_fixture_t(vector_3D_test_t()) & ])) call test_harness%report_results end associate diff --git a/test/gradient_operator_1D_test_m.F90 b/test/gradient_operator_1D_test_m.F90 index 1f35875..e9564ad 100644 --- a/test/gradient_operator_1D_test_m.F90 +++ b/test/gradient_operator_1D_test_m.F90 @@ -19,9 +19,6 @@ module gradient_operator_1D_test_m ,test_result_t & ,usher use formal_m, only : scalar_1D_t, scalar_1D_initializer_i -#ifdef __GFORTRAN__ - use formal_m, only : vector_1D_t, vector_1D_initializer_i, gradient_1D_t -#endif type, extends(test_t) :: gradient_operator_1D_test_t contains @@ -69,34 +66,16 @@ function check_grad_const() result(test_diagnosis) double precision, parameter :: grad_expected = 0. procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer => const -#ifdef __GFORTRAN__ - type(gradient_1D_t) grad - - grad = .grad. scalar_1D_t(scalar_1D_initializer, order=2, cells=16, x_min=0D0, x_max=4D0) -#else associate(grad => .grad. scalar_1D_t(scalar_1D_initializer, order=2, cells=16, x_min=0D0, x_max=4D0)) -#endif - test_diagnosis = passing_test() test_diagnosis = test_diagnosis .also. (.all. (grad%values() .approximates. grad_expected .within. loose_tolerance)) & // " (2nd-order .grad.(5))" - -#ifndef __GFORTRAN__ end associate -#endif -#ifdef __GFORTRAN__ - grad = .grad. scalar_1D_t(scalar_1D_initializer, order=4, cells=16, x_min=0D0, x_max=8D0) -#else associate(grad => .grad. scalar_1D_t(scalar_1D_initializer, order=4, cells=16, x_min=0D0, x_max=8D0)) -#endif - test_diagnosis = test_diagnosis .also. (.all. (grad%values() .approximates. grad_expected .within. loose_tolerance)) & // " (4th-order .grad.(5))" - -#ifndef __GFORTRAN__ end associate -#endif end function pure function line(x) result(y) @@ -109,34 +88,17 @@ function check_grad_line() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis double precision, parameter :: grad_expected = 14D0 procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer => line -#ifdef __GFORTRAN__ - type(gradient_1D_t) grad - grad = .grad. scalar_1D_t(scalar_1D_initializer, order=2, cells=16, x_min=0D0, x_max=4D0) -#else associate(grad => .grad. scalar_1D_t(scalar_1D_initializer, order=2, cells=16, x_min=0D0, x_max=4D0)) -#endif - test_diagnosis = passing_test() test_diagnosis = test_diagnosis .also. (.all. (grad%values() .approximates. grad_expected .within. loose_tolerance)) & // " (2nd-order .grad.(14*x + 3))" - -#ifndef __GFORTRAN__ end associate -#endif -#ifdef __GFORTRAN__ - grad = .grad. scalar_1D_t(scalar_1D_initializer, order=4, cells=16, x_min=0D0, x_max=8D0) -#else associate(grad => .grad. scalar_1D_t(scalar_1D_initializer, order=4, cells=16, x_min=0D0, x_max=8D0)) -#endif - test_diagnosis = test_diagnosis .also. (.all. (grad%values() .approximates. grad_expected .within. loose_tolerance)) & // " (4th-order .grad.(14*x + 3))" - -#ifndef __GFORTRAN__ end associate -#endif end function pure function parabola(x) result(y) @@ -148,43 +110,25 @@ pure function parabola(x) result(y) function check_grad_parabola() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer => parabola -#ifdef __GFORTRAN__ - type(gradient_1D_t) grad - grad = .grad. scalar_1D_t(scalar_1D_initializer , order=2, cells=16, x_min=0D0, x_max=4D0) -#else associate(grad => .grad. scalar_1D_t(scalar_1D_initializer , order=2, cells=16, x_min=0D0, x_max=4D0)) -#endif - test_diagnosis = passing_test() - associate(x => grad%grid()) associate(grad_expected => 14*x + 3) test_diagnosis = test_diagnosis .also. (.all. (grad%values() .approximates. grad_expected .within. loose_tolerance)) & // " (2nd-order .grad.(7*x**2 + 3*x + 5))" end associate end associate - -#ifndef __GFORTRAN__ end associate -#endif -#ifdef __GFORTRAN__ - grad = .grad. scalar_1D_t(scalar_1D_initializer , order=4, cells=16, x_min=0D0, x_max=8D0) -#else associate(grad => .grad. scalar_1D_t(scalar_1D_initializer , order=4, cells=16, x_min=0D0, x_max=8D0)) -#endif - associate(x => grad%grid()) associate(grad_expected => 14*x + 3) test_diagnosis = test_diagnosis .also. (.all. (grad%values() .approximates. grad_expected .within. loose_tolerance)) & // " (4th-order .grad.(7*x**2 + 3*x + 5))" end associate end associate - -#ifndef __GFORTRAN__ end associate -#endif end function pure function sinusoid(x) result(y) @@ -199,17 +143,10 @@ function check_2nd_order_grad_convergence() result(test_diagnosis) procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer => sinusoid double precision, parameter :: pi = 3.141592653589793D0 integer, parameter :: order_desired = 2, coarse_cells=200, fine_cells=coarse_cells+1 -#ifdef __GFORTRAN__ - type(gradient_1D_t) grad_coarse, grad_fine - - grad_coarse = .grad. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=coarse_cells, x_min=0D0, x_max=2*pi) - grad_fine = .grad. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=fine_cells , x_min=0D0, x_max=2*pi) -#else associate( & grad_coarse => .grad. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=coarse_cells, x_min=0D0, x_max=2*pi) & ,grad_fine => .grad. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=fine_cells , x_min=0D0, x_max=2*pi) & ) -#endif associate( & x_coarse => grad_coarse%grid() & ,x_fine => grad_fine%grid() & @@ -236,28 +173,18 @@ function check_2nd_order_grad_convergence() result(test_diagnosis) end associate end associate end associate -#ifndef __GFORTRAN__ end associate -#endif end function function check_4th_order_grad_convergence() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer => sinusoid double precision, parameter :: pi = 3.141592653589793D0 -#ifdef __GFORTRAN__ - integer, parameter :: order_desired = 4, coarse_cells=300, fine_cells=coarse_cells+1 - type(gradient_1D_t) grad_coarse, grad_fine - - grad_coarse = .grad. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=coarse_cells, x_min=0D0, x_max=2*pi) - grad_fine = .grad. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=fine_cells , x_min=0D0, x_max=2*pi) -#else integer, parameter :: order_desired = 4, coarse_cells=400, fine_cells=coarse_cells+1 associate( & grad_coarse => .grad. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=coarse_cells, x_min=0D0, x_max=2*pi) & ,grad_fine => .grad. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=fine_cells , x_min=0D0, x_max=2*pi) & ) -#endif associate( & x_coarse => grad_coarse%grid() & ,x_fine => grad_fine%grid() & @@ -284,9 +211,7 @@ function check_4th_order_grad_convergence() result(test_diagnosis) end associate end associate end associate -#ifndef __GFORTRAN__ end associate -#endif end function end module \ No newline at end of file diff --git a/test/laplacian_operator_1D_test_m.F90 b/test/laplacian_operator_1D_test_m.F90 index ccd5486..578065a 100644 --- a/test/laplacian_operator_1D_test_m.F90 +++ b/test/laplacian_operator_1D_test_m.F90 @@ -18,9 +18,6 @@ module laplacian_operator_1D_test_m ,test_result_t & ,usher use formal_m, only : scalar_1D_t, scalar_1D_initializer_i -#ifdef __GFORTRAN__ - use formal_m, only : laplacian_1D_t -#endif implicit none type, extends(test_t) :: laplacian_operator_1D_test_t @@ -68,20 +65,12 @@ function check_2nd_order_laplacian_parabola() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer => parabola double precision, parameter :: expected_laplacian = 1D0 -#ifdef __GFORTRAN__ - type(laplacian_1D_t) laplacian_scalar - laplacian_scalar = .laplacian. scalar_1D_t(scalar_1D_initializer, order=2, cells=16, x_min=0D0, x_max=5D0) -#else - associate(laplacian_scalar => .laplacian. scalar_1D_t(scalar_1D_initializer, order=2, cells=16, x_min=0D0, x_max=5D0)) -#endif + associate(laplacian_scalar => .laplacian. scalar_1D_t(scalar_1D_initializer, order=2, cells=16, x_min=0D0, x_max=5D0)) test_diagnosis = passing_test() test_diagnosis = test_diagnosis .also. (.all. (laplacian_scalar%values() .approximates. expected_laplacian .within. tight_tolerance)) & // " (2nd-order .laplacian. [(x**2)/2]" - -#ifndef __GFORTRAN__ end associate -#endif end function pure function quartic(x) result(y) @@ -94,12 +83,7 @@ function check_4th_order_laplacian_of_quartic() result(test_diagnosis) type(test_diagnosis_t) test_diagnosis procedure(scalar_1D_initializer_i), pointer :: scalar_1D_initializer => quartic -#ifndef __GFORTRAN__ associate(laplacian_quartic => .laplacian. scalar_1D_t(scalar_1D_initializer, order=4, cells=16, x_min=0D0, x_max=40D0)) -#else - type(laplacian_1D_t) laplacian_quartic - laplacian_quartic = .laplacian. scalar_1D_t(scalar_1D_initializer, order=4, cells=16, x_min=0D0, x_max=40D0) -#endif associate(x => laplacian_quartic%grid()) associate(expected_laplacian => x**2, actual_laplacian => laplacian_quartic%values()) test_diagnosis = passing_test() @@ -107,9 +91,7 @@ function check_4th_order_laplacian_of_quartic() result(test_diagnosis) // " (4th-order .laplacian. [(x**4)/24]" end associate end associate -#ifndef __GFORTRAN__ end associate -#endif end function pure function f(x) @@ -140,16 +122,10 @@ function check_laplacian_convergence(order_desired, coarse_cells, fine_cells) re double precision, parameter :: pi = 3.141592653589793D0 integer, intent(in) :: order_desired, coarse_cells, fine_cells -#ifndef __GFORTRAN__ associate( & laplacian_coarse => .laplacian. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=coarse_cells, x_min=0D0, x_max=2*pi) & ,laplacian_fine => .laplacian. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=fine_cells , x_min=0D0, x_max=2*pi) & ) -#else - type(laplacian_1D_t) laplacian_coarse, laplacian_fine - laplacian_coarse = .laplacian. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=coarse_cells, x_min=0D0, x_max=2*pi) - laplacian_fine = .laplacian. scalar_1D_t(scalar_1D_initializer , order=order_desired, cells=fine_cells , x_min=0D0, x_max=2*pi) -#endif grids: & associate( & x_coarse => laplacian_coarse%grid() & @@ -204,9 +180,7 @@ function check_laplacian_convergence(order_desired, coarse_cells, fine_cells) re end associate laplacian_values end associate grids -#ifndef __GFORTRAN__ end associate -#endif end function end module \ No newline at end of file diff --git a/test/scalar_1D_test_m.F90 b/test/scalar_1D_test_m.F90 index 4b8edef..42c6393 100644 --- a/test/scalar_1D_test_m.F90 +++ b/test/scalar_1D_test_m.F90 @@ -63,21 +63,11 @@ function check_exponentiation() result(test_diagnosis) do order = 2, 4, 2 associate(scalar_1D => scalar_1D_t(scalar_1D_initializer, order=order, cells=10, x_min=0D0, x_max=10D0) ) -#ifndef __GFORTRAN__ associate(cube => scalar_1D**3 ) test_diagnosis = test_diagnosis .also. .all. & (cube%values() .approximates. scalar_1D%values()**3 .within. tolerance) & // string_t(" for order ") // string_t(order) end associate -#else - block - type(scalar_1D_t) cube - cube = scalar_1D**3 - test_diagnosis = test_diagnosis .also. .all. & - (cube%values() .approximates. scalar_1D%values()**3 .within. tolerance) & - // string_t(" for order ") // string_t(order) - end block -#endif end associate end do @@ -93,19 +83,10 @@ function check_divison_operator() result(test_diagnosis) do order = 2, 4, 2 associate(scalar_1D => scalar_1D_t(scalar_1D_initializer, order=order, cells=10, x_min=0D0, x_max=10D0) ) -#ifndef __GFORTRAN__ associate( half => scalar_1D/2 ) test_diagnosis = test_diagnosis .also. .all. (half%values() .approximates. scalar_1D%values()/2 .within. tolerance) & // string_t(" for order ") // string_t(order) end associate -#else - block - type(scalar_1D_t) half - half = scalar_1D/2 - test_diagnosis = test_diagnosis .also. .all. (half%values() .approximates. scalar_1D%values()/2 .within. tolerance) & - // string_t(" for order ") // string_t(order) - end block -#endif end associate end do diff --git a/test/scalar_2D_test_m.F90 b/test/scalar_2D_test_m.F90 new file mode 100644 index 0000000..d1a470f --- /dev/null +++ b/test/scalar_2D_test_m.F90 @@ -0,0 +1,84 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +module scalar_2D_test_m + use julienne_m, only : & + operator(//) & + ,operator(.all.) & + ,operator(.also.) & + ,operator(.approximates.) & + ,operator(.within.) & + ,passing_test & + ,string_t & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t & + ,usher + use formal_m, only : scalar_2D_t, vector_2D_t, scalar_2D_initializer_i, vector_2D_initializer_i + + implicit none + + type, extends(test_t) :: scalar_2D_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + + double precision, parameter :: tolerance = 5D-2 + integer, parameter :: space_dimension = 2 + +contains + + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = 'The scalar_2D_t derived type' + end function + + function results() result(test_results) + type(scalar_2D_test_t) scalar_2D_test + type(test_result_t), allocatable :: test_results(:) + + test_results = scalar_2D_test%run([ & + test_description_t('computing the gradient of a scalar field', usher(check_gradient)) & + ]) + end function + + pure function biquadratic(x,y) result(z) + double precision, intent(in) :: x(:), y(:) + double precision z(size(x),size(y)) + do concurrent(integer :: j=1:size(y)) default(none) shared(x,y,z) + z(:,j) = 1 - 2*x + 3*x**2 - x*y(j)/5 + 3*y(j)**2 - 2*y(j) + end do + end function + + pure function biquadratic_gradient(x,y) result(gradient) + double precision, intent(in) :: x(:), y(:) + double precision gradient(size(x),size(y),space_dimension) + do concurrent(integer :: i=1:size(x), j=1:size(y)) default(none) shared(gradient,x,y) + gradient(i,j,:) = [-2 + 6*x(i) - y(j)/5, -x(i)/5 + 6*y(j) - 2] + end do + end function + + function check_gradient() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + procedure(scalar_2D_initializer_i), pointer :: scalar_2D_initializer + procedure(vector_2D_initializer_i), pointer :: expected_gradient_initializer + integer order + + scalar_2D_initializer => biquadratic + expected_gradient_initializer => biquadratic_gradient + test_diagnosis = passing_test() + + do order = 2, 4, 2 + associate(scalar_2D => scalar_2D_t(scalar_2D_initializer, order=order, cells=[30,20], x_min=[-1D0,1D0], x_max=[9D0,4D0])) + associate(grad_scalar => .grad. scalar_2D, expected_gradient => vector_2D_t(expected_gradient_initializer, mold=scalar_2D)) + test_diagnosis = test_diagnosis .also. & + .all. (grad_scalar%values() .approximates. expected_gradient%values() .within. tolerance) & + // string_t(" for order ") // string_t(order) + end associate + end associate + end do + end function + +end module scalar_2D_test_m \ No newline at end of file diff --git a/test/scalar_3D_test_m.F90 b/test/scalar_3D_test_m.F90 new file mode 100644 index 0000000..6252230 --- /dev/null +++ b/test/scalar_3D_test_m.F90 @@ -0,0 +1,84 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +module scalar_3D_test_m + use julienne_m, only : & + operator(//) & + ,operator(.all.) & + ,operator(.also.) & + ,operator(.approximates.) & + ,operator(.within.) & + ,passing_test & + ,string_t & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t & + ,usher + use formal_m, only : scalar_3D_t, vector_3D_t, scalar_3D_initializer_i, vector_3D_initializer_i + + implicit none + + type, extends(test_t) :: scalar_3D_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + + double precision, parameter :: tolerance = 1D-2 + integer, parameter :: space_dimension = 3 + +contains + + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = 'The scalar_3D_t derived type' + end function + + function results() result(test_results) + type(scalar_3D_test_t) scalar_3D_test + type(test_result_t), allocatable :: test_results(:) + + test_results = scalar_3D_test%run([ & + test_description_t('computing the gradient of a scalar field', usher(check_gradient)) & + ]) + end function + + pure function triquadratic(x,y,z) result(f) + double precision, intent(in) :: x(:), y(:), z(:) + double precision f(size(x),size(y),size(z)) + do concurrent(integer :: j=1:size(y), k=1:size(z)) default(none) shared(x,y,z,f) + f(:,j,k) = 1 - 2*x + 3*x**2 - x*y(j)/5 + 3*y(j)**2 - 2*y(j) - 2*z(k) + end do + end function + + pure function triquadratic_gradient(x,y,z) result(gradient) + double precision, intent(in) :: x(:), y(:), z(:) + double precision gradient(size(x),size(y),size(z),space_dimension) + do concurrent(integer :: i=1:size(x), j=1:size(y), k=1:size(z)) default(none) shared(gradient,x,y,z) + gradient(i,j,k,:) = [-2 + 6*x(i) - y(j)/5, -x(i)/5 + 6*y(j) - 2, -2D0] + end do + end function + + function check_gradient() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + procedure(scalar_3D_initializer_i), pointer :: scalar_3D_initializer + procedure(vector_3D_initializer_i), pointer :: expected_gradient_initializer + integer order + + scalar_3D_initializer => triquadratic + expected_gradient_initializer => triquadratic_gradient + test_diagnosis = passing_test() + + do order = 2, 4, 2 + associate(scalar_3D => scalar_3D_t(scalar_3D_initializer, order=order, cells=[30,20,10], x_min=[0D0,0D0,0D0], x_max=[1D0,1D0,1D0])) + associate(grad_scalar => .grad. scalar_3D, expected_gradient => vector_3D_t(expected_gradient_initializer, mold=scalar_3D)) + test_diagnosis = test_diagnosis .also. & + .all. (grad_scalar%values() .approximates. expected_gradient%values() .within. tolerance) & + // string_t(" for order ") // string_t(order) + end associate + end associate + end do + end function + +end module scalar_3D_test_m \ No newline at end of file diff --git a/test/vector_2D_test_m.F90 b/test/vector_2D_test_m.F90 new file mode 100644 index 0000000..ed145f9 --- /dev/null +++ b/test/vector_2D_test_m.F90 @@ -0,0 +1,121 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +module vector_2D_test_m + use julienne_m, only : & + operator(//) & + ,operator(.all.) & + ,operator(.also.) & + ,operator(.approximates.) & + ,operator(.within.) & + ,operator(.withinPercentage.) & + ,passing_test & + ,string_t & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t & + ,usher + use formal_m, only : & + vector_2D_t & + ,vector_2D_initializer_i & + ,divergence_2D_t & + ,divergence_2D_initializer_i + + implicit none + + type, extends(test_t) :: vector_2D_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + + integer, parameter :: space_dimension = 2 + double precision, parameter :: tolerance = 1D-2 + +contains + + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = 'The vector_2D_t derived type' + end function + + function results() result(test_results) + type(vector_2D_test_t) vector_2D_test + type(test_result_t), allocatable :: test_results(:) + + test_results = vector_2D_test%run([ & + test_description_t('computing the divergence of a vector field', usher(check_divergence)) & + ]) + end function + + pure function biquadratic(x,y) result(z) + double precision, intent(in) :: x(:), y(:) + double precision z(size(x),size(y),space_dimension) + do concurrent(integer :: i=1:size(x), j=1:size(y)) default(none) shared(x,y,z) + z(i,j,:) = [ & + 1 - 2*x(i) + 3*x(i)**2 - x(i)*y(j)/5 + 3*y(j)**2 - 2*y(j) & + ,1 - 2*x(i) + 3*x(i)**2 - x(i)*y(j)/5 + 3*y(j)**2 - 2*y(j) & + ] + end do + end function + + pure function biquadratic_divergence(x,y) result(divergence) + double precision, intent(in) :: x(:), y(:) + double precision divergence(size(x),size(y)) + do concurrent(integer :: i=1:size(x), j=1:size(y)) default(none) shared(divergence,x,y) + divergence(i,j) = (-2 + 6*x(i) - y(j)/5) + (-2 + 6*y(j) - x(i)/5) + end do + end function + + pure function cubic(x,y) result(z) + double precision, intent(in) :: x(:), y(:) + double precision z(size(x),size(y),space_dimension) + do concurrent(integer :: i=1:size(x), j=1:size(y)) default(none) shared(x,y,z) + z(i,j,:) = [ & + 1 - 2*x(i) + 3*x(i)**3 - x(i)*y(j)/5 + 3*y(j)**3 - 2*y(j) & + ,1 - 2*x(i) + 3*x(i)**3 - x(i)*y(j)/5 + 3*y(j)**3 - 2*y(j) & + ] + end do + end function + + pure function cubic_divergence(x,y) result(divergence) + double precision, intent(in) :: x(:), y(:) + double precision divergence(size(x),size(y)) + do concurrent(integer :: i=1:size(x), j=1:size(y)) default(none) shared(divergence,x,y) + divergence(i,j) = (-2 + 9*x(i)**2 - y(j)/5) + (-2 + 9*y(j)**2 - x(i)/5) + end do + end function + + function check_divergence() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + procedure(vector_2D_initializer_i), pointer :: vector_2D_initializer + procedure(divergence_2D_initializer_i), pointer :: expected_divergence_initializer + integer order + + test_diagnosis = passing_test() + + do order = 2, 4, 2 + select case(order) + case(2) + vector_2D_initializer => biquadratic + expected_divergence_initializer => biquadratic_divergence + case(4) + vector_2D_initializer => cubic + expected_divergence_initializer => cubic_divergence + case default + error stop "check_divergence(vector_2D_test_m): unsupported order" + end select + associate(vector_2D => vector_2D_t(vector_2D_initializer, order=order, cells=[40,30], x_min=[0D0,0D0], x_max=[2D0,1D0])) + associate(div_vector => .div. vector_2D) + associate(expected_divergence => divergence_2D_t(expected_divergence_initializer, mold=vector_2D)) + test_diagnosis = test_diagnosis .also. & + (.all. (div_vector%values() .approximates. expected_divergence%values() .within. tolerance)) & + // string_t(" for order ") // string_t(order) + end associate + end associate + end associate + end do + end function + +end module vector_2D_test_m \ No newline at end of file diff --git a/test/vector_3D_test_m.F90 b/test/vector_3D_test_m.F90 new file mode 100644 index 0000000..231925a --- /dev/null +++ b/test/vector_3D_test_m.F90 @@ -0,0 +1,129 @@ +! Copyright (c) 2026, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +module vector_3D_test_m + use julienne_m, only : & + operator(//) & + ,operator(.all.) & + ,operator(.also.) & + ,operator(.approximates.) & + ,operator(.within.) & + ,operator(.withinPercentage.) & + ,passing_test & + ,string_t & + ,test_description_t & + ,test_diagnosis_t & + ,test_result_t & + ,test_t & + ,usher + use formal_m, only : & + vector_3D_t & + ,vector_3D_initializer_i & + ,divergence_3D_t & + ,divergence_3D_initializer_i + + implicit none + + type, extends(test_t) :: vector_3D_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + + integer, parameter :: space_dimension = 3 + double precision, parameter :: tolerance = 1D-2 + +contains + + pure function subject() result(test_subject) + character(len=:), allocatable :: test_subject + test_subject = 'The vector_3D_t derived type' + end function + + function results() result(test_results) + type(vector_3D_test_t) vector_3D_test + type(test_result_t), allocatable :: test_results(:) + + test_results = vector_3D_test%run([ & + test_description_t('computing the divergence of a vector field', usher(check_divergence)) & + ]) + end function + + pure function biquadratic(x,y,z) result(vector_field) + double precision, intent(in) :: x(:), y(:), z(:) + double precision vector_field(size(x),size(y),size(z),space_dimension) + do concurrent(integer :: i=1:size(x), j=1:size(y), k=1:size(z)) default(none) shared(x,y,z,vector_field) + vector_field(i,j,k,:) = [ & + 1 - 2*x(i) + 3*x(i)**2 - x(i)*y(j)/5 + 3*y(j)**2 - 2*y(j) & + ,1 - 2*x(i) + 3*x(i)**2 - x(i)*y(j)/5 + 3*y(j)**2 - 2*y(j) & + ,z(k) & + ] + end do + end function + + pure function biquadratic_divergence(x,y,z) result(divergence) + double precision, intent(in) :: x(:), y(:), z(:) + double precision divergence(size(x),size(y),size(z)) + do concurrent(integer :: i=1:size(x), j=1:size(y), k=1:size(z)) default(none) shared(x,y,z,divergence) + divergence(i,j,k) = & + (-2 + 6*x(i) - y(j)/5) & ! du/dx + + (-2 + 6*y(j) - x(i)/5) & ! dv/dy + + (1D0) ! dw/dz + end do + end function + + pure function cubic(x,y,z) result(vector_field) + double precision, intent(in) :: x(:), y(:), z(:) + double precision vector_field(size(x),size(y),size(z),space_dimension) + do concurrent(integer :: i=1:size(x), j=1:size(y), k=1:size(z)) default(none) shared(x,y,z,vector_field) + vector_field(i,j,k,:) = [ & + 1 - 2*x(i) + 3*x(i)**3 - x(i)*y(j)/5 + 3*y(j)**3 - 2*y(j) & + ,1 - 2*x(i) + 3*x(i)**3 - x(i)*y(j)/5 + 3*y(j)**3 - 2*y(j) & + ,-z(k) & + ] + end do + end function + + pure function cubic_divergence(x,y,z) result(divergence) + double precision, intent(in) :: x(:), y(:), z(:) + double precision divergence(size(x),size(y),size(z)) + do concurrent(integer :: i=1:size(x), j=1:size(y), k=1:size(z)) default(none) shared(x,y,z,divergence) + divergence(i,j,k) = & + (-2 + 9*x(i)**2 - y(j)/5) & ! du/dx + + (-2 + 9*y(j)**2 - x(i)/5) & ! dv/dx + + (-1D0) ! dw/dz + end do + end function + + function check_divergence() result(test_diagnosis) + type(test_diagnosis_t) test_diagnosis + procedure(vector_3D_initializer_i), pointer :: vector_3D_initializer + procedure(divergence_3D_initializer_i), pointer :: expected_divergence_initializer + integer order + + test_diagnosis = passing_test() + + do order = 2, 4, 2 + select case(order) + case(2) + vector_3D_initializer => biquadratic + expected_divergence_initializer => biquadratic_divergence + case(4) + vector_3D_initializer => cubic + expected_divergence_initializer => cubic_divergence + case default + error stop "check_divergence(vector_3D_test_m): unsupported order" + end select + associate(vector_3D => vector_3D_t(vector_3D_initializer, order=order, cells=[40,20,30], x_min=[0D0,-.5D0,0D0], x_max=[2D0,0D0,3D0])) + associate(div_vector => .div. vector_3D) + associate(expected_divergence => divergence_3D_t(expected_divergence_initializer, mold=vector_3D)) + test_diagnosis = test_diagnosis .also. & + (.all. (div_vector%values() .approximates. expected_divergence%values() .within. tolerance)) & + // string_t(" for order ") // string_t(order) + end associate + end associate + end associate + end do + end function + +end module vector_3D_test_m \ No newline at end of file