From 2691e5927c03fff4e74bcfe3bc1d95719b63ac64 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 27 Dec 2019 16:06:16 -0500 Subject: [PATCH 01/15] (*)Set answers_2018 in calls to solve_linear_system Use the same value of ANSWERS_2018 in solve_linear_solver as in the rest of the edge_values or edge_slopes code. This will change answers slightly when REMAPPING_2018_ANSWERS is false, but the answers in the MOM6-examples test cases are bitwise identical. --- src/ALE/regrid_edge_slopes.F90 | 14 +++++++------- src/ALE/regrid_edge_values.F90 | 32 ++++++++++++++++---------------- 2 files changed, 23 insertions(+), 23 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 9a34267e79..7b5d8bfe54 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -172,7 +172,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(i) = u(i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) ! Set the first edge slope tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) @@ -213,7 +213,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(i) = u(N+1-i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) ! Set the last edge slope tri_b(N+1) = Csys(2) @@ -410,7 +410,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -523,7 +523,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, -h1, h1_2/2.0, -h1_3/6.0, h1_4/24.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -562,7 +562,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 enddo - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) @@ -672,7 +672,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, h2, h2_2/2.0, h2_3/6.0, h2_4/24.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -708,7 +708,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(i) = u(N-6+i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 479fd5c99f..f43168ee4b 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -328,7 +328,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) B(i) = u(i) * dx enddo - call solve_linear_system( A, B, C, 4 ) + call solve_linear_system( A, B, C, 4, .false. ) ! Set the edge values of the first cell edge_val(1,1) = C(1) ! x(1) = 0 so ignore + x(1)*(C(2) + x(1)*(C(3) + x(1)*C(4))) @@ -374,7 +374,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) B(i) = u(N+1-i) * dx enddo - call solve_linear_system( A, B, C, 4 ) + call solve_linear_system( A, B, C, 4, .false. ) ! Set the last and second to last edge values edge_val(N,2) = C(1) @@ -425,7 +425,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real :: h_min ! A minimal cell width [H] real :: h_sum ! A sum of adjacent thicknesses [H] real :: h0_2, h1_2, h0h1 - real :: d2, d4 + real :: h0ph1_2, h0ph1_4 real :: alpha, beta ! stencil coefficients [nondim] real :: I_h2, abmix ! stencil coefficients [nondim] real :: a, b @@ -463,17 +463,17 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) endif ! Auxiliary calculations - d2 = (h0 + h1) ** 2 - d4 = d2 ** 2 + h0ph1_2 = (h0 + h1)**2 + h0ph1_4 = h0ph1_2**2 h0h1 = h0 * h1 h0_2 = h0 * h0 h1_2 = h1 * h1 ! Coefficients - alpha = h1_2 / d2 - beta = h0_2 / d2 - a = 2.0 * h1_2 * ( h1_2 + 2.0 * h0_2 + 3.0 * h0h1 ) / d4 - b = 2.0 * h0_2 * ( h0_2 + 2.0 * h1_2 + 3.0 * h0h1 ) / d4 + alpha = h1_2 / h0ph1_2 + beta = h0_2 / h0ph1_2 + a = 2.0 * h1_2 * ( h1_2 + 2.0 * h0_2 + 3.0 * h0h1 ) / h0ph1_4 + b = 2.0 * h0_2 * ( h0_2 + 2.0 * h1_2 + 3.0 * h0h1 ) / h0ph1_4 tri_d(i+1) = 1.0 else ! Use expressions with less sensitivity to roundoff @@ -530,7 +530,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(i) = u(i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) tri_b(1) = Csys(1) ! Set the first edge value, using the fact that x(1) = 0. tri_c(1) = 1.0 @@ -572,7 +572,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(i) = u(N+1-i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4 ) + call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) ! Set the last edge value tri_b(N+1) = Csys(1) @@ -778,7 +778,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -901,7 +901,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, h1, -0.5*h1_2, h1_3/6.0, -h1_4/24.0, h1_5/120.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -940,7 +940,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) enddo - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) tri_l(1) = 0.0 tri_d(1) = 1.0 @@ -1054,7 +1054,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, -h2, -0.5*h2_2, -h2_3/6.0, -h2_4/24.0, -h2_5/120.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) alpha = Csys(1) beta = Csys(2) @@ -1093,7 +1093,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) enddo - call solve_linear_system( Asys, Bsys, Csys, 6 ) + call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) tri_l(N+1) = 0.0 tri_d(N+1) = 1.0 From 2a59632d401287094c29a9495ebd4c4b7e6a7997 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 2 Jan 2020 07:25:53 -0500 Subject: [PATCH 02/15] +Added subroutine linear_solver to regrid_solvers Added the new subroutine linear_solver to regrid_solvers. This new subroutine differs from solve_linear_system in that it only uses the newer expressions and it reverses the order of indicies in the matrix being solved to use stride-1 in memory. This new routine is being used with the newer algorithms in several edge_values and edge_slopes routines. All answers are bitwise identical. --- src/ALE/regrid_edge_slopes.F90 | 23 +++++------ src/ALE/regrid_edge_values.F90 | 43 +++++++++++---------- src/ALE/regrid_solvers.F90 | 70 ++++++++++++++++++++++++++++++++-- 3 files changed, 100 insertions(+), 36 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 7b5d8bfe54..02fa00f7fc 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -4,7 +4,8 @@ module regrid_edge_slopes ! This file is part of MOM6. See LICENSE.md for the license. -use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system, solve_diag_dominant_tridiag +use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system +use regrid_solvers, only : solve_diag_dominant_tridiag, linear_solver use polynomial_functions, only : evaluation_polynomial implicit none ; private @@ -165,14 +166,14 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(1,i) = dx + Asys(2,i) = dx * xavg + Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) + Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) Bsys(i) = u(i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) + call linear_solver( 4, Asys, Bsys, Csys ) ! Set the first edge slope tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) @@ -205,15 +206,15 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(N+1-i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(1,i) = dx + Asys(2,i) = dx * xavg + Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) + Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) Bsys(i) = u(N+1-i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) + call linear_solver( 4, Asys, Bsys, Csys ) ! Set the last edge slope tri_b(N+1) = Csys(2) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index f43168ee4b..78706ce4c4 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -3,7 +3,8 @@ module regrid_edge_values ! This file is part of MOM6. See LICENSE.md for the license. -use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system, solve_diag_dominant_tridiag +use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system +use regrid_solvers, only : solve_diag_dominant_tridiag, linear_solver use polynomial_functions, only : evaluation_polynomial implicit none ; private @@ -321,14 +322,14 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = 0.5 * (x(i+1) + x(i)) - A(i,1) = dx - A(i,2) = dx * xavg - A(i,3) = dx * (xavg**2 + C1_12*dx**2) - A(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + A(1,i) = dx + A(2,i) = dx * xavg + A(3,i) = dx * (xavg**2 + C1_12*dx**2) + A(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) B(i) = u(i) * dx enddo - call solve_linear_system( A, B, C, 4, .false. ) + call linear_solver( 4, A, B, C ) ! Set the edge values of the first cell edge_val(1,1) = C(1) ! x(1) = 0 so ignore + x(1)*(C(2) + x(1)*(C(3) + x(1)*C(4))) @@ -366,15 +367,15 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - A(i,1) = dx - A(i,2) = dx * xavg - A(i,3) = dx * (xavg**2 + C1_12*dx**2) - A(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + A(1,i) = dx + A(2,i) = dx * xavg + A(3,i) = dx * (xavg**2 + C1_12*dx**2) + A(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) B(i) = u(N+1-i) * dx enddo - call solve_linear_system( A, B, C, 4, .false. ) + call linear_solver( 4, A, B, C ) ! Set the last and second to last edge values edge_val(N,2) = C(1) @@ -523,14 +524,14 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(1,i) = dx + Asys(2,i) = dx * xavg + Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) + Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) Bsys(i) = u(i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) + call linear_solver( 4, Asys, Bsys, Csys ) tri_b(1) = Csys(1) ! Set the first edge value, using the fact that x(1) = 0. tri_c(1) = 1.0 @@ -564,15 +565,15 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) + Asys(1,i) = dx + Asys(2,i) = dx * xavg + Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) + Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) Bsys(i) = u(N+1-i) * dx enddo - call solve_linear_system( Asys, Bsys, Csys, 4, .false. ) + call linear_solver( 4, Asys, Bsys, Csys ) ! Set the last edge value tri_b(N+1) = Csys(1) diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index 3f8923b585..82b23832f4 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -7,7 +7,7 @@ module regrid_solvers implicit none ; private -public :: solve_linear_system, solve_tridiagonal_system, solve_diag_dominant_tridiag +public :: solve_linear_system, linear_solver, solve_tridiagonal_system, solve_diag_dominant_tridiag contains @@ -15,16 +15,16 @@ module regrid_solvers !! !! This routine uses Gauss's algorithm to transform the system's original !! matrix into an upper triangular matrix. Back substitution yields the answer. -!! The matrix A must be square and its size must be that of the vectors R and X. +!! The matrix A must be square, with the first index varing down the column. subroutine solve_linear_system( A, R, X, N, answers_2018 ) integer, intent(in) :: N !< The size of the system real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] real, dimension(N), intent(inout) :: R !< system right-hand side [A] real, dimension(N), intent(inout) :: X !< solution vector [A] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + logical, optional, intent(in) :: answers_2018 !< If true or absent use older, less efficient expressions. ! Local variables real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed - real :: factor ! The factor that eliminates the leading nonzero element in a row. + real :: factor ! The factor that eliminates the leading nonzero element in a row. real :: pivot, I_pivot ! The pivot value and its reciprocal [nondim] real :: swap_a, swap_b logical :: found_pivot ! If true, a pivot has been found @@ -103,6 +103,68 @@ subroutine solve_linear_system( A, R, X, N, answers_2018 ) end subroutine solve_linear_system +!> Solve the linear system AX = R by Gaussian elimination +!! +!! This routine uses Gauss's algorithm to transform the system's original +!! matrix into an upper triangular matrix. Back substitution then yields the answer. +!! The matrix A must be square, with the first index varing along the row. +subroutine linear_solver( N, A, R, X ) + integer, intent(in) :: N !< The size of the system + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] + real, dimension(N), intent(inout) :: R !< system right-hand side [A] + real, dimension(N), intent(inout) :: X !< solution vector [A] + + ! Local variables + real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed + real :: factor ! The factor that eliminates the leading nonzero element in a row. + real :: I_pivot ! The reciprocal of the pivot value [inverse of the input units of a row of A] + real :: swap + logical :: found_pivot ! If true, a pivot has been found + integer :: i, j, k + + ! Loop on rows to transform the problem into multiplication by an upper-right matrix. + do i=1,N-1 + ! Seek a pivot for column i starting in row i, and continuing into the remaining rows. If the + ! pivot is in a row other than i, swap them. If no valid pivot is found, i = N+1 after this loop. + do k=i,N ; if ( abs( A(i,k) ) > eps ) exit ; enddo ! end loop to find pivot + if ( k > N ) then ! No pivot could be found and the system is singular. + write(0,*) ' A=',A + call MOM_error( FATAL, 'The linear system is singular !' ) + endif + + ! If the pivot is in a row that is different than row i, swap those two rows, noting that both + ! rows start with i-1 zero values. + if ( k /= i ) then + do j=i,N ; swap = A(j,i) ; A(j,i) = A(j,k) ; A(j,k) = swap ; enddo + swap = R(i) ; R(i) = R(k) ; R(k) = swap + endif + + ! Transform the pivot to 1 by dividing the entire row (right-hand side included) by the pivot + I_pivot = 1.0 / A(i,i) + A(i,i) = 1.0 + do j=i+1,N ; A(j,i) = A(j,i) * I_pivot ; enddo + R(i) = R(i) * I_pivot + + ! Put zeros in column for all rows below that contain the pivot (which is row i) + do k=i+1,N ! k is the row index + factor = A(i,k) + ! A(i,k) = 0.0 ! These elements are not used again, so this line can be skipped for speed. + do j=i+1,N ; A(j,k) = A(j,k) - factor * A(j,i) ; enddo + R(k) = R(k) - factor * R(i) + enddo + + enddo ! end loop on i + + ! Solve the system by back substituting into what is now an upper-right matrix. + X(N) = R(N) / A(N,N) ! The last row is now trivially solved. + do i=N-1,1,-1 ! loop on rows, starting from second to last row + X(i) = R(i) + do j=i+1,N ; X(i) = X(i) - A(j,i) * X(j) ; enddo + enddo + +end subroutine linear_solver + + !> Solve the tridiagonal system AX = R !! !! This routine uses Thomas's algorithm to solve the tridiagonal system AX = R. From e92490adf279f6426d5ace959d28b25a1e21ab2c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 5 Jan 2020 23:08:13 -0500 Subject: [PATCH 03/15] (*)Simplified edge-value linear systems Simplified matricies in one-sided edge-value calculations in the edge_slopes_implicit and edge_values_implicit schemes, dividing out common factors of dx when REMAPPING_2018_ANSWERS is false. Although all of these calculations are mathematically identical, the differences amount to multiplying then dividing by a common factor, which does change answers at roundoff when REMAPPING_2018_ANSWERS is false. Also simplified expressions and used clearer variable names in edge_values_implicit_h6 in ways that are bitwise identical, although using this option fails (as before) in many cases. All answers in the MOM6-examples test cases are bitwise identical by default. --- src/ALE/regrid_edge_slopes.F90 | 62 +++---- src/ALE/regrid_edge_values.F90 | 315 ++++++++++++++++----------------- 2 files changed, 178 insertions(+), 199 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 02fa00f7fc..3e31feb030 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -166,11 +166,11 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(1,i) = dx - Asys(2,i) = dx * xavg - Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) - Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - Bsys(i) = u(i) * dx + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Bsys(i) = u(i) enddo call linear_solver( 4, Asys, Bsys, Csys ) @@ -206,12 +206,11 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(N+1-i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(1,i) = dx - Asys(2,i) = dx * xavg - Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) - Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - - Bsys(i) = u(N+1-i) * dx + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Bsys(i) = u(N+1-i) enddo call linear_solver( 4, Asys, Bsys, Csys ) @@ -540,26 +539,23 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Boundary conditions: left boundary x(1) = 0.0 - do i = 2,7 - x(i) = x(i-1) + h(i-1) - enddo - do i = 1,6 - dx = h(i) + x(i+1) = x(i) + dx if (use_2018_answers) then do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(i) * dx else ! Use expressions with less sensitivity to roundoff xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(i) endif - Bsys(i) = u(i) * dx enddo @@ -689,24 +685,22 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Boundary conditions: right boundary x(1) = 0.0 - do i = 2,7 - x(i) = x(i-1) + h(N-7+i) - enddo - do i = 1,6 dx = h(N-6+i) + x(i+1) = x(i) + dx if (use_2018_answers) then do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(N-6+i) * dx else ! Use expressions with less sensitivity to roundoff xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(N-6+i) endif - Bsys(i) = u(N-6+i) * dx enddo call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 78706ce4c4..fd99b5aff6 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -322,11 +322,11 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = 0.5 * (x(i+1) + x(i)) - A(1,i) = dx - A(2,i) = dx * xavg - A(3,i) = dx * (xavg**2 + C1_12*dx**2) - A(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - B(i) = u(i) * dx + A(1,i) = 1.0 + A(2,i) = xavg + A(3,i) = (xavg**2 + C1_12*dx**2) + A(4,i) = xavg * (xavg**2 + 0.25*dx**2) + B(i) = u(i) enddo call linear_solver( 4, A, B, C ) @@ -359,20 +359,16 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! system that sets the origin at the last interface in the domain. h_min = hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - x(1) = 0.0 - do i=1,4 dx = max(h_min, h(N+1-i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - - A(1,i) = dx - A(2,i) = dx * xavg - A(3,i) = dx * (xavg**2 + C1_12*dx**2) - A(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - - B(i) = u(N+1-i) * dx + A(1,i) = 1.0 + A(2,i) = xavg + A(3,i) = (xavg**2 + C1_12*dx**2) + A(4,i) = xavg * (xavg**2 + 0.25*dx**2) + B(i) = u(N+1-i) enddo call linear_solver( 4, A, B, C ) @@ -524,11 +520,11 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(1,i) = dx - Asys(2,i) = dx * xavg - Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) - Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - Bsys(i) = u(i) * dx + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Bsys(i) = u(i) enddo call linear_solver( 4, Asys, Bsys, Csys ) @@ -564,13 +560,11 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) dx = max(h_min, h(N+1-i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - - Asys(1,i) = dx - Asys(2,i) = dx * xavg - Asys(3,i) = dx * (xavg**2 + C1_12*dx**2) - Asys(4,i) = dx * xavg * (xavg**2 + 0.25*dx**2) - - Bsys(i) = u(N+1-i) * dx + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Bsys(i) = u(N+1-i) enddo call linear_solver( 4, Asys, Bsys, Csys ) @@ -644,8 +638,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Local variables integer :: i, j, k ! loop indexes real :: h0, h1, h2, h3 ! cell widths [H] - real :: g, g_2, g_3 ! the following are - real :: g_4, g_5, g_6 ! auxiliary variables + real :: hMin ! The minimum thickness used in these calculations [H] + real :: h01, h01_2, h01_3, h01_4, h01_5, h01_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h23, h23_2, h23_3, h23_4, h23_5, h23_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: d2, d3, d4, d5, d6 ! to set up the systems real :: n2, n3, n4, n5, n6 ! used to compute the real :: h1_2, h2_2 ! the coefficients of the @@ -658,6 +653,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) real :: h2ph3, h2ph3_2 ! ... real :: h2ph3_3, h2ph3_4 ! ... real :: h0ph1_5, h2ph3_5 ! ... + real :: I_h1ph2 ! The inverse of the sum of two layers' thicknesses [H] real :: alpha, beta ! stencil coefficients real :: a, b, c, d ! " real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] @@ -678,6 +674,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect ! Loop on cells (except last one) + ! Loop on interior cells do k = 2,N-2 ! Cell widths @@ -688,11 +685,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMinFrac*g, h0 ) - h1 = max( hMinFrac*g, h1 ) - h2 = max( hMinFrac*g, h2 ) - h3 = max( hMinFrac*g, h3 ) + hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) + h0 = max( hMin, h0 ) + h1 = max( hMin, h1 ) + h2 = max( hMin, h2 ) + h3 = max( hMin, h3 ) endif ! Auxiliary calculations @@ -708,31 +705,31 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2_5 = h2_3 * h2_2 h2_6 = h2_3 * h2_3 - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - d2 = ( h1_2 - g_2 ) / h0 - d3 = ( h1_3 - g_3 ) / h0 - d4 = ( h1_4 - g_4 ) / h0 - d5 = ( h1_5 - g_5 ) / h0 - d6 = ( h1_6 - g_6 ) / h0 - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / h3 - n3 = ( g_3 - h2_3 ) / h3 - n4 = ( g_4 - h2_4 ) / h3 - n5 = ( g_5 - h2_5 ) / h3 - n6 = ( g_6 - h2_6 ) / h3 + h01 = h0 + h1 + h01_2 = h01 * h01 + h01_3 = h01 * h01_2 + h01_4 = h01_2 * h01_2 + h01_5 = h01_4 * h01 + h01_6 = h01_3 * h01_3 + + d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) + d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) + d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + + h23 = h2 + h3 + h23_2 = h23 * h23 + h23_3 = h23 * h23_2 + h23_4 = h23_2 * h23_2 + h23_5 = h23_4 * h23 + h23_6 = h23_3 * h23_3 + + n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 + n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) + n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) + n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) + n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) ! Compute matrix entries Asys(1,1) = 1.0 @@ -744,35 +741,35 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(2,1) = - h1 Asys(2,2) = h2 - Asys(2,3) = -0.5 * d2 + Asys(2,3) = 0.5 * d2 Asys(2,4) = 0.5 * h1 Asys(2,5) = -0.5 * h2 Asys(2,6) = -0.5 * n2 Asys(3,1) = 0.5 * h1_2 Asys(3,2) = 0.5 * h2_2 - Asys(3,3) = d3 / 6.0 + Asys(3,3) = -d3 / 6.0 Asys(3,4) = - h1_2 / 6.0 Asys(3,5) = - h2_2 / 6.0 Asys(3,6) = - n3 / 6.0 Asys(4,1) = - h1_3 / 6.0 Asys(4,2) = h2_3 / 6.0 - Asys(4,3) = - d4 / 24.0 + Asys(4,3) = d4 / 24.0 Asys(4,4) = h1_3 / 24.0 Asys(4,5) = - h2_3 / 24.0 Asys(4,6) = - n4 / 24.0 Asys(5,1) = h1_4 / 24.0 Asys(5,2) = h2_4 / 24.0 - Asys(5,3) = d5 / 120.0 + Asys(5,3) = -d5 / 120.0 Asys(5,4) = - h1_4 / 120.0 Asys(5,5) = - h2_4 / 120.0 Asys(5,6) = - n5 / 120.0 Asys(6,1) = - h1_5 / 120.0 Asys(6,2) = h2_5 / 120.0 - Asys(6,3) = - d6 / 720.0 + Asys(6,3) = d6 / 720.0 Asys(6,4) = h1_5 / 720.0 Asys(6,5) = - h2_5 / 720.0 Asys(6,6) = - n6 / 720.0 @@ -805,11 +802,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMinFrac*g, h0 ) - h1 = max( hMinFrac*g, h1 ) - h2 = max( hMinFrac*g, h2 ) - h3 = max( hMinFrac*g, h3 ) + hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) + h0 = max( hMin, h0 ) + h1 = max( hMin, h1 ) + h2 = max( hMin, h2 ) + h3 = max( hMin, h3 ) endif ! Auxiliary calculations @@ -825,12 +822,27 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2_5 = h2_3 * h2_2 h2_6 = h2_3 * h2_3 - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 + h01 = h0 + h1 ; h01_2 = h01 * h01 ; h01_3 = h01 * h01_2 + h01_4 = h01_2 * h01_2 ; h01_5 = h01_4 * h01 ; h01_6 = h01_3 * h01_3 + + d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) + d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) + d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + + h23 = h2 + h3 + h23_2 = h23 * h23 + h23_3 = h23 * h23_2 + h23_4 = h23_2 * h23_2 + h23_5 = h23_4 * h23 + h23_6 = h23_3 * h23_3 + + n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 + n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) + n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) + n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) + n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) h0ph1 = h0 + h1 h0ph1_2 = h0ph1 * h0ph1 @@ -838,25 +850,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h0ph1_4 = h0ph1_2 * h0ph1_2 h0ph1_5 = h0ph1_3 * h0ph1_2 - d2 = ( h1_2 - g_2 ) / h0 - d3 = ( h1_3 - g_3 ) / h0 - d4 = ( h1_4 - g_4 ) / h0 - d5 = ( h1_5 - g_5 ) / h0 - d6 = ( h1_6 - g_6 ) / h0 - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / h3 - n3 = ( g_3 - h2_3 ) / h3 - n4 = ( g_4 - h2_4 ) / h3 - n5 = ( g_5 - h2_5 ) / h3 - n6 = ( g_6 - h2_6 ) / h3 - ! Compute matrix entries Asys(1,1) = 1.0 Asys(1,2) = 1.0 @@ -867,35 +860,35 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(2,1) = - h0ph1 Asys(2,2) = 0.0 - Asys(2,3) = -0.5 * d2 + Asys(2,3) = 0.5 * d2 Asys(2,4) = 0.5 * h1 Asys(2,5) = -0.5 * h2 Asys(2,6) = -0.5 * n2 Asys(3,1) = 0.5 * h0ph1_2 Asys(3,2) = 0.0 - Asys(3,3) = d3 / 6.0 + Asys(3,3) = -d3 / 6.0 Asys(3,4) = - h1_2 / 6.0 Asys(3,5) = - h2_2 / 6.0 Asys(3,6) = - n3 / 6.0 Asys(4,1) = - h0ph1_3 / 6.0 Asys(4,2) = 0.0 - Asys(4,3) = - d4 / 24.0 + Asys(4,3) = d4 / 24.0 Asys(4,4) = h1_3 / 24.0 Asys(4,5) = - h2_3 / 24.0 Asys(4,6) = - n4 / 24.0 Asys(5,1) = h0ph1_4 / 24.0 Asys(5,2) = 0.0 - Asys(5,3) = d5 / 120.0 + Asys(5,3) = -d5 / 120.0 Asys(5,4) = - h1_4 / 120.0 Asys(5,5) = - h2_4 / 120.0 Asys(5,6) = - n5 / 120.0 Asys(6,1) = - h0ph1_5 / 120.0 Asys(6,2) = 0.0 - Asys(6,3) = - d6 / 720.0 + Asys(6,3) = d6 / 720.0 Asys(6,4) = h1_5 / 720.0 Asys(6,5) = - h2_5 / 720.0 Asys(6,6) = - n6 / 720.0 @@ -906,38 +899,32 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(2) = alpha tri_d(2) = 1.0 tri_u(2) = beta - tri_b(2) = a * u(1) + b * u(2) + c * u(3) + d * u(4) + tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) ! Boundary conditions: left boundary -! h_sum = (h(1) + h(2)) + (h(5) + h(6)) + (h(3) + h(4)) - g = max( hNeglect, hMinFrac*sum(h(1:6)) ) +! h_min = hMinFrac * ((h(1) + h(2)) + (h(5) + h(6)) + (h(3) + h(4))) + hMin = max( hNeglect, hMinFrac*sum(h(1:6)) ) x(1) = 0.0 - do i = 2,7 - x(i) = x(i-1) + max( g, h(i-1) ) - enddo - do i = 1,6 - dx = max( g, h(i) ) + dx = max( hMin, h(i) ) + x(i+1) = x(i) + dx if (use_2018_answers) then do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(i) * dx else ! Use expressions with less sensitivity to roundoff xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(i) endif - Bsys(i) = u(i) * dx enddo @@ -958,11 +945,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Avoid singularities when h0=0 or h3=0 if (h0*h3==0.) then - g = max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMinFrac*g, h0 ) - h1 = max( hMinFrac*g, h1 ) - h2 = max( hMinFrac*g, h2 ) - h3 = max( hMinFrac*g, h3 ) + hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) + h0 = max( hMin, h0 ) + h1 = max( hMin, h1 ) + h2 = max( hMin, h2 ) + h3 = max( hMin, h3 ) endif ! Auxiliary calculations @@ -978,12 +965,31 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2_5 = h2_3 * h2_2 h2_6 = h2_3 * h2_3 - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 + h01 = h0 + h1 + h01_2 = h01 * h01 + h01_3 = h01 * h01_2 + h01_4 = h01_2 * h01_2 + h01_5 = h01_4 * h01 + h01_6 = h01_3 * h01_3 + + d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) + d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) + d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + + h23 = h2 + h3 + h23_2 = h23 * h23 + h23_3 = h23 * h23_2 + h23_4 = h23_2 * h23_2 + h23_5 = h23_4 * h23 + h23_6 = h23_3 * h23_3 + + n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 + n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) + n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) + n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) + n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) h2ph3 = h2 + h3 h2ph3_2 = h2ph3 * h2ph3 @@ -991,25 +997,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2ph3_4 = h2ph3_2 * h2ph3_2 h2ph3_5 = h2ph3_3 * h2ph3_2 - d2 = ( h1_2 - g_2 ) / h0 - d3 = ( h1_3 - g_3 ) / h0 - d4 = ( h1_4 - g_4 ) / h0 - d5 = ( h1_5 - g_5 ) / h0 - d6 = ( h1_6 - g_6 ) / h0 - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / h3 - n3 = ( g_3 - h2_3 ) / h3 - n4 = ( g_4 - h2_4 ) / h3 - n5 = ( g_5 - h2_5 ) / h3 - n6 = ( g_6 - h2_6 ) / h3 - ! Compute matrix entries Asys(1,1) = 1.0 Asys(1,2) = 1.0 @@ -1020,35 +1007,35 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(2,1) = 0.0 Asys(2,2) = h2ph3 - Asys(2,3) = -0.5 * d2 + Asys(2,3) = 0.5 * d2 Asys(2,4) = 0.5 * h1 Asys(2,5) = -0.5 * h2 Asys(2,6) = -0.5 * n2 Asys(3,1) = 0.0 Asys(3,2) = 0.5 * h2ph3_2 - Asys(3,3) = d3 / 6.0 + Asys(3,3) = -d3 / 6.0 Asys(3,4) = - h1_2 / 6.0 Asys(3,5) = - h2_2 / 6.0 Asys(3,6) = - n3 / 6.0 Asys(4,1) = 0.0 Asys(4,2) = h2ph3_3 / 6.0 - Asys(4,3) = - d4 / 24.0 + Asys(4,3) = d4 / 24.0 Asys(4,4) = h1_3 / 24.0 Asys(4,5) = - h2_3 / 24.0 Asys(4,6) = - n4 / 24.0 Asys(5,1) = 0.0 Asys(5,2) = h2ph3_4 / 24.0 - Asys(5,3) = d5 / 120.0 + Asys(5,3) = - d5 / 120.0 Asys(5,4) = - h1_4 / 120.0 Asys(5,5) = - h2_4 / 120.0 Asys(5,6) = - n5 / 120.0 Asys(6,1) = 0.0 Asys(6,2) = h2ph3_5 / 120.0 - Asys(6,3) = - d6 / 720.0 + Asys(6,3) = d6 / 720.0 Asys(6,4) = h1_5 / 720.0 Asys(6,5) = - h2_5 / 720.0 Asys(6,6) = - n6 / 720.0 @@ -1071,26 +1058,24 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Boundary conditions: right boundary ! h_sum = (h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) - g = max( hNeglect, hMinFrac*sum(h(N-5:N)) ) + hMin = max( hNeglect, hMinFrac*sum(h(N-5:N)) ) x(1) = 0.0 - do i = 2,7 - x(i) = x(i-1) + max( g, h(N-7+i) ) - enddo - do i = 1,6 - dx = max( g, h(N-6+i) ) + dx = max( hMin, h(N-6+i) ) + x(i+1) = x(i) + dx if (use_2018_answers) then do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(N-6+i) * dx else ! Use expressions with less sensitivity to roundoff xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = dx - Asys(i,2) = dx * xavg - Asys(i,3) = dx * (xavg**2 + C1_12*dx**2) - Asys(i,4) = dx * xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = dx * (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = dx * xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(N-6+i) endif - Bsys(i) = u(N-6+i) * dx enddo From 6dbecaac707e10bce015b3489ecf2083aaf82fd2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Jan 2020 15:20:39 -0500 Subject: [PATCH 04/15] (*)Added explicit boundary edge value estimates Use explicit expressions for the 4th order boundary edge value estimates when REMAPPING_2018_ANSWERS is false. These new expressions will never encounter zero pivots inside of linear equation solvers. These are mathematically equivalent to the previous expressions, but because they use only sign-definite expressions and extensive algebraic manipulation, answers can change, especially for very different layer thicknessees near the edges. By default all answers are bitwise identical. --- src/ALE/regrid_edge_values.F90 | 223 +++++++++++++++++++++++++-------- 1 file changed, 173 insertions(+), 50 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index fd99b5aff6..c2e9f5f04d 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -3,6 +3,7 @@ module regrid_edge_values ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_error_handler, only : MOM_error, FATAL use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system use regrid_solvers, only : solve_diag_dominant_tridiag, linear_solver use polynomial_functions, only : evaluation_polynomial @@ -237,6 +238,8 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real :: f1, f2, f3 ! auxiliary variables with various units real :: et1, et2, et3 ! terms the expresson for edge values [A H] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real, parameter :: C1_12 = 1.0 / 12.0 real :: dx, xavg ! Differences and averages of successive values of x [same units as h] real, dimension(4,4) :: A ! values near the boundaries @@ -317,23 +320,16 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) else ! Use expressions with less sensitivity to roundoff h_min = hMinFrac*((h(1) + h(2)) + (h(3) + h(4))) if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(i) ) - x(i+1) = x(i) + dx - xavg = 0.5 * (x(i+1) + x(i)) - A(1,i) = 1.0 - A(2,i) = xavg - A(3,i) = (xavg**2 + C1_12*dx**2) - A(4,i) = xavg * (xavg**2 + 0.25*dx**2) - B(i) = u(i) - enddo - call linear_solver( 4, A, B, C ) + do i=1,4 + dz(i) = max(h_min, h(i) ) + u_tmp(i) = u(i) + enddo + call end_value_h4(dz, u_tmp, C) ! Set the edge values of the first cell - edge_val(1,1) = C(1) ! x(1) = 0 so ignore + x(1)*(C(2) + x(1)*(C(3) + x(1)*C(4))) - edge_val(1,2) = C(1) + x(2)*(C(2) + x(2)*(C(3) + x(2)*C(4))) + edge_val(1,1) = C(1) + edge_val(1,2) = C(1) + dz(1)*(C(2) + dz(1)*(C(3) + dz(1)*C(4))) endif edge_val(2,1) = edge_val(1,2) @@ -359,23 +355,15 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! system that sets the origin at the last interface in the domain. h_min = hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - x(1) = 0.0 do i=1,4 - dx = max(h_min, h(N+1-i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - A(1,i) = 1.0 - A(2,i) = xavg - A(3,i) = (xavg**2 + C1_12*dx**2) - A(4,i) = xavg * (xavg**2 + 0.25*dx**2) - B(i) = u(N+1-i) + dz(i) = max(h_min, h(N+1-i) ) + u_tmp(i) = u(N+1-i) enddo - - call linear_solver( 4, A, B, C ) + call end_value_h4(dz, u_tmp, C) ! Set the last and second to last edge values edge_val(N,2) = C(1) - edge_val(N,1) = C(1) + x(2)*(C(2) + x(2)*(C(3) + x(2)*C(4))) + edge_val(N,1) = C(1) + dz(1)*(C(2) + dz(1)*(C(3) + dz(1)*C(4))) endif edge_val(N-1,2) = edge_val(N,1) @@ -418,7 +406,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! Local variables integer :: i, j ! loop indexes - real :: h0, h1 ! cell widths [H] + real :: h0, h1, h2 ! cell widths [H] real :: h_min ! A minimal cell width [H] real :: h_sum ! A sum of adjacent thicknesses [H] real :: h0_2, h1_2, h0h1 @@ -428,9 +416,14 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real :: a, b real, dimension(5) :: x ! Coordinate system with 0 at edges [H] real, parameter :: C1_12 = 1.0 / 12.0 + real, parameter :: C1_3 = 1.0 / 3.0 + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! boundary conditions real, dimension(4) :: Bsys, Csys + real, dimension(4,4) :: Asys_orig ! boundary conditions + real, dimension(4) :: Bsys_orig real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] tri_d, & ! tridiagonal system (middle diagonal) [nondim] tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u @@ -515,21 +508,14 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Bsys(i) = u(i) + do i=1,4 + dz(i) = max(h_min, h(i) ) + u_tmp(i) = u(i) enddo + call end_value_h4(dz, u_tmp, Csys) - call linear_solver( 4, Asys, Bsys, Csys ) + tri_b(1) = Csys(1) ! Set the first edge value. - tri_b(1) = Csys(1) ! Set the first edge value, using the fact that x(1) = 0. tri_c(1) = 1.0 endif tri_u(1) = 0.0 ! tri_l(1) = 0.0 @@ -555,19 +541,12 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) - x(1) = 0.0 do i=1,4 - dx = max(h_min, h(N+1-i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Bsys(i) = u(N+1-i) + dz(i) = max(h_min, h(N+1-i) ) + u_tmp(i) = u(N+1-i) enddo - call linear_solver( 4, Asys, Bsys, Csys ) + call end_value_h4(dz, u_tmp, Csys) ! Set the last edge value tri_b(N+1) = Csys(1) @@ -591,6 +570,118 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_implicit_h4 +!> Determine a one-sided 4th order polynomial fit of u to the data points for the purposes of specifying +!! edge values, as described in the appendix of White and Adcroft JCP 2008. +subroutine end_value_h4(dz, u, Csys) + real, dimension(4), intent(in) :: dz !< The thicknesses of 4 layers, starting at the edge [H]. + !! The values of dz must be positive. + real, dimension(4), intent(in) :: u !< The average properties of 4 layers, starting at the edge [A] + real, dimension(4), intent(out) :: Csys !< The four coefficients of a 4th order polynomial fit + !! of u as a function of z [A H-(n-1)] + + ! Local variables + real :: Wt(3,4) ! The weights of successive u differences in the 4 closed form expressions. + ! The units of Wt vary with the second index as [H-(n-1)]. + real :: h1, h2, h3, h4 ! Copies of the layer thicknesses [H] + real :: h12, h23, h34 ! Sums of two successive thicknesses [H] + real :: h123, h234 ! Sums of three successive thicknesses [H] + real :: h1234 ! Sums of all four thicknesses [H] + ! real :: I_h1 ! The inverse of the a thickness [H-1] + real :: I_h12, I_h23, I_h34 ! The inverses of sums of two thicknesses [H-1] + real :: I_h123, I_h234 ! The inverse of the sum of three thicknesses [H-1] + real :: I_h1234 ! The inverse of the sum of all four thicknesses [H-1] + real :: I_denom ! The inverse of the denominator some expressions [H-3] + real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] + real, parameter :: C1_3 = 1.0 / 3.0 + integer :: i, j, k + + ! These are only used for code verification + real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. + real :: zavg, u_mag, c_mag + character(len=128) :: mesg + real, parameter :: C1_12 = 1.0 / 12.0 + + ! if ((dz(1) == dz(2)) .and. (dz(1) == dz(3)) .and. (dz(1) == dz(4))) then + ! ! There are simple closed-form expressions in this case + ! I_h1 = 0.0 ; if (dz(1) > 0.0) I_h1 = 1.0 / dz(1) + ! Csys(1) = u(1) + (-13.0 * (u(2)-u(1)) + 10.0 * (u(3)-u(2)) - 3.0 * (u(4)-u(3))) * (0.25*C1_3) + ! Csys(2) = (35.0 * (u(2)-u(1)) - 34.0 * (u(3)-u(2)) + 11.0 * (u(4)-u(3))) * (0.25*C1_3 * I_h1) + ! Csys(3) = (-5.0 * (u(2)-u(1)) + 8.0 * (u(3)-u(2)) - 3.0 * (u(4)-u(3))) * (0.25 * I_h1**2) + ! Csys(4) = ((u(2)-u(1)) - 2.0 * (u(3)-u(2)) + (u(4)-u(3))) * (0.5*C1_3) + ! else + + ! Express the coefficients as sums of the differences between properties of succesive layers. + + h1 = dz(1) ; h2 = dz(2) ; h3 = dz(3) ; h4 = dz(4) + h12 = h1+h2 ; h23 = h2+h3 ; h34 = h3+h4 + h123 = h12 + h3 ; h234 = h2 + h34 ; h1234 = h12 + h34 + ! Find 3 reciprocals with a single division for efficiency. + I_denB3 = 1.0 / (h123 * h12 * h23) + I_h12 = (h123 * h23) * I_denB3 + I_h23 = (h12 * h123) * I_denB3 + I_h123 = (h12 * h23) * I_denB3 + I_denom = 1.0 / ( h1234 * (h234 * h34) ) + I_h34 = (h1234 * h234) * I_denom + I_h234 = (h1234 * h34) * I_denom + I_h1234 = (h234 * h34) * I_denom + + ! Calculation coefficients in the four equations + + ! The expressions for Csys(3) and Csys(4) come from reducing the 4x4 matrix problem into the following 2x2 + ! matrix problem, then manipulating the analytic solution to avoid any subtraction and simplifying. + ! (C1_3 * h123 * h23) * Csys(3) + (0.25 * h123 * h23 * (h3 + 2.0*h2 + 3.0*h1)) * Csys(4) = + ! (u(3)-u(1)) - (u(2)-u(1)) * (h12 + h23) * I_h12 + ! (C1_3 * ((h23 + h34) * h1234 + h23 * h3)) * Csys(3) + + ! (0.25 * ((h1234 + h123 + h12 + h1) * h23 * h3 + (h1234 + h12 + h1) * (h23 + h34) * h1234)) * Csys(4) = + ! (u(4)-u(1)) - (u(2)-u(1)) * (h123 + h234) * I_h12 + ! The final expressions for Csys(1) and Csys(2) were derived by algebraically manipulating the following expressions: + ! Csys(1) = (C1_3 * h1 * h12 * Csys(3) + 0.25 * h1 * h12 * (2.0*h1+h2) * Csys(4)) - & + ! (h1*I_h12)*(u(2)-u(1)) + u(1) + ! Csys(2) = (-2.0*C1_3 * (2.0*h1+h2) * Csys(3) - 0.5 * (h1**2 + h12 * (2.0*h1+h2)) * Csys(4)) + & + ! 2.0*I_h12 * (u(2)-u(1)) + ! These expressions are typically evaluated at x=0 and x=h1, so it is important that these are well behaved + ! for these values, suggesting that h1/h23 and h1/h34 should not be allowed to be too large. + + Wt(1,1) = -h1 * (I_h1234 + I_h123 + I_h12) ! > -3 + Wt(2,1) = h1 * h12 * ( I_h234 * I_h1234 + I_h23 * (I_h234 + I_h123) ) ! < (h1/h234) + (h1/h23)*(2+(h1/h234)) + Wt(3,1) = -h1 * h12 * h123 * I_denom ! > -(h1/h34)*(1+(h1/h234)) + + Wt(1,2) = 2.0 * (I_h12*(1.0 + (h1+h12) * (I_h1234 + I_h123)) + h1 * I_h1234*I_h123) ! < 10/h12 + Wt(2,2) = -2.0 * ((h1 * h12 * I_h1234) * (I_h23 * (I_h234 + I_h123)) + & ! > -(10+6*(h1/h234))/h23 + (h1+h12) * ( I_h1234*I_h234 + I_h23 * (I_h234 + I_h123) ) ) + Wt(3,2) = 2.0 * ((h1+h12) * h123 + h1*h12 ) * I_denom ! < (2+(6*h1/h234)) / h34 + + Wt(1,3) = -3.0 * I_h12 * I_h123* ( 1.0 + I_h1234 * ((h1+h12)+h123) ) ! > -12 / (h12*h123) + Wt(2,3) = 3.0 * I_h23 * ( I_h123 + I_h1234 * ((h1+h12)+h123) * (I_h123 + I_h234) ) ! < 12 / (h23^2) + Wt(3,3) = -3.0 * ((h1+h12)+h123) * I_denom ! > -9 / (h234*h23) + + Wt(1,4) = 4.0 * I_h1234 * I_h123 * I_h12 ! Wt*h1^3 < 4 + Wt(2,4) = -4.0 * I_h1234 * (I_h23 * (I_h123 + I_h234)) ! Wt*h1^3 > -4* (h1/h23)*(1+h1/h234) + Wt(3,4) = 4.0 * I_denom ! = 4.0*I_h1234 * I_h234 * I_h34 ! Wt*h1^3 < 4 * (h1/h234)*(h1/h34) + + Csys(1) = ((u(1) + Wt(1,1) * (u(2)-u(1))) + Wt(2,1) * (u(3)-u(2))) + Wt(3,1) * (u(4)-u(3)) + Csys(2) = (Wt(1,2) * (u(2)-u(1)) + Wt(2,2) * (u(3)-u(2))) + Wt(3,2) * (u(4)-u(3)) + Csys(3) = (Wt(1,3) * (u(2)-u(1)) + Wt(2,3) * (u(3)-u(2))) + Wt(3,3) * (u(4)-u(3)) + Csys(4) = (Wt(1,4) * (u(2)-u(1)) + Wt(2,4) * (u(3)-u(2))) + Wt(3,4) * (u(4)-u(3)) + + ! endif ! End of non-uniform layer thickness branch. + + ! To verify that these answers are correct, uncomment the following: +! u_mag = 0.0 ; do i=1,4 ; u_mag = max(u_mag, abs(u(i))) ; enddo +! do i = 1,4 +! if (i==1) then ; zavg = 0.5*dz(i) ; else ; zavg = zavg + 0.5*(dz(i-1)+dz(i)) ; endif +! Atest(1) = 1.0 +! Atest(2) = zavg ! = ( (z(i+1)**2) - (z(i)**2) ) / (2*dz(i)) +! Atest(3) = (zavg**2 + 0.25*C1_3*dz(i)**2) ! = ( (z(i+1)**3) - (z(i)**3) ) / (3*dz(i)) +! Atest(4) = zavg * (zavg**2 + 0.25*dz(i)**2) ! = ( (z(i+1)**4) - (z(i)**4) ) / (4*dz(i)) +! c_mag = 1.0 ; do k=0,3 ; do j=1,3 ; c_mag = c_mag + abs(Wt(j,k+1) * zavg**k) ; enddo ; enddo +! write(mesg, '("end_value_h4 line ", i2, " c_mag = ", es10.2, " u_mag = ", es10.2)') i, c_mag, u_mag +! call test_line(mesg, 4, Atest, Csys, u(i), u_mag*c_mag, tolerance=1.0e-15) +! enddo + +end subroutine end_value_h4 + + !> Compute ih6 edge values (implicit sixth order accurate) !! in the same units as h. !! @@ -653,7 +744,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) real :: h2ph3, h2ph3_2 ! ... real :: h2ph3_3, h2ph3_4 ! ... real :: h0ph1_5, h2ph3_5 ! ... - real :: I_h1ph2 ! The inverse of the sum of two layers' thicknesses [H] real :: alpha, beta ! stencil coefficients real :: a, b, c, d ! " real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] @@ -1098,4 +1188,37 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_implicit_h6 + +! Verify that A*C = R to within roundoff. +subroutine test_line(msg, N, A, C, R, mag, tolerance) + integer, intent(in) :: N + real, dimension(4), intent(in) :: A + real, dimension(4), intent(in) :: C + real, intent(in) :: R + real, intent(in) :: mag !< The magnitude of leading order terms in this line + real, optional, intent(in) :: tolerance + character(len=*) :: msg + + real :: sum, sum_mag + real :: tol + character(len=128) :: mesg2 + integer :: i + + tol = 1.0e-12 ; if (present(tolerance)) tol = tolerance + + sum = 0.0 ; sum_mag = max(0.0,mag) + + do i=1,N + sum = sum + A(i) * C(i) + sum_mag = sum_mag + abs(A(i) * C(i)) + enddo + + if (abs(sum - R) > tol * (sum_mag + abs(R))) then + write(mesg2, '(", Fractional error = ", es12.4,", sum = ", es12.4)') (sum - R) / (sum_mag + abs(R)), sum + call MOM_error(FATAL, "Failed line test: "//trim(msg)//trim(mesg2)) + endif + +end subroutine test_line + + end module regrid_edge_values From 0a987cf34bfd89455ae2aff37bca5f7b3d901db0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Jan 2020 17:30:09 -0500 Subject: [PATCH 05/15] (*)Got a test working with edge_slopes_implicit_h5 Added relative thickness limits within edge_values_implicit_h6 and edge_slopes_implicit_h5 that enable them to run without crashing for the z and rho versions of flow_downslope testcase with REMAPPING_SCHEME = "PQM_IH6IH5". Also hard-coded the calls from these routines to solve_linear_solver to use updated versions of the solver. Because these routines had never been useful before, this does not change answers in any of the test cases. --- src/ALE/regrid_edge_slopes.F90 | 153 +++++++++++++++------------------ src/ALE/regrid_edge_values.F90 | 137 ++++++++++------------------- 2 files changed, 113 insertions(+), 177 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 3e31feb030..5bfb5b287a 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -282,8 +282,8 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! ----------------------------------------------------------------------------- ! Local variables - integer :: i, j, k ! loop indexes - real :: h0, h1, h2, h3 ! cell widths + real :: h0, h1, h2, h3 ! cell widths [H] + real :: hMin ! The minimum thickness used in these calculations [H] real :: g, g_2, g_3 ! the following are real :: g_4, g_5, g_6 ! auxiliary variables real :: d2, d3, d4, d5, d6 ! to set up the systems @@ -311,20 +311,18 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) - real :: hNeglect ! A negligible thickness in the same units as h. - logical :: use_2018_answers ! If true use older, less acccurate expressions. + real :: h_Min_Frac = 1.0e-4 + real :: hNeglect ! A negligible thickness in the same units as h. + integer :: i, j, k ! loop indexes hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 ! Loop on cells (except the first and last ones) do k = 2,N-2 - - ! Cell widths - h0 = h(k-1) - h1 = h(k+0) - h2 = h(k+1) - h3 = h(k+2) + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) + h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -346,11 +344,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 g_5 = g_4 * g g_6 = g_3 * g_3 - d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) + d2 = ( h1_2 - g_2 ) / ( h0 ) + d3 = ( h1_3 - g_3 ) / ( h0 ) + d4 = ( h1_4 - g_4 ) / ( h0 ) + d5 = ( h1_5 - g_5 ) / ( h0 ) + d6 = ( h1_6 - g_6 ) / ( h0 ) g = h2 + h3 g_2 = g * g @@ -359,11 +357,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) + n2 = ( g_2 - h2_2 ) / ( h3 ) + n3 = ( g_3 - h2_3 ) / ( h3 ) + n4 = ( g_4 - h2_4 ) / ( h3 ) + n5 = ( g_5 - h2_5 ) / ( h3 ) + n6 = ( g_6 - h2_6 ) / ( h3 ) ! Compute matrix entries Asys(1,1) = 0.0 @@ -410,7 +408,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -428,11 +426,10 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Use a right-biased stencil for the second row - ! Cell widths - h0 = h(1) - h1 = h(2) - h2 = h(3) - h3 = h(4) + ! Store temporary cell widths, avoiding singularities from zero thic2nesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) + h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) + h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -459,11 +456,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h0ph1_3 = h0ph1_2 * h0ph1 h0ph1_4 = h0ph1_2 * h0ph1_2 - d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) + d2 = ( h1_2 - g_2 ) / ( h0 ) + d3 = ( h1_3 - g_3 ) / ( h0 ) + d4 = ( h1_4 - g_4 ) / ( h0 ) + d5 = ( h1_5 - g_5 ) / ( h0 ) + d6 = ( h1_6 - g_6 ) / ( h0 ) g = h2 + h3 g_2 = g * g @@ -472,11 +469,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) + n2 = ( g_2 - h2_2 ) / ( h3 ) + n3 = ( g_3 - h2_3 ) / ( h3 ) + n4 = ( g_4 - h2_4 ) / ( h3 ) + n5 = ( g_5 - h2_5 ) / ( h3 ) + n6 = ( g_6 - h2_6 ) / ( h3 ) ! Compute matrix entries Asys(1,1) = 0.0 @@ -523,7 +520,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, -h1, h1_2/2.0, -h1_3/6.0, h1_4/24.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -541,25 +538,18 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 x(1) = 0.0 do i = 1,6 dx = h(i) + xavg = x(i) + 0.5 * dx + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(i) x(i+1) = x(i) + dx - if (use_2018_answers) then - do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(i) * dx - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) - Bsys(i) = u(i) - endif - - enddo - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) @@ -573,12 +563,10 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_b(1) = evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value ! Use a left-biased stencil for the second to last row - - ! Cell widths - h0 = h(N-3) - h1 = h(N-2) - h2 = h(N-1) - h3 = h(N) + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) + h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -605,11 +593,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h2ph3_3 = h2ph3_2 * h2ph3 h2ph3_4 = h2ph3_2 * h2ph3_2 - d2 = ( h1_2 - g_2 ) / ( h0 + hNeglect ) - d3 = ( h1_3 - g_3 ) / ( h0 + hNeglect ) - d4 = ( h1_4 - g_4 ) / ( h0 + hNeglect ) - d5 = ( h1_5 - g_5 ) / ( h0 + hNeglect ) - d6 = ( h1_6 - g_6 ) / ( h0 + hNeglect ) + d2 = ( h1_2 - g_2 ) / ( h0 ) + d3 = ( h1_3 - g_3 ) / ( h0 ) + d4 = ( h1_4 - g_4 ) / ( h0 ) + d5 = ( h1_5 - g_5 ) / ( h0 ) + d6 = ( h1_6 - g_6 ) / ( h0 ) g = h2 + h3 g_2 = g * g @@ -618,11 +606,11 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 g_5 = g_4 * g g_6 = g_3 * g_3 - n2 = ( g_2 - h2_2 ) / ( h3 + hNeglect ) - n3 = ( g_3 - h2_3 ) / ( h3 + hNeglect ) - n4 = ( g_4 - h2_4 ) / ( h3 + hNeglect ) - n5 = ( g_5 - h2_5 ) / ( h3 + hNeglect ) - n6 = ( g_6 - h2_6 ) / ( h3 + hNeglect ) + n2 = ( g_2 - h2_2 ) / ( h3 ) + n3 = ( g_3 - h2_3 ) / ( h3 ) + n4 = ( g_4 - h2_4 ) / ( h3 ) + n5 = ( g_5 - h2_5 ) / ( h3 ) + n6 = ( g_6 - h2_6 ) / ( h3 ) ! Compute matrix entries Asys(1,1) = 0.0 @@ -669,7 +657,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Bsys(:) = (/ 0.0, -1.0, h2, h2_2/2.0, h2_3/6.0, h2_4/24.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -687,23 +675,18 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 x(1) = 0.0 do i = 1,6 dx = h(N-6+i) + xavg = x(i) + 0.5*dx + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx - if (use_2018_answers) then - do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(N-6+i) * dx - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) - Bsys(i) = u(N-6+i) - endif enddo - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index c2e9f5f04d..6912ae5bb0 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -703,8 +703,9 @@ end subroutine end_value_h4 !! i-1/2 i+1/2 i+3/2 !! !! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, a, b, c and d are -!! computed, the tridiagonal system is built, boundary conditions are -!! prescribed and the system is solved to yield edge-value estimates. +!! computed, the tridiagonal system is built, boundary conditions are prescribed and +!! the system is solved to yield edge-value estimates. This scheme is described in detail +!! by White and Adcroft, 2009, J. Comp. Phys, https://doi.org/10.1016/j.jcp.2008.04.026 !! !! Note that the centered stencil only applies to edges 3 to N-1 (edges are !! numbered 1 to n+1), which yields N-3 equations for N+1 unknowns. Two other @@ -727,11 +728,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables - integer :: i, j, k ! loop indexes - real :: h0, h1, h2, h3 ! cell widths [H] - real :: hMin ! The minimum thickness used in these calculations [H] + real :: h0, h1, h2, h3 ! cell widths [H] + real :: hMin ! The minimum thickness used in these calculations [H] real :: h01, h01_2, h01_3, h01_4, h01_5, h01_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: h23, h23_2, h23_3, h23_4, h23_5, h23_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: hNeglect ! A negligible thickness [H]. real :: d2, d3, d4, d5, d6 ! to set up the systems real :: n2, n3, n4, n5, n6 ! used to compute the real :: h1_2, h2_2 ! the coefficients of the @@ -757,30 +758,16 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) - real :: hNeglect ! A negligible thickness [H]. - logical :: use_2018_answers ! If true use older, less acccurate expressions. + integer :: i, j, k ! loop indexes - use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect - ! Loop on cells (except last one) ! Loop on interior cells do k = 2,N-2 - - ! Cell widths - h0 = h(k-1) - h1 = h(k+0) - h2 = h(k+1) - h3 = h(k+2) - - ! Avoid singularities when h0=0 or h3=0 - if (h0*h3==0.) then - hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMin, h0 ) - h1 = max( hMin, h1 ) - h2 = max( hMin, h2 ) - h3 = max( hMin, h3 ) - endif + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, hMinFrac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) + h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -821,7 +808,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - ! Compute matrix entries + ! Compute matrix entries as described in Eq. (48) of White and Adcroft (2009) Asys(1,1) = 1.0 Asys(1,2) = 1.0 Asys(1,3) = -1.0 @@ -866,7 +853,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -882,22 +869,12 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) enddo ! end loop on cells - ! Use a right-biased stencil for the second row - - ! Cell widths - h0 = h(1) - h1 = h(2) - h2 = h(3) - h3 = h(4) - - ! Avoid singularities when h0=0 or h3=0 - if (h0*h3==0.) then - hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMin, h0 ) - h1 = max( hMin, h1 ) - h2 = max( hMin, h2 ) - h3 = max( hMin, h3 ) - endif + ! Use a right-biased stencil for the second row, as described in Eq. (49) of White and Adcroft (2009). + + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, hMinFrac*((h(1) + h(2)) + (h(3) + h(4)))) + h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) + h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -985,7 +962,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, h1, -0.5*h1_2, h1_3/6.0, -h1_4/24.0, h1_5/120.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -996,29 +973,22 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) ! Boundary conditions: left boundary -! h_min = hMinFrac * ((h(1) + h(2)) + (h(5) + h(6)) + (h(3) + h(4))) - hMin = max( hNeglect, hMinFrac*sum(h(1:6)) ) + hMin = max( hNeglect, hMinFrac*((h(1)+h(2)) + (h(5)+h(6)) + (h(3)+h(4))) ) x(1) = 0.0 do i = 1,6 dx = max( hMin, h(i) ) + xavg = x(i) + 0.5*dx + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(i) x(i+1) = x(i) + dx - if (use_2018_answers) then - do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(i) * dx - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) - Bsys(i) = u(i) - endif - enddo - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) tri_l(1) = 0.0 tri_d(1) = 1.0 @@ -1027,20 +997,10 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Use a left-biased stencil for the second to last row - ! Cell widths - h0 = h(N-3) - h1 = h(N-2) - h2 = h(N-1) - h3 = h(N) - - ! Avoid singularities when h0=0 or h3=0 - if (h0*h3==0.) then - hMin = hMinFrac * max( hNeglect, h0+h1+h2+h3 ) - h0 = max( hMin, h0 ) - h1 = max( hMin, h1 ) - h2 = max( hMin, h2 ) - h3 = max( hMin, h3 ) - endif + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, hMinFrac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) + h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) ! Auxiliary calculations h1_2 = h1 * h1 @@ -1132,7 +1092,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Bsys(:) = (/ -1.0, -h2, -0.5*h2_2, -h2_3/6.0, -h2_4/24.0, -h2_5/120.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) @@ -1147,29 +1107,22 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_b(N) = a * u(N-3) + b * u(N-2) + c * u(N-1) + d * u(N) ! Boundary conditions: right boundary -! h_sum = (h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) - hMin = max( hNeglect, hMinFrac*sum(h(N-5:N)) ) + hMin = max( hNeglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) x(1) = 0.0 do i = 1,6 dx = max( hMin, h(N-6+i) ) + xavg = x(i) + 0.5 * dx + Asys(i,1) = 1.0 + Asys(i,2) = xavg + Asys(i,3) = (xavg**2 + C1_12*dx**2) + Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) + Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx - if (use_2018_answers) then - do j = 1,6 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(N-6+i) * dx - else ! Use expressions with less sensitivity to roundoff - xavg = 0.5 * (x(i+1) + x(i)) - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) - Bsys(i) = u(N-6+i) - endif - enddo - call solve_linear_system( Asys, Bsys, Csys, 6, use_2018_answers ) + call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) tri_l(N+1) = 0.0 tri_d(N+1) = 1.0 From b6281836b032cf077418a583627c5ca65eec4efa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Jan 2020 19:32:32 -0500 Subject: [PATCH 06/15] (*)Improved algorithms in edge_slopes_implicit_h5 Replaced the n2 and d2 variables in edge_values_implicit_h6 and edge_slopes_implicit_h5 with mathematically equivalent forms that avoid any subtractions and hence are much less prone to roundoff. Also multiplied matricies by constants in edge_values_implicit_h6 and edge_slopes_implicit_h5 to avoid division and make these expressions more consistent with what is documented in White and Adcroft (2009). Also renamed some variables for greater clarity. Expressions are mathematically identical but do change at roundoff. --- src/ALE/regrid_edge_slopes.F90 | 353 +++++++++++---------------------- src/ALE/regrid_edge_values.F90 | 337 ++++++++++--------------------- 2 files changed, 219 insertions(+), 471 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 5bfb5b287a..6021d19fc5 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -284,21 +284,14 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Local variables real :: h0, h1, h2, h3 ! cell widths [H] real :: hMin ! The minimum thickness used in these calculations [H] - real :: g, g_2, g_3 ! the following are - real :: g_4, g_5, g_6 ! auxiliary variables - real :: d2, d3, d4, d5, d6 ! to set up the systems - real :: n2, n3, n4, n5, n6 ! used to compute the + real :: h01, h01_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h23, h23_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: hNeglect ! A negligible thickness [H]. real :: h1_2, h2_2 ! the coefficients of the real :: h1_3, h2_3 ! tridiagonal system real :: h1_4, h2_4 ! ... real :: h1_5, h2_5 ! ... - real :: h1_6, h2_6 ! ... - real :: h0ph1, h0ph1_2 ! ... - real :: h0ph1_3, h0ph1_4 ! ... - real :: h2ph3, h2ph3_2 ! ... - real :: h2ph3_3, h2ph3_4 ! ... real :: alpha, beta ! stencil coefficients - real :: a, b, c, d ! " real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] real, parameter :: C1_12 = 1.0 / 12.0 real, parameter :: C5_6 = 5.0 / 6.0 @@ -312,7 +305,6 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) real :: h_Min_Frac = 1.0e-4 - real :: hNeglect ! A negligible thickness in the same units as h. integer :: i, j, k ! loop indexes hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -325,45 +317,10 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - d2 = ( h1_2 - g_2 ) / ( h0 ) - d3 = ( h1_3 - g_3 ) / ( h0 ) - d4 = ( h1_4 - g_4 ) / ( h0 ) - d5 = ( h1_5 - g_5 ) / ( h0 ) - d6 = ( h1_6 - g_6 ) / ( h0 ) - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / ( h3 ) - n3 = ( g_3 - h2_3 ) / ( h3 ) - n4 = ( g_4 - h2_4 ) / ( h3 ) - n5 = ( g_5 - h2_5 ) / ( h3 ) - n6 = ( g_6 - h2_6 ) / ( h3 ) - - ! Compute matrix entries + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009) Asys(1,1) = 0.0 Asys(1,2) = 0.0 Asys(1,3) = 1.0 @@ -371,109 +328,66 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Asys(1,5) = 1.0 Asys(1,6) = 1.0 - Asys(2,1) = 1.0 - Asys(2,2) = 1.0 - Asys(2,3) = -0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 - - Asys(3,1) = h1 - Asys(3,2) = - h2 - Asys(3,3) = - d3 / 6.0 - Asys(3,4) = h1_2 / 6.0 - Asys(3,5) = h2_2 / 6.0 - Asys(3,6) = n3 / 6.0 - - Asys(4,1) = - h1_2 / 2.0 - Asys(4,2) = - h2_2 / 2.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = - h1_3 / 24.0 - Asys(4,5) = h2_3 / 24.0 - Asys(4,6) = n4 / 24.0 - - Asys(5,1) = h1_3 / 6.0 - Asys(5,2) = - h2_3 / 6.0 - Asys(5,3) = - d5 / 120.0 - Asys(5,4) = h1_4 / 120.0 - Asys(5,5) = h2_4 / 120.0 - Asys(5,6) = n5 / 120.0 - - Asys(6,1) = - h1_4 / 24.0 - Asys(6,2) = - h2_4 / 24.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = - h1_5 / 720.0 - Asys(6,5) = h2_5 / 720.0 - Asys(6,6) = n6 / 720.0 - - Bsys(:) = (/ 0.0, -1.0, 0.0, 0.0, 0.0, 0.0 /) + Asys(2,1) = 2.0 + Asys(2,2) = 2.0 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) + + Asys(3,1) = 6.0*h1 + Asys(3,2) = -6.0* h2 + Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) ! = ((h0+h1)**3 - h1**3) / h0 + Asys(3,4) = h1_2 + Asys(3,5) = h2_2 + Asys(3,6) = (3.0*h2_2 + h3*(3.0*h2 + h3)) ! = ((h2+h3)**3 - h2**3) / h3 + + Asys(4,1) = -12.0* h1_2 + Asys(4,2) = -12.0* h2_2 + Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = -((h0+h1)**4 - h1**4) / h0 + Asys(4,4) = - h1_3 + Asys(4,5) = h2_3 + Asys(4,6) = (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = ((h2+h3)**4 - h2**4)/ h3 + + Asys(5,1) = 20.0*h1_3 + Asys(5,2) = -20.0* h2_3 + Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = h1_4 + Asys(5,5) = h2_4 + Asys(5,6) = (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + + Asys(6,1) = -30.0*h1_4 + Asys(6,2) = -30.0*h2_4 + Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = -h1_5 + Asys(6,5) = h2_5 + Asys(6,6) = (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) + + Bsys(:) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(k+1) = alpha tri_d(k+1) = 1.0 tri_u(k+1) = beta - tri_b(k+1) = a * u(k-1) + b * u(k) + c * u(k+1) + d * u(k+2) + tri_b(k+1) = Csys(3) * u(k-1) + Csys(4) * u(k) + Csys(5) * u(k+1) + Csys(6) * u(k+2) enddo ! end loop on cells - ! Use a right-biased stencil for the second row + ! Use a right-biased stencil for the second row, as described in Eq. (53) of White and Adcroft (2009). - ! Store temporary cell widths, avoiding singularities from zero thic2nesses or extreme changes. + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - h0ph1 = h0 + h1 - h0ph1_2 = h0ph1 * h0ph1 - h0ph1_3 = h0ph1_2 * h0ph1 - h0ph1_4 = h0ph1_2 * h0ph1_2 - - d2 = ( h1_2 - g_2 ) / ( h0 ) - d3 = ( h1_3 - g_3 ) / ( h0 ) - d4 = ( h1_4 - g_4 ) / ( h0 ) - d5 = ( h1_5 - g_5 ) / ( h0 ) - d6 = ( h1_6 - g_6 ) / ( h0 ) - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / ( h3 ) - n3 = ( g_3 - h2_3 ) / ( h3 ) - n4 = ( g_4 - h2_4 ) / ( h3 ) - n5 = ( g_5 - h2_5 ) / ( h3 ) - n6 = ( g_6 - h2_6 ) / ( h3 ) + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h01 = h0 + h1 ; h01_2 = h01 * h01 ! Compute matrix entries Asys(1,1) = 0.0 @@ -483,56 +397,52 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Asys(1,5) = 1.0 Asys(1,6) = 1.0 - Asys(2,1) = 1.0 - Asys(2,2) = 1.0 - Asys(2,3) = -0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 + Asys(2,1) = 2.0 + Asys(2,2) = 2.0 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) - Asys(3,1) = h0ph1 + Asys(3,1) = 6.0*h01 Asys(3,2) = 0.0 - Asys(3,3) = - d3 / 6.0 - Asys(3,4) = h1_2 / 6.0 - Asys(3,5) = h2_2 / 6.0 - Asys(3,6) = n3 / 6.0 + Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) + Asys(3,4) = h1_2 + Asys(3,5) = h2_2 + Asys(3,6) = 3.0*h2_2 + h3*(3.0*h2 + h3) - Asys(4,1) = - h0ph1_2 / 2.0 + Asys(4,1) = -12.0*h01_2 Asys(4,2) = 0.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = - h1_3 / 24.0 - Asys(4,5) = h2_3 / 24.0 - Asys(4,6) = n4 / 24.0 + Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(4,4) = -h1_3 + Asys(4,5) = h2_3 + Asys(4,6) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - Asys(5,1) = h0ph1_3 / 6.0 + Asys(5,1) = 20.0*(h01*h01_2) Asys(5,2) = 0.0 - Asys(5,3) = - d5 / 120.0 - Asys(5,4) = h1_4 / 120.0 - Asys(5,5) = h2_4 / 120.0 - Asys(5,6) = n5 / 120.0 + Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = h1_4 + Asys(5,5) = h2_4 + Asys(5,6) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - Asys(6,1) = - h0ph1_4 / 24.0 + Asys(6,1) = -30.0*(h01_2*h01_2) Asys(6,2) = 0.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = - h1_5 / 720.0 - Asys(6,5) = h2_5 / 720.0 - Asys(6,6) = n6 / 720.0 + Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = -h1_5 + Asys(6,5) = h2_5 + Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - Bsys(:) = (/ 0.0, -1.0, -h1, h1_2/2.0, -h1_3/6.0, h1_4/24.0 /) + Bsys(:) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(2) = alpha tri_d(2) = 1.0 tri_u(2) = beta - tri_b(2) = a * u(1) + b * u(2) + c * u(3) + d * u(4) + tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) ! Boundary conditions: left boundary x(1) = 0.0 @@ -562,55 +472,18 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_u(1) = 0.0 tri_b(1) = evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value - ! Use a left-biased stencil for the second to last row + ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - g = h0 + h1 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - h2ph3 = h2 + h3 - h2ph3_2 = h2ph3 * h2ph3 - h2ph3_3 = h2ph3_2 * h2ph3 - h2ph3_4 = h2ph3_2 * h2ph3_2 - - d2 = ( h1_2 - g_2 ) / ( h0 ) - d3 = ( h1_3 - g_3 ) / ( h0 ) - d4 = ( h1_4 - g_4 ) / ( h0 ) - d5 = ( h1_5 - g_5 ) / ( h0 ) - d6 = ( h1_6 - g_6 ) / ( h0 ) - - g = h2 + h3 - g_2 = g * g - g_3 = g * g_2 - g_4 = g_2 * g_2 - g_5 = g_4 * g - g_6 = g_3 * g_3 - - n2 = ( g_2 - h2_2 ) / ( h3 ) - n3 = ( g_3 - h2_3 ) / ( h3 ) - n4 = ( g_4 - h2_4 ) / ( h3 ) - n5 = ( g_5 - h2_5 ) / ( h3 ) - n6 = ( g_6 - h2_6 ) / ( h3 ) + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + h23 = h2 + h3 ; h23_2 = h23 * h23 ! Compute matrix entries Asys(1,1) = 0.0 @@ -620,56 +493,52 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 Asys(1,5) = 1.0 Asys(1,6) = 1.0 - Asys(2,1) = 1.0 - Asys(2,2) = 1.0 - Asys(2,3) = -0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 + Asys(2,1) = 2.0 + Asys(2,2) = 2.0 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) Asys(3,1) = 0.0 - Asys(3,2) = - h2ph3 - Asys(3,3) = - d3 / 6.0 - Asys(3,4) = h1_2 / 6.0 - Asys(3,5) = h2_2 / 6.0 - Asys(3,6) = n3 / 6.0 + Asys(3,2) = -6.0*h23 + Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) + Asys(3,4) = h1_2 + Asys(3,5) = h2_2 + Asys(3,6) = 3.0*h2_2 + h3*(3.0*h2 + h3) Asys(4,1) = 0.0 - Asys(4,2) = - h2ph3_2 / 2.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = - h1_3 / 24.0 - Asys(4,5) = h2_3 / 24.0 - Asys(4,6) = n4 / 24.0 + Asys(4,2) = -12.0*h23_2 + Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(4,4) = -h1_3 + Asys(4,5) = h2_3 + Asys(4,6) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) Asys(5,1) = 0.0 - Asys(5,2) = - h2ph3_3 / 6.0 - Asys(5,3) = - d5 / 120.0 - Asys(5,4) = h1_4 / 120.0 - Asys(5,5) = h2_4 / 120.0 - Asys(5,6) = n5 / 120.0 + Asys(5,2) = -20.0*(h23*h23_2) + Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = h1_4 + Asys(5,5) = h2_4 + Asys(5,6) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) Asys(6,1) = 0.0 - Asys(6,2) = - h2ph3_4 / 24.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = - h1_5 / 720.0 - Asys(6,5) = h2_5 / 720.0 - Asys(6,6) = n6 / 720.0 + Asys(6,2) = -30.0*(h23_2*h23_2) + Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = -h1_5 + Asys(6,5) = h2_5 + Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - Bsys(:) = (/ 0.0, -1.0, h2, h2_2/2.0, h2_3/6.0, h2_4/24.0 /) + Bsys(:) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(N) = alpha tri_d(N) = 1.0 tri_u(N) = beta - tri_b(N) = a * u(N-3) + b * u(N-2) + c * u(N-1) + d * u(N) + tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) ! Boundary conditions: right boundary x(1) = 0.0 diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 6912ae5bb0..76dab697c8 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -730,8 +730,8 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Local variables real :: h0, h1, h2, h3 ! cell widths [H] real :: hMin ! The minimum thickness used in these calculations [H] - real :: h01, h01_2, h01_3, h01_4, h01_5, h01_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] - real :: h23, h23_2, h23_3, h23_4, h23_5, h23_6 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h01, h01_2, h01_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h23, h23_2, h23_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: hNeglect ! A negligible thickness [H]. real :: d2, d3, d4, d5, d6 ! to set up the systems real :: n2, n3, n4, n5, n6 ! used to compute the @@ -739,12 +739,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) real :: h1_3, h2_3 ! tridiagonal system real :: h1_4, h2_4 ! ... real :: h1_5, h2_5 ! ... - real :: h1_6, h2_6 ! ... - real :: h0ph1, h0ph1_2 ! ... - real :: h0ph1_3, h0ph1_4 ! ... - real :: h2ph3, h2ph3_2 ! ... - real :: h2ph3_3, h2ph3_4 ! ... - real :: h0ph1_5, h2ph3_5 ! ... real :: alpha, beta ! stencil coefficients real :: a, b, c, d ! " real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] @@ -770,43 +764,8 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - h01 = h0 + h1 - h01_2 = h01 * h01 - h01_3 = h01 * h01_2 - h01_4 = h01_2 * h01_2 - h01_5 = h01_4 * h01 - h01_6 = h01_3 * h01_3 - - d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) - d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) - d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - - h23 = h2 + h3 - h23_2 = h23 * h23 - h23_3 = h23 * h23_2 - h23_4 = h23_2 * h23_2 - h23_5 = h23_4 * h23 - h23_6 = h23_3 * h23_3 - - n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 - n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) - n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 ! Compute matrix entries as described in Eq. (48) of White and Adcroft (2009) Asys(1,1) = 1.0 @@ -816,40 +775,40 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(1,5) = -1.0 Asys(1,6) = -1.0 - Asys(2,1) = - h1 - Asys(2,2) = h2 - Asys(2,3) = 0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 - - Asys(3,1) = 0.5 * h1_2 - Asys(3,2) = 0.5 * h2_2 - Asys(3,3) = -d3 / 6.0 - Asys(3,4) = - h1_2 / 6.0 - Asys(3,5) = - h2_2 / 6.0 - Asys(3,6) = - n3 / 6.0 - - Asys(4,1) = - h1_3 / 6.0 - Asys(4,2) = h2_3 / 6.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = h1_3 / 24.0 - Asys(4,5) = - h2_3 / 24.0 - Asys(4,6) = - n4 / 24.0 - - Asys(5,1) = h1_4 / 24.0 - Asys(5,2) = h2_4 / 24.0 - Asys(5,3) = -d5 / 120.0 - Asys(5,4) = - h1_4 / 120.0 - Asys(5,5) = - h2_4 / 120.0 - Asys(5,6) = - n5 / 120.0 - - Asys(6,1) = - h1_5 / 120.0 - Asys(6,2) = h2_5 / 120.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = h1_5 / 720.0 - Asys(6,5) = - h2_5 / 720.0 - Asys(6,6) = - n6 / 720.0 + Asys(2,1) = -2.0*h1 + Asys(2,2) = 2.0*h2 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) + + Asys(3,1) = 3.0*h1_2 + Asys(3,2) = 3.0*h2_2 + Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) ! = -((h0+h1)**3 - h1**3) / h0 + Asys(3,4) = - h1_2 + Asys(3,5) = - h2_2 + Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) ! = -((h2+h3)**3 - h2**3) / h3 + + Asys(4,1) = -4.0*h1_3 + Asys(4,2) = 4.0*h2_3 + Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = ((h0+h1)**4 - h1**4) / h0 + Asys(4,4) = h1_3 + Asys(4,5) = - h2_3 + Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = -((h2+h3)**4 - h2**4)/ h3 + + Asys(5,1) = 5.0*h1_4 + Asys(5,2) = 5.0*h2_4 + Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = - h1_4 + Asys(5,5) = - h2_4 + Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + + Asys(6,1) = -6.0*h1_5 + Asys(6,2) = 6.0*h2_5 + Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = h1_5 + Asys(6,5) = - h2_5 + Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) Bsys(:) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) @@ -857,15 +816,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(k+1) = alpha tri_d(k+1) = 1.0 tri_u(k+1) = beta - tri_b(k+1) = a * u(k-1) + b * u(k) + c * u(k+1) + d * u(k+2) + tri_b(k+1) = Csys(3) * u(k-1) + Csys(4) * u(k) + Csys(5) * u(k+1) + Csys(6) * u(k+2) enddo ! end loop on cells @@ -877,45 +832,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - h01 = h0 + h1 ; h01_2 = h01 * h01 ; h01_3 = h01 * h01_2 - h01_4 = h01_2 * h01_2 ; h01_5 = h01_4 * h01 ; h01_6 = h01_3 * h01_3 - - d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) - d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) - d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - - h23 = h2 + h3 - h23_2 = h23 * h23 - h23_3 = h23 * h23_2 - h23_4 = h23_2 * h23_2 - h23_5 = h23_4 * h23 - h23_6 = h23_3 * h23_3 - - n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 - n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) - n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - - h0ph1 = h0 + h1 - h0ph1_2 = h0ph1 * h0ph1 - h0ph1_3 = h0ph1_2 * h0ph1 - h0ph1_4 = h0ph1_2 * h0ph1_2 - h0ph1_5 = h0ph1_3 * h0ph1_2 + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h01 = h0 + h1 ; h01_2 = h01 * h01 ; h01_3 = h01 * h01_2 ! Compute matrix entries Asys(1,1) = 1.0 @@ -925,42 +844,42 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(1,5) = -1.0 Asys(1,6) = -1.0 - Asys(2,1) = - h0ph1 + Asys(2,1) = -2.0* h01 Asys(2,2) = 0.0 - Asys(2,3) = 0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) - Asys(3,1) = 0.5 * h0ph1_2 + Asys(3,1) = 3.0 * h01_2 Asys(3,2) = 0.0 - Asys(3,3) = -d3 / 6.0 - Asys(3,4) = - h1_2 / 6.0 - Asys(3,5) = - h2_2 / 6.0 - Asys(3,6) = - n3 / 6.0 + Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) + Asys(3,4) = - h1_2 + Asys(3,5) = - h2_2 + Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) - Asys(4,1) = - h0ph1_3 / 6.0 + Asys(4,1) = -4.0*h01_3 Asys(4,2) = 0.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = h1_3 / 24.0 - Asys(4,5) = - h2_3 / 24.0 - Asys(4,6) = - n4 / 24.0 + Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(4,4) = h1_3 + Asys(4,5) = - h2_3 + Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) - Asys(5,1) = h0ph1_4 / 24.0 + Asys(5,1) = 5.0*(h01_2*h01_2) Asys(5,2) = 0.0 - Asys(5,3) = -d5 / 120.0 - Asys(5,4) = - h1_4 / 120.0 - Asys(5,5) = - h2_4 / 120.0 - Asys(5,6) = - n5 / 120.0 + Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = - h1_4 + Asys(5,5) = - h2_4 + Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - Asys(6,1) = - h0ph1_5 / 120.0 + Asys(6,1) = -6.0*(h01_3*h01_2) Asys(6,2) = 0.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = h1_5 / 720.0 - Asys(6,5) = - h2_5 / 720.0 - Asys(6,6) = - n6 / 720.0 + Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = h1_5 + Asys(6,5) = - h2_5 + Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) - Bsys(:) = (/ -1.0, h1, -0.5*h1_2, h1_3/6.0, -h1_4/24.0, h1_5/120.0 /) + Bsys(:) = (/ -1.0, 2.0*h1, -3.0*h1_2, 4.0*h1_3, -5.0*h1_4, 6.0*h1_5 /) call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) @@ -995,7 +914,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_u(1) = 0.0 tri_b(1) = evaluation_polynomial( Csys, 6, x(1) ) ! first edge value - ! Use a left-biased stencil for the second to last row + ! Use a left-biased stencil for the second to last row, as described in Eq. (50) of White and Adcroft (2009). ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. hMin = max(hNeglect, hMinFrac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) @@ -1003,49 +922,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) ! Auxiliary calculations - h1_2 = h1 * h1 - h1_3 = h1_2 * h1 - h1_4 = h1_2 * h1_2 - h1_5 = h1_3 * h1_2 - h1_6 = h1_3 * h1_3 - - h2_2 = h2 * h2 - h2_3 = h2_2 * h2 - h2_4 = h2_2 * h2_2 - h2_5 = h2_3 * h2_2 - h2_6 = h2_3 * h2_3 - - h01 = h0 + h1 - h01_2 = h01 * h01 - h01_3 = h01 * h01_2 - h01_4 = h01_2 * h01_2 - h01_5 = h01_4 * h01 - h01_6 = h01_3 * h01_3 - - d2 = ( h01_2 - h1_2 ) / h0 ! = (2.0*h1 + h0) - d3 = ( h01_3 - h1_3 ) / h0 ! = (3.0*h1_2 + h0*(3.0*h1 + h0)) - d4 = ( h01_4 - h1_4 ) / h0 ! = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - d5 = ( h01_5 - h1_5 ) / h0 ! = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - d6 = ( h01_6 - h1_6 ) / h0 ! = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - - h23 = h2 + h3 - h23_2 = h23 * h23 - h23_3 = h23 * h23_2 - h23_4 = h23_2 * h23_2 - h23_5 = h23_4 * h23 - h23_6 = h23_3 * h23_3 - - n2 = ( h23_2 - h2_2 ) / h3 ! = 2.0*h2 + h3 - n3 = ( h23_3 - h2_3 ) / h3 ! = 3.0*h2_2 + h3*(3.0*h2 + h3) - n4 = ( h23_4 - h2_4 ) / h3 ! = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - n5 = ( h23_5 - h2_5 ) / h3 ! = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - n6 = ( h23_6 - h2_6 ) / h3 ! = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - - h2ph3 = h2 + h3 - h2ph3_2 = h2ph3 * h2ph3 - h2ph3_3 = h2ph3_2 * h2ph3 - h2ph3_4 = h2ph3_2 * h2ph3_2 - h2ph3_5 = h2ph3_3 * h2ph3_2 + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h23 = h2 + h3 ; h23_2 = h23 * h23 ; h23_3 = h23 * h23_2 ! Compute matrix entries Asys(1,1) = 1.0 @@ -1055,42 +934,42 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) Asys(1,5) = -1.0 Asys(1,6) = -1.0 - Asys(2,1) = 0.0 - Asys(2,2) = h2ph3 - Asys(2,3) = 0.5 * d2 - Asys(2,4) = 0.5 * h1 - Asys(2,5) = -0.5 * h2 - Asys(2,6) = -0.5 * n2 - - Asys(3,1) = 0.0 - Asys(3,2) = 0.5 * h2ph3_2 - Asys(3,3) = -d3 / 6.0 - Asys(3,4) = - h1_2 / 6.0 - Asys(3,5) = - h2_2 / 6.0 - Asys(3,6) = - n3 / 6.0 - - Asys(4,1) = 0.0 - Asys(4,2) = h2ph3_3 / 6.0 - Asys(4,3) = d4 / 24.0 - Asys(4,4) = h1_3 / 24.0 - Asys(4,5) = - h2_3 / 24.0 - Asys(4,6) = - n4 / 24.0 - - Asys(5,1) = 0.0 - Asys(5,2) = h2ph3_4 / 24.0 - Asys(5,3) = - d5 / 120.0 - Asys(5,4) = - h1_4 / 120.0 - Asys(5,5) = - h2_4 / 120.0 - Asys(5,6) = - n5 / 120.0 - - Asys(6,1) = 0.0 - Asys(6,2) = h2ph3_5 / 120.0 - Asys(6,3) = d6 / 720.0 - Asys(6,4) = h1_5 / 720.0 - Asys(6,5) = - h2_5 / 720.0 - Asys(6,6) = - n6 / 720.0 - - Bsys(:) = (/ -1.0, -h2, -0.5*h2_2, -h2_3/6.0, -h2_4/24.0, -h2_5/120.0 /) + Asys(2,1) = 0.0 + Asys(2,2) = 2.0*h23 + Asys(2,3) = (2.0*h1 + h0) + Asys(2,4) = h1 + Asys(2,5) = -h2 + Asys(2,6) = -(2.0*h2 + h3) + + Asys(3,1) = 0.0 + Asys(3,2) = 3.0*h23_2 + Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) + Asys(3,4) = -h1_2 + Asys(3,5) = -h2_2 + Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) + + Asys(4,1) = 0.0 + Asys(4,2) = 4.0*h23_3 + Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(4,4) = h1_3 + Asys(4,5) = -h2_3 + Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) + + Asys(5,1) = 0.0 + Asys(5,2) = 5.0*(h23_2*h23_2) + Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(5,4) = -h1_4 + Asys(5,5) = -h2_4 + Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + + Asys(6,1) = 0.0 + Asys(6,2) = 6.0*(h23_3*h23_2) + Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(6,4) = h1_5 + Asys(6,5) = -h2_5 + Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) + + Bsys(:) = (/ -1.0, -2.0*h2, -3.0*h2_2, -4.0*h2_3, -5.0*h2_4, -6.0*h2_5 /) call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) From 21c805bdd2d78662748be9165df617974903dec6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jan 2020 06:52:48 -0500 Subject: [PATCH 07/15] Use linear_solver in edge_slopes_implicit_h5 Use linear_solver in place of solve_linear_system in edge_slopes_implicit_h5 and edge_values_implicit_h6, which increases efficiency because the arrays are accessed with a stride of 1 in memory. All answers are bitwise identical. --- src/ALE/regrid_edge_slopes.F90 | 223 +++++++++++++++++---------------- src/ALE/regrid_edge_values.F90 | 214 +++++++++++++++---------------- 2 files changed, 223 insertions(+), 214 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index 6021d19fc5..bade56a46f 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -170,6 +170,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 Asys(2,i) = xavg Asys(3,i) = (xavg**2 + C1_12*dx**2) Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + ! Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) Bsys(i) = u(i) enddo @@ -210,6 +211,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 Asys(2,i) = xavg Asys(3,i) = (xavg**2 + C1_12*dx**2) Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + ! Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) Bsys(i) = u(N+1-i) enddo @@ -321,51 +323,54 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009) + ! Asys(1:6,n) = (/ -n*(n-1)*(-h1)**(n-2), -n*(n-1)*h1**(n-2), (-1)**(n-1) * ((h0+h1)**n - h0**n) / h0, & + ! (-h1)**(n-1), h2**(n-1), ((h2+h3)**n - h2**n) / h3 /) + Asys(1,1) = 0.0 - Asys(1,2) = 0.0 - Asys(1,3) = 1.0 - Asys(1,4) = 1.0 - Asys(1,5) = 1.0 - Asys(1,6) = 1.0 + Asys(2,1) = 0.0 + Asys(3,1) = 1.0 + Asys(4,1) = 1.0 + Asys(5,1) = 1.0 + Asys(6,1) = 1.0 - Asys(2,1) = 2.0 + Asys(1,2) = 2.0 Asys(2,2) = 2.0 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 6.0*h1 - Asys(3,2) = -6.0* h2 + Asys(1,3) = 6.0*h1 + Asys(2,3) = -6.0* h2 Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) ! = ((h0+h1)**3 - h1**3) / h0 - Asys(3,4) = h1_2 - Asys(3,5) = h2_2 - Asys(3,6) = (3.0*h2_2 + h3*(3.0*h2 + h3)) ! = ((h2+h3)**3 - h2**3) / h3 + Asys(4,3) = h1_2 + Asys(5,3) = h2_2 + Asys(6,3) = (3.0*h2_2 + h3*(3.0*h2 + h3)) ! = ((h2+h3)**3 - h2**3) / h3 - Asys(4,1) = -12.0* h1_2 - Asys(4,2) = -12.0* h2_2 - Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = -((h0+h1)**4 - h1**4) / h0 + Asys(1,4) = -12.0* h1_2 + Asys(2,4) = -12.0* h2_2 + Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = -((h0+h1)**4 - h1**4) / h0 Asys(4,4) = - h1_3 - Asys(4,5) = h2_3 - Asys(4,6) = (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = ((h2+h3)**4 - h2**4)/ h3 + Asys(5,4) = h2_3 + Asys(6,4) = (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = ((h2+h3)**4 - h2**4)/ h3 - Asys(5,1) = 20.0*h1_3 - Asys(5,2) = -20.0* h2_3 - Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = h1_4 + Asys(1,5) = 20.0*h1_3 + Asys(2,5) = -20.0* h2_3 + Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = h1_4 Asys(5,5) = h2_4 - Asys(5,6) = (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + Asys(6,5) = (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - Asys(6,1) = -30.0*h1_4 - Asys(6,2) = -30.0*h2_4 - Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = -h1_5 - Asys(6,5) = h2_5 + Asys(1,6) = -30.0*h1_4 + Asys(2,6) = -30.0*h2_4 + Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = -h1_5 + Asys(5,6) = h2_5 Asys(6,6) = (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) Bsys(:) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -391,50 +396,54 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Compute matrix entries Asys(1,1) = 0.0 - Asys(1,2) = 0.0 - Asys(1,3) = 1.0 - Asys(1,4) = 1.0 - Asys(1,5) = 1.0 - Asys(1,6) = 1.0 + Asys(2,1) = 0.0 + Asys(3,1) = 1.0 + Asys(4,1) = 1.0 + Asys(5,1) = 1.0 + Asys(6,1) = 1.0 - Asys(2,1) = 2.0 + Asys(1,2) = 2.0 Asys(2,2) = 2.0 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 6.0*h01 - Asys(3,2) = 0.0 + Asys(1,3) = 6.0*h01 + Asys(2,3) = 0.0 Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(3,4) = h1_2 - Asys(3,5) = h2_2 - Asys(3,6) = 3.0*h2_2 + h3*(3.0*h2 + h3) + Asys(4,3) = h1_2 + Asys(5,3) = h2_2 + Asys(6,3) = 3.0*h2_2 + h3*(3.0*h2 + h3) + +! Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) +! Asys(1:6,2) = (/ 2.0, 2.0, 2.0*h1 + h0, h1, -h2, -(2.0*h2 + h3) /) +! Asys(1:6,3) = (/ 6.0*h01, 0.0, 3.0*h1_2 + h0*(3.0*h1 + h0), h1_2, h2_2, 3.0*h2_2 + h3*(3.0*h2 + h3) /) - Asys(4,1) = -12.0*h01_2 - Asys(4,2) = 0.0 - Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(1,4) = -12.0*h01_2 + Asys(2,4) = 0.0 + Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) Asys(4,4) = -h1_3 - Asys(4,5) = h2_3 - Asys(4,6) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) + Asys(5,4) = h2_3 + Asys(6,4) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - Asys(5,1) = 20.0*(h01*h01_2) - Asys(5,2) = 0.0 - Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = h1_4 + Asys(1,5) = 20.0*(h01*h01_2) + Asys(2,5) = 0.0 + Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = h1_4 Asys(5,5) = h2_4 - Asys(5,6) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) + Asys(6,5) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - Asys(6,1) = -30.0*(h01_2*h01_2) - Asys(6,2) = 0.0 - Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = -h1_5 - Asys(6,5) = h2_5 + Asys(1,6) = -30.0*(h01_2*h01_2) + Asys(2,6) = 0.0 + Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = -h1_5 + Asys(5,6) = h2_5 Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) Bsys(:) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -449,17 +458,17 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 do i = 1,6 dx = h(i) xavg = x(i) + 0.5 * dx - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) Bsys(i) = u(i) x(i+1) = x(i) + dx enddo - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) @@ -487,50 +496,50 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Compute matrix entries Asys(1,1) = 0.0 - Asys(1,2) = 0.0 - Asys(1,3) = 1.0 - Asys(1,4) = 1.0 - Asys(1,5) = 1.0 - Asys(1,6) = 1.0 + Asys(2,1) = 0.0 + Asys(3,1) = 1.0 + Asys(4,1) = 1.0 + Asys(5,1) = 1.0 + Asys(6,1) = 1.0 - Asys(2,1) = 2.0 + Asys(1,2) = 2.0 Asys(2,2) = 2.0 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 0.0 - Asys(3,2) = -6.0*h23 + Asys(1,3) = 0.0 + Asys(2,3) = -6.0*h23 Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(3,4) = h1_2 - Asys(3,5) = h2_2 - Asys(3,6) = 3.0*h2_2 + h3*(3.0*h2 + h3) + Asys(4,3) = h1_2 + Asys(5,3) = h2_2 + Asys(6,3) = 3.0*h2_2 + h3*(3.0*h2 + h3) - Asys(4,1) = 0.0 - Asys(4,2) = -12.0*h23_2 - Asys(4,3) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(1,4) = 0.0 + Asys(2,4) = -12.0*h23_2 + Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) Asys(4,4) = -h1_3 - Asys(4,5) = h2_3 - Asys(4,6) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) + Asys(5,4) = h2_3 + Asys(6,4) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - Asys(5,1) = 0.0 - Asys(5,2) = -20.0*(h23*h23_2) - Asys(5,3) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = h1_4 + Asys(1,5) = 0.0 + Asys(2,5) = -20.0*(h23*h23_2) + Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = h1_4 Asys(5,5) = h2_4 - Asys(5,6) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) + Asys(6,5) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - Asys(6,1) = 0.0 - Asys(6,2) = -30.0*(h23_2*h23_2) - Asys(6,3) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = -h1_5 - Asys(6,5) = h2_5 + Asys(1,6) = 0.0 + Asys(2,6) = -30.0*(h23_2*h23_2) + Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = -h1_5 + Asys(5,6) = h2_5 Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) Bsys(:) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -545,17 +554,17 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 do i = 1,6 dx = h(N-6+i) xavg = x(i) + 0.5*dx - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx enddo - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) Dsys(1) = Csys(2) Dsys(2) = 2.0 * Csys(3) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 76dab697c8..80752f2d98 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -769,50 +769,50 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Compute matrix entries as described in Eq. (48) of White and Adcroft (2009) Asys(1,1) = 1.0 - Asys(1,2) = 1.0 - Asys(1,3) = -1.0 - Asys(1,4) = -1.0 - Asys(1,5) = -1.0 - Asys(1,6) = -1.0 + Asys(2,1) = 1.0 + Asys(3,1) = -1.0 + Asys(4,1) = -1.0 + Asys(5,1) = -1.0 + Asys(6,1) = -1.0 - Asys(2,1) = -2.0*h1 + Asys(1,2) = -2.0*h1 Asys(2,2) = 2.0*h2 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 3.0*h1_2 - Asys(3,2) = 3.0*h2_2 + Asys(1,3) = 3.0*h1_2 + Asys(2,3) = 3.0*h2_2 Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) ! = -((h0+h1)**3 - h1**3) / h0 - Asys(3,4) = - h1_2 - Asys(3,5) = - h2_2 - Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) ! = -((h2+h3)**3 - h2**3) / h3 + Asys(4,3) = - h1_2 + Asys(5,3) = - h2_2 + Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) ! = -((h2+h3)**3 - h2**3) / h3 - Asys(4,1) = -4.0*h1_3 - Asys(4,2) = 4.0*h2_3 - Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = ((h0+h1)**4 - h1**4) / h0 + Asys(1,4) = -4.0*h1_3 + Asys(2,4) = 4.0*h2_3 + Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = ((h0+h1)**4 - h1**4) / h0 Asys(4,4) = h1_3 - Asys(4,5) = - h2_3 - Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = -((h2+h3)**4 - h2**4)/ h3 + Asys(5,4) = - h2_3 + Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = -((h2+h3)**4 - h2**4)/ h3 - Asys(5,1) = 5.0*h1_4 - Asys(5,2) = 5.0*h2_4 - Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = - h1_4 + Asys(1,5) = 5.0*h1_4 + Asys(2,5) = 5.0*h2_4 + Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = - h1_4 Asys(5,5) = - h2_4 - Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - Asys(6,1) = -6.0*h1_5 - Asys(6,2) = 6.0*h2_5 - Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = h1_5 - Asys(6,5) = - h2_5 + Asys(1,6) = -6.0*h1_5 + Asys(2,6) = 6.0*h2_5 + Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = h1_5 + Asys(5,6) = - h2_5 Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) Bsys(:) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -838,50 +838,50 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Compute matrix entries Asys(1,1) = 1.0 - Asys(1,2) = 1.0 - Asys(1,3) = -1.0 - Asys(1,4) = -1.0 - Asys(1,5) = -1.0 - Asys(1,6) = -1.0 + Asys(2,1) = 1.0 + Asys(3,1) = -1.0 + Asys(4,1) = -1.0 + Asys(5,1) = -1.0 + Asys(6,1) = -1.0 - Asys(2,1) = -2.0* h01 + Asys(1,2) = -2.0* h01 Asys(2,2) = 0.0 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 3.0 * h01_2 - Asys(3,2) = 0.0 + Asys(1,3) = 3.0 * h01_2 + Asys(2,3) = 0.0 Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(3,4) = - h1_2 - Asys(3,5) = - h2_2 - Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) + Asys(4,3) = - h1_2 + Asys(5,3) = - h2_2 + Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) - Asys(4,1) = -4.0*h01_3 - Asys(4,2) = 0.0 - Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(1,4) = -4.0*h01_3 + Asys(2,4) = 0.0 + Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) Asys(4,4) = h1_3 - Asys(4,5) = - h2_3 - Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) + Asys(5,4) = - h2_3 + Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) - Asys(5,1) = 5.0*(h01_2*h01_2) - Asys(5,2) = 0.0 - Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = - h1_4 + Asys(1,5) = 5.0*(h01_2*h01_2) + Asys(2,5) = 0.0 + Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = - h1_4 Asys(5,5) = - h2_4 - Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - Asys(6,1) = -6.0*(h01_3*h01_2) - Asys(6,2) = 0.0 - Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = h1_5 - Asys(6,5) = - h2_5 + Asys(1,6) = -6.0*(h01_3*h01_2) + Asys(2,6) = 0.0 + Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = h1_5 + Asys(5,6) = - h2_5 Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) Bsys(:) = (/ -1.0, 2.0*h1, -3.0*h1_2, 4.0*h1_3, -5.0*h1_4, 6.0*h1_5 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -897,17 +897,17 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) do i = 1,6 dx = max( hMin, h(i) ) xavg = x(i) + 0.5*dx - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) Bsys(i) = u(i) x(i+1) = x(i) + dx enddo - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) tri_l(1) = 0.0 tri_d(1) = 1.0 @@ -928,50 +928,50 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! Compute matrix entries Asys(1,1) = 1.0 - Asys(1,2) = 1.0 - Asys(1,3) = -1.0 - Asys(1,4) = -1.0 - Asys(1,5) = -1.0 - Asys(1,6) = -1.0 + Asys(2,1) = 1.0 + Asys(3,1) = -1.0 + Asys(4,1) = -1.0 + Asys(5,1) = -1.0 + Asys(6,1) = -1.0 - Asys(2,1) = 0.0 + Asys(1,2) = 0.0 Asys(2,2) = 2.0*h23 - Asys(2,3) = (2.0*h1 + h0) - Asys(2,4) = h1 - Asys(2,5) = -h2 - Asys(2,6) = -(2.0*h2 + h3) + Asys(3,2) = (2.0*h1 + h0) + Asys(4,2) = h1 + Asys(5,2) = -h2 + Asys(6,2) = -(2.0*h2 + h3) - Asys(3,1) = 0.0 - Asys(3,2) = 3.0*h23_2 + Asys(1,3) = 0.0 + Asys(2,3) = 3.0*h23_2 Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(3,4) = -h1_2 - Asys(3,5) = -h2_2 - Asys(3,6) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) + Asys(4,3) = -h1_2 + Asys(5,3) = -h2_2 + Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) - Asys(4,1) = 0.0 - Asys(4,2) = 4.0*h23_3 - Asys(4,3) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) + Asys(1,4) = 0.0 + Asys(2,4) = 4.0*h23_3 + Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) Asys(4,4) = h1_3 - Asys(4,5) = -h2_3 - Asys(4,6) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) + Asys(5,4) = -h2_3 + Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) - Asys(5,1) = 0.0 - Asys(5,2) = 5.0*(h23_2*h23_2) - Asys(5,3) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(5,4) = -h1_4 + Asys(1,5) = 0.0 + Asys(2,5) = 5.0*(h23_2*h23_2) + Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) + Asys(4,5) = -h1_4 Asys(5,5) = -h2_4 - Asys(5,6) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) + Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - Asys(6,1) = 0.0 - Asys(6,2) = 6.0*(h23_3*h23_2) - Asys(6,3) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(6,4) = h1_5 - Asys(6,5) = -h2_5 + Asys(1,6) = 0.0 + Asys(2,6) = 6.0*(h23_3*h23_2) + Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) + Asys(4,6) = h1_5 + Asys(5,6) = -h2_5 Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) Bsys(:) = (/ -1.0, -2.0*h2, -3.0*h2_2, -4.0*h2_3, -5.0*h2_4, -6.0*h2_5 /) - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) @@ -991,17 +991,17 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) do i = 1,6 dx = max( hMin, h(N-6+i) ) xavg = x(i) + 0.5 * dx - Asys(i,1) = 1.0 - Asys(i,2) = xavg - Asys(i,3) = (xavg**2 + C1_12*dx**2) - Asys(i,4) = xavg * (xavg**2 + 0.25*dx**2) - Asys(i,5) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(i,6) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1,i) = 1.0 + Asys(2,i) = xavg + Asys(3,i) = (xavg**2 + C1_12*dx**2) + Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) + Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) + Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx enddo - call solve_linear_system( Asys, Bsys, Csys, 6, .false. ) + call linear_solver( 6, Asys, Bsys, Csys ) tri_l(N+1) = 0.0 tri_d(N+1) = 1.0 From 66c46c3866c1595309c742eb2712d6b8d1854e77 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jan 2020 17:55:23 -0500 Subject: [PATCH 08/15] Made regrid_edge_slopes more concise Used array syntax to set whole lines of the arrays being inverted in edge_values_implicit_h6, edge_slopes_implicit_h5 and elsewhere in the regridding code for shorter code that is easier to read. All answers are bitwise identical. --- src/ALE/regrid_edge_slopes.F90 | 206 ++++++++------------------------ src/ALE/regrid_edge_values.F90 | 212 +++++++++------------------------ 2 files changed, 102 insertions(+), 316 deletions(-) diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index bade56a46f..82996e3e44 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -166,11 +166,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - ! Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) + Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) Bsys(i) = u(i) enddo @@ -207,11 +203,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 dx = max(h_min, h(N+1-i) ) x(i+1) = x(i) + dx xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - ! Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) + Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) Bsys(i) = u(N+1-i) enddo @@ -322,53 +314,23 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 - ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009) + ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009). The last 4 rows are ! Asys(1:6,n) = (/ -n*(n-1)*(-h1)**(n-2), -n*(n-1)*h1**(n-2), (-1)**(n-1) * ((h0+h1)**n - h0**n) / h0, & ! (-h1)**(n-1), h2**(n-1), ((h2+h3)**n - h2**n) / h3 /) - Asys(1,1) = 0.0 - Asys(2,1) = 0.0 - Asys(3,1) = 1.0 - Asys(4,1) = 1.0 - Asys(5,1) = 1.0 - Asys(6,1) = 1.0 - - Asys(1,2) = 2.0 - Asys(2,2) = 2.0 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 6.0*h1 - Asys(2,3) = -6.0* h2 - Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) ! = ((h0+h1)**3 - h1**3) / h0 - Asys(4,3) = h1_2 - Asys(5,3) = h2_2 - Asys(6,3) = (3.0*h2_2 + h3*(3.0*h2 + h3)) ! = ((h2+h3)**3 - h2**3) / h3 - - Asys(1,4) = -12.0* h1_2 - Asys(2,4) = -12.0* h2_2 - Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = -((h0+h1)**4 - h1**4) / h0 - Asys(4,4) = - h1_3 - Asys(5,4) = h2_3 - Asys(6,4) = (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = ((h2+h3)**4 - h2**4)/ h3 - - Asys(1,5) = 20.0*h1_3 - Asys(2,5) = -20.0* h2_3 - Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = h1_4 - Asys(5,5) = h2_4 - Asys(6,5) = (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - - Asys(1,6) = -30.0*h1_4 - Asys(2,6) = -30.0*h2_4 - Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = -h1_5 - Asys(5,6) = h2_5 - Asys(6,6) = (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) - - Bsys(:) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 6.0*h1, -6.0* h2, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -12.0*h1_2, -12.0*h2_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 20.0*h1_3, -20.0*h2_3, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -30.0*h1_4, -30.0*h2_4, & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) call linear_solver( 6, Asys, Bsys, Csys ) @@ -395,53 +357,19 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h01 = h0 + h1 ; h01_2 = h01 * h01 ! Compute matrix entries - Asys(1,1) = 0.0 - Asys(2,1) = 0.0 - Asys(3,1) = 1.0 - Asys(4,1) = 1.0 - Asys(5,1) = 1.0 - Asys(6,1) = 1.0 - - Asys(1,2) = 2.0 - Asys(2,2) = 2.0 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 6.0*h01 - Asys(2,3) = 0.0 - Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(4,3) = h1_2 - Asys(5,3) = h2_2 - Asys(6,3) = 3.0*h2_2 + h3*(3.0*h2 + h3) - -! Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) -! Asys(1:6,2) = (/ 2.0, 2.0, 2.0*h1 + h0, h1, -h2, -(2.0*h2 + h3) /) -! Asys(1:6,3) = (/ 6.0*h01, 0.0, 3.0*h1_2 + h0*(3.0*h1 + h0), h1_2, h2_2, 3.0*h2_2 + h3*(3.0*h2 + h3) /) - - Asys(1,4) = -12.0*h01_2 - Asys(2,4) = 0.0 - Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - Asys(4,4) = -h1_3 - Asys(5,4) = h2_3 - Asys(6,4) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - - Asys(1,5) = 20.0*(h01*h01_2) - Asys(2,5) = 0.0 - Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = h1_4 - Asys(5,5) = h2_4 - Asys(6,5) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - - Asys(1,6) = -30.0*(h01_2*h01_2) - Asys(2,6) = 0.0 - Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = -h1_5 - Asys(5,6) = h2_5 - Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - - Bsys(:) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 6.0*h01, 0.0, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -12.0*h01_2, 0.0, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 20.0*(h01*h01_2), 0.0, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -30.0*(h01_2*h01_2), 0.0, & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) call linear_solver( 6, Asys, Bsys, Csys ) @@ -458,12 +386,9 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 do i = 1,6 dx = h(i) xavg = x(i) + 0.5 * dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) Bsys(i) = u(i) x(i+1) = x(i) + dx enddo @@ -479,7 +404,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_d(1) = 0.0 tri_d(1) = 1.0 tri_u(1) = 0.0 - tri_b(1) = evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value + tri_b(1) = Csys(2) ! evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). @@ -495,49 +420,19 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 h23 = h2 + h3 ; h23_2 = h23 * h23 ! Compute matrix entries - Asys(1,1) = 0.0 - Asys(2,1) = 0.0 - Asys(3,1) = 1.0 - Asys(4,1) = 1.0 - Asys(5,1) = 1.0 - Asys(6,1) = 1.0 - - Asys(1,2) = 2.0 - Asys(2,2) = 2.0 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 0.0 - Asys(2,3) = -6.0*h23 - Asys(3,3) = (3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(4,3) = h1_2 - Asys(5,3) = h2_2 - Asys(6,3) = 3.0*h2_2 + h3*(3.0*h2 + h3) - - Asys(1,4) = 0.0 - Asys(2,4) = -12.0*h23_2 - Asys(3,4) = -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - Asys(4,4) = -h1_3 - Asys(5,4) = h2_3 - Asys(6,4) = 4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3)) - - Asys(1,5) = 0.0 - Asys(2,5) = -20.0*(h23*h23_2) - Asys(3,5) = (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = h1_4 - Asys(5,5) = h2_4 - Asys(6,5) = 5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3))) - - Asys(1,6) = 0.0 - Asys(2,6) = -30.0*(h23_2*h23_2) - Asys(3,6) = -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = -h1_5 - Asys(5,6) = h2_5 - Asys(6,6) = 6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3)))) - - Bsys(:) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 0.0, -6.0*h23, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ 0.0, -12.0*h23_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 0.0, -20.0*(h23*h23_2), (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ 0.0, -30.0*(h23_2*h23_2), & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) call linear_solver( 6, Asys, Bsys, Csys ) @@ -554,12 +449,9 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 do i = 1,6 dx = h(N-6+i) xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx enddo diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 80752f2d98..a4b788cd56 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -162,7 +162,7 @@ end subroutine check_discontinuous_edge_values !> Compute h2 edge values (explicit second order accurate) -!! in the same units as h. +!! in the same units as u. ! !! Compute edge values based on second-order explicit estimates. !! These estimates are based on a straight line spanning two cells and evaluated @@ -203,7 +203,7 @@ subroutine edge_values_explicit_h2( N, h, u, edge_val ) end subroutine edge_values_explicit_h2 !> Compute h4 edge values (explicit fourth order accurate) -!! in the same units as h. +!! in the same units as u. !! !! Compute edge values based on fourth-order explicit estimates. !! These estimates are based on a cubic interpolant spanning four cells @@ -241,7 +241,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real, parameter :: C1_12 = 1.0 / 12.0 - real :: dx, xavg ! Differences and averages of successive values of x [same units as h] + real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: A ! values near the boundaries real, dimension(4) :: B, C real :: hNeglect ! A negligible thickness in the same units as h. @@ -370,7 +370,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_explicit_h4 !> Compute ih4 edge values (implicit fourth order accurate) -!! in the same units as h. +!! in the same units as u. !! !! Compute edge values based on fourth-order implicit estimates. !! @@ -682,8 +682,7 @@ subroutine end_value_h4(dz, u, Csys) end subroutine end_value_h4 -!> Compute ih6 edge values (implicit sixth order accurate) - !! in the same units as h. +!> Compute ih6 edge values (implicit sixth order accurate) in the same units as u. !! !! Sixth-order implicit estimates of edge values are based on a four-cell, !! three-edge stencil. A tridiagonal system is set up and is based on @@ -733,14 +732,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) real :: h01, h01_2, h01_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: h23, h23_2, h23_3 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: hNeglect ! A negligible thickness [H]. - real :: d2, d3, d4, d5, d6 ! to set up the systems - real :: n2, n3, n4, n5, n6 ! used to compute the - real :: h1_2, h2_2 ! the coefficients of the - real :: h1_3, h2_3 ! tridiagonal system - real :: h1_4, h2_4 ! ... - real :: h1_5, h2_5 ! ... + real :: h1_2, h2_2, h1_3, h2_3 ! Cell widths raised to the 2nd and 3rd powers [H2] or [H3] + real :: h1_4, h2_4, h1_5, h2_5 ! Cell widths raised to the 4th and 5th powers [H4] or [H5] real :: alpha, beta ! stencil coefficients - real :: a, b, c, d ! " real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] real, parameter :: C1_12 = 1.0 / 12.0 real, parameter :: C5_6 = 5.0 / 6.0 @@ -768,49 +762,19 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 ! Compute matrix entries as described in Eq. (48) of White and Adcroft (2009) - Asys(1,1) = 1.0 - Asys(2,1) = 1.0 - Asys(3,1) = -1.0 - Asys(4,1) = -1.0 - Asys(5,1) = -1.0 - Asys(6,1) = -1.0 - - Asys(1,2) = -2.0*h1 - Asys(2,2) = 2.0*h2 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 3.0*h1_2 - Asys(2,3) = 3.0*h2_2 - Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) ! = -((h0+h1)**3 - h1**3) / h0 - Asys(4,3) = - h1_2 - Asys(5,3) = - h2_2 - Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) ! = -((h2+h3)**3 - h2**3) / h3 - - Asys(1,4) = -4.0*h1_3 - Asys(2,4) = 4.0*h2_3 - Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) ! = ((h0+h1)**4 - h1**4) / h0 - Asys(4,4) = h1_3 - Asys(5,4) = - h2_3 - Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) ! = -((h2+h3)**4 - h2**4)/ h3 - - Asys(1,5) = 5.0*h1_4 - Asys(2,5) = 5.0*h2_4 - Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = - h1_4 - Asys(5,5) = - h2_4 - Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - - Asys(1,6) = -6.0*h1_5 - Asys(2,6) = 6.0*h2_5 - Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = h1_5 - Asys(5,6) = - h2_5 - Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) - - Bsys(:) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) + Asys(1:6,1) = (/ 1.0, 1.0, -1.0, -1.0, -1.0, -1.0 /) + Asys(1:6,2) = (/ -2.0*h1, 2.0*h2, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 3.0*h1_2, 3.0*h2_2, -(3.0*h1_2 + h0*(3.0*h1 + h0)), & ! = -((h0+h1)**3 - h1**3) / h0 + -h1_2, -h2_2, -(3.0*h2_2 + h3*(3.0*h2 + h3)) /) ! = -((h2+h3)**3 - h2**3) / h3 + Asys(1:6,4) = (/ -4.0*h1_3, 4.0*h2_3, (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + h1_3, -h2_3, -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 5.0*h1_4, 5.0*h2_4, -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + -h1_4, -h2_4, -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -6.0*h1_5, 6.0*h2_5, & + (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + h1_5, -h2_5, & + -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ -1.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) call linear_solver( 6, Asys, Bsys, Csys ) @@ -837,49 +801,19 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h01 = h0 + h1 ; h01_2 = h01 * h01 ; h01_3 = h01 * h01_2 ! Compute matrix entries - Asys(1,1) = 1.0 - Asys(2,1) = 1.0 - Asys(3,1) = -1.0 - Asys(4,1) = -1.0 - Asys(5,1) = -1.0 - Asys(6,1) = -1.0 - - Asys(1,2) = -2.0* h01 - Asys(2,2) = 0.0 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 3.0 * h01_2 - Asys(2,3) = 0.0 - Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(4,3) = - h1_2 - Asys(5,3) = - h2_2 - Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) - - Asys(1,4) = -4.0*h01_3 - Asys(2,4) = 0.0 - Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - Asys(4,4) = h1_3 - Asys(5,4) = - h2_3 - Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) - - Asys(1,5) = 5.0*(h01_2*h01_2) - Asys(2,5) = 0.0 - Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = - h1_4 - Asys(5,5) = - h2_4 - Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - - Asys(1,6) = -6.0*(h01_3*h01_2) - Asys(2,6) = 0.0 - Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = h1_5 - Asys(5,6) = - h2_5 - Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) - - Bsys(:) = (/ -1.0, 2.0*h1, -3.0*h1_2, 4.0*h1_3, -5.0*h1_4, 6.0*h1_5 /) + Asys(1:6,1) = (/ 1.0, 1.0, -1.0, -1.0, -1.0, -1.0 /) + Asys(1:6,2) = (/ -2.0*h01, 0.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 3.0*h01_2, 0.0, -(3.0*h1_2 + h0*(3.0*h1 + h0)), & + -h1_2, -h2_2, -(3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -4.0*h01_3, 0.0, (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + h1_3, -h2_3, -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 5.0*(h01_2*h01_2), 0.0, -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + -h1_4, -h2_4, -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -6.0*(h01_3*h01_2), 0.0, & + (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + h1_5, - h2_5, & + -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ -1.0, 2.0*h1, -3.0*h1_2, 4.0*h1_3, -5.0*h1_4, 6.0*h1_5 /) call linear_solver( 6, Asys, Bsys, Csys ) @@ -897,12 +831,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) do i = 1,6 dx = max( hMin, h(i) ) xavg = x(i) + 0.5*dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) Bsys(i) = u(i) x(i+1) = x(i) + dx enddo @@ -927,63 +858,29 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) h23 = h2 + h3 ; h23_2 = h23 * h23 ; h23_3 = h23 * h23_2 ! Compute matrix entries - Asys(1,1) = 1.0 - Asys(2,1) = 1.0 - Asys(3,1) = -1.0 - Asys(4,1) = -1.0 - Asys(5,1) = -1.0 - Asys(6,1) = -1.0 - - Asys(1,2) = 0.0 - Asys(2,2) = 2.0*h23 - Asys(3,2) = (2.0*h1 + h0) - Asys(4,2) = h1 - Asys(5,2) = -h2 - Asys(6,2) = -(2.0*h2 + h3) - - Asys(1,3) = 0.0 - Asys(2,3) = 3.0*h23_2 - Asys(3,3) = -(3.0*h1_2 + h0*(3.0*h1 + h0)) - Asys(4,3) = -h1_2 - Asys(5,3) = -h2_2 - Asys(6,3) = -(3.0*h2_2 + h3*(3.0*h2 + h3)) - - Asys(1,4) = 0.0 - Asys(2,4) = 4.0*h23_3 - Asys(3,4) = (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))) - Asys(4,4) = h1_3 - Asys(5,4) = -h2_3 - Asys(6,4) = -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) - - Asys(1,5) = 0.0 - Asys(2,5) = 5.0*(h23_2*h23_2) - Asys(3,5) = -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))) - Asys(4,5) = -h1_4 - Asys(5,5) = -h2_4 - Asys(6,5) = -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) - - Asys(1,6) = 0.0 - Asys(2,6) = 6.0*(h23_3*h23_2) - Asys(3,6) = (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))) - Asys(4,6) = h1_5 - Asys(5,6) = -h2_5 - Asys(6,6) = -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) - - Bsys(:) = (/ -1.0, -2.0*h2, -3.0*h2_2, -4.0*h2_3, -5.0*h2_4, -6.0*h2_5 /) + Asys(1:6,1) = (/ 1.0, 1.0, -1.0, -1.0, -1.0, -1.0 /) + Asys(1:6,2) = (/ 0.0, 2.0*h23, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 0.0, 3.0*h23_2, -(3.0*h1_2 + h0*(3.0*h1 + h0)), & + -h1_2, -h2_2, -(3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ 0.0, 4.0*h23_3, (4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + h1_3, -h2_3, -(4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 0.0, 5.0*(h23_2*h23_2), -(5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + -h1_4, -h2_4, -(5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ 0.0, 6.0*(h23_3*h23_2), & + (6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + h1_5, -h2_5, & + -(6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ -1.0, -2.0*h2, -3.0*h2_2, -4.0*h2_3, -5.0*h2_4, -6.0*h2_5 /) call linear_solver( 6, Asys, Bsys, Csys ) alpha = Csys(1) beta = Csys(2) - a = Csys(3) - b = Csys(4) - c = Csys(5) - d = Csys(6) tri_l(N) = alpha tri_d(N) = 1.0 tri_u(N) = beta - tri_b(N) = a * u(N-3) + b * u(N-2) + c * u(N-1) + d * u(N) + tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) ! Boundary conditions: right boundary hMin = max( hNeglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) @@ -991,12 +888,9 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) do i = 1,6 dx = max( hMin, h(N-6+i) ) xavg = x(i) + 0.5 * dx - Asys(1,i) = 1.0 - Asys(2,i) = xavg - Asys(3,i) = (xavg**2 + C1_12*dx**2) - Asys(4,i) = xavg * (xavg**2 + 0.25*dx**2) - Asys(5,i) = (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4) - Asys(6,i) = xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) Bsys(i) = u(N-6+i) x(i+1) = x(i) + dx enddo From dc1bed6bd9bc29fc8cf223d49fad6f2fe46b8b73 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Jan 2020 19:00:57 -0500 Subject: [PATCH 09/15] +Merged regrid_edge_slopes into regrid_edge_values Merged the regrid_edge_slopes module into regrid_edge_values, and also added the two subroutines from regrid_solvers that are intended to be retained to the same module. Also added some additional error handling to linear_solver. All answers are bitwise identical, but the module structure has been streamlined and the locations of some public interfaces have changed. --- src/ALE/MOM_remapping.F90 | 2 +- src/ALE/regrid_edge_slopes.F90 | 484 --------------------------- src/ALE/regrid_edge_values.F90 | 585 ++++++++++++++++++++++++++++++++- src/ALE/regrid_interp.F90 | 2 +- 4 files changed, 579 insertions(+), 494 deletions(-) delete mode 100644 src/ALE/regrid_edge_slopes.F90 diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 5c2bc9918c..d886015115 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -8,7 +8,7 @@ module MOM_remapping use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 -use regrid_edge_slopes, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 +use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 use PCM_functions, only : PCM_reconstruction use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 deleted file mode 100644 index 82996e3e44..0000000000 --- a/src/ALE/regrid_edge_slopes.F90 +++ /dev/null @@ -1,484 +0,0 @@ -!> Routines that estimate edge slopes to be used in -!! high-order reconstruction schemes. -module regrid_edge_slopes - -! This file is part of MOM6. See LICENSE.md for the license. - -use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system -use regrid_solvers, only : solve_diag_dominant_tridiag, linear_solver -use polynomial_functions, only : evaluation_polynomial - -implicit none ; private - -public edge_slopes_implicit_h3 -public edge_slopes_implicit_h5 - -! Specifying a dimensional parameter value, as is done here, is a terrible idea. -real, parameter :: hNeglect_dflt = 1.E-30 !< Default negligible cell thickness -real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) - -contains - -!------------------------------------------------------------------------------ -!> Compute ih3 edge slopes (implicit third order accurate) -!! in the same units as h. -!! -!! Compute edge slopes based on third-order implicit estimates. Note that -!! the estimates are fourth-order accurate on uniform grids -!! -!! Third-order implicit estimates of edge slopes are based on a two-cell -!! stencil. A tridiagonal system is set up and is based on expressing the -!! edge slopes in terms of neighboring cell averages. The generic -!! relationship is -!! -!! \f[ -!! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = -!! a \bar{u}_i + b \bar{u}_{i+1} -!! \f] -!! -!! and the stencil looks like this -!! -!! i i+1 -!! ..--o------o------o--.. -!! i-1/2 i+1/2 i+3/2 -!! -!! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, a and b are computed, -!! the tridiagonal system is built, boundary conditions are prescribed and -!! the system is solved to yield edge-slope estimates. -!! -!! There are N+1 unknowns and we are able to write N-1 equations. The -!! boundary conditions close the system. -subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_2018 ) - integer, intent(in) :: N !< Number of cells - real, dimension(N), intent(in) :: h !< cell widths [H] - real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] - real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the - !! second index is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. - ! Local variables - integer :: i, j ! loop indexes - real :: h0, h1 ! cell widths [H or nondim] - real :: h0_2, h1_2, h0h1 ! products of cell widths [H2 or nondim] - real :: h0_3, h1_3 ! products of three cell widths [H3 or nondim] - real :: h_min ! A minimal cell width [H] - real :: d ! A temporary variable [H3] - real :: I_d ! A temporary variable [nondim] - real :: I_h ! Inverses of thicknesses [H-1] - real :: alpha, beta ! stencil coefficients [nondim] - real :: a, b ! weights of cells [H-1] - real, parameter :: C1_12 = 1.0 / 12.0 - real, dimension(5) :: x ! Coordinate system with 0 at edges [H] - real :: dx, xavg ! Differences and averages of successive values of x [H] - real, dimension(4,4) :: Asys ! matrix used to find boundary conditions - real, dimension(4) :: Bsys, Csys - real, dimension(3) :: Dsys - real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] - tri_d, & ! tridiagonal system (middle diagonal) [nondim] - tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u - tri_u, & ! tridiagonal system (upper diagonal) [nondim] - tri_b, & ! tridiagonal system (right hand side) [A H-1] - tri_x ! tridiagonal system (solution vector) [A H-1] - real :: hNeglect ! A negligible thickness [H]. - real :: hNeglect3 ! hNeglect^3 [H3]. - logical :: use_2018_answers ! If true use older, less acccurate expressions. - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect3 = hNeglect**3 - use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 - - ! Loop on cells (except last one) - do i = 1,N-1 - - if (use_2018_answers) then - ! Get cell widths - h0 = h(i) - h1 = h(i+1) - - ! Auxiliary calculations - h0h1 = h0 * h1 - h0_2 = h0 * h0 - h1_2 = h1 * h1 - h0_3 = h0_2 * h0 - h1_3 = h1_2 * h1 - - d = 4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3 - - ! Coefficients - alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + hNeglect3 ) - beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + hNeglect3 ) - a = -12.0 * h0h1 / ( d + hNeglect3 ) - b = -a - - tri_l(i+1) = alpha - tri_d(i+1) = 1.0 - tri_u(i+1) = beta - - tri_b(i+1) = a * u(i) + b * u(i+1) - else - ! Get cell widths - h0 = max(h(i), hNeglect) - h1 = max(h(i+1), hNeglect) - - I_h = 1.0 / (h0 + h1) - h0 = h0 * I_h ; h1 = h1 * I_h - - h0h1 = h0 * h1 ; h0_2 = h0 * h0 ; h1_2 = h1 * h1 - h0_3 = h0_2 * h0 ; h1_3 = h1_2 * h1 - - I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + h0*h1*(h0 + h1)) - - ! Set the tridiagonal coefficients - tri_l(i+1) = (h1 * ((h0_2 + h0h1) - h1_2)) * I_d - ! tri_d(i+1) = 1.0 - tri_c(i+1) = 2.0 * ((h0_2 + h1_2) * (h0 + h1)) * I_d - tri_u(i+1) = (h0 * ((h1_2 + h0h1) - h0_2)) * I_d - ! The following expressions have been simplified using the nondimensionalization above: - ! I_d = 1.0 / (1.0 + h0h1) - ! tri_l(i+1) = (h0h1 - h1_3) * I_d - ! tri_c(i+1) = 2.0 * (h0_2 + h1_2) * I_d - ! tri_u(i+1) = (h0h1 - h0_3) * I_d - - tri_b(i+1) = 12.0 * (h0h1 * I_d) * ((u(i+1) - u(i)) * I_h) - endif - - enddo ! end loop on cells - - ! Boundary conditions: set the first edge slope - if (use_2018_answers) then - x(1) = 0.0 - do i = 1,4 - dx = h(i) - x(i+1) = x(i) + dx - do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(i) * dx - enddo - - call solve_linear_system( Asys, Bsys, Csys, 4 ) - - Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) - tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! Set the first edge slope - tri_d(1) = 1.0 - else ! Use expressions with less sensitivity to roundoff - h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) - Bsys(i) = u(i) - enddo - - call linear_solver( 4, Asys, Bsys, Csys ) - - ! Set the first edge slope - tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) - tri_c(1) = 1.0 - endif - tri_u(1) = 0.0 ! tri_l(1) = 0.0 - - ! Boundary conditions: set the last edge slope - if (use_2018_answers) then - x(1) = 0.0 - do i = 1,4 - dx = h(N-4+i) - x(i+1) = x(i) + dx - do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo - Bsys(i) = u(N-4+i) * dx - enddo - - call solve_linear_system( Asys, Bsys, Csys, 4 ) - - Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) - ! Set the last edge slope - tri_b(N+1) = evaluation_polynomial( Dsys, 3, x(5) ) - tri_d(N+1) = 1.0 - else - ! Use expressions with less sensitivity to roundoff, including using a coordinate - ! system that sets the origin at the last interface in the domain. - h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(N+1-i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) - Bsys(i) = u(N+1-i) - enddo - - call linear_solver( 4, Asys, Bsys, Csys ) - - ! Set the last edge slope - tri_b(N+1) = Csys(2) - tri_c(N+1) = 1.0 - endif - tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 - - ! Solve tridiagonal system and assign edge slopes - if (use_2018_answers) then - call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) - else - call solve_diag_dominant_tridiag( tri_l, tri_c, tri_u, tri_b, tri_x, N+1 ) - endif - - do i = 2,N - edge_slopes(i,1) = tri_x(i) - edge_slopes(i-1,2) = tri_x(i) - enddo - edge_slopes(1,1) = tri_x(1) - edge_slopes(N,2) = tri_x(N+1) - -end subroutine edge_slopes_implicit_h3 - - -!------------------------------------------------------------------------------ -!> Compute ih5 edge values (implicit fifth order accurate) -subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_2018 ) - integer, intent(in) :: N !< Number of cells - real, dimension(N), intent(in) :: h !< cell widths [H] - real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] - real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the - !! second index is for the two edges of each cell. - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. -! ----------------------------------------------------------------------------- -! Fifth-order implicit estimates of edge values are based on a four-cell, -! three-edge stencil. A tridiagonal system is set up and is based on -! expressing the edge slopes in terms of neighboring cell averages. -! -! The generic relationship is -! -! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = -! a \bar{u}_{i-1} + b \bar{u}_i + c \bar{u}_{i+1} + d \bar{u}_{i+2} -! -! and the stencil looks like this -! -! i-1 i i+1 i+2 -! ..--o------o------o------o------o--.. -! i-1/2 i+1/2 i+3/2 -! -! In this routine, the coefficients \alpha, \beta, a, b, c and d are -! computed, the tridiagonal system is built, boundary conditions are -! prescribed and the system is solved to yield edge-value estimates. -! -! Note that the centered stencil only applies to edges 3 to N-1 (edges are -! numbered 1 to n+1), which yields N-3 equations for N+1 unknowns. Two other -! equations are written by using a right-biased stencil for edge 2 and a -! left-biased stencil for edge N. The prescription of boundary conditions -! (using sixth-order polynomials) closes the system. -! -! CAUTION: For each edge, in order to determine the coefficients of the -! implicit expression, a 6x6 linear system is solved. This may -! become computationally expensive if regridding is carried out -! often. Figuring out closed-form expressions for these coefficients -! on nonuniform meshes turned out to be intractable. -! ----------------------------------------------------------------------------- - - ! Local variables - real :: h0, h1, h2, h3 ! cell widths [H] - real :: hMin ! The minimum thickness used in these calculations [H] - real :: h01, h01_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] - real :: h23, h23_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] - real :: hNeglect ! A negligible thickness [H]. - real :: h1_2, h2_2 ! the coefficients of the - real :: h1_3, h2_3 ! tridiagonal system - real :: h1_4, h2_4 ! ... - real :: h1_5, h2_5 ! ... - real :: alpha, beta ! stencil coefficients - real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] - real, parameter :: C1_12 = 1.0 / 12.0 - real, parameter :: C5_6 = 5.0 / 6.0 - real :: dx, xavg ! Differences and averages of successive values of x [same units as h] - real, dimension(6,6) :: Asys ! matrix used to find boundary conditions - real, dimension(6) :: Bsys, Csys ! ... - real, dimension(5) :: Dsys ! derivative - real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) - tri_d, & ! trid. system (middle diagonal) - tri_u, & ! trid. system (upper diagonal) - tri_b, & ! trid. system (unknowns vector) - tri_x ! trid. system (rhs) - real :: h_Min_Frac = 1.0e-4 - integer :: i, j, k ! loop indexes - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - - ! Loop on cells (except the first and last ones) - do k = 2,N-2 - ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) - h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) - h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) - - ! Auxiliary calculations - h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 - h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 - - ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009). The last 4 rows are - ! Asys(1:6,n) = (/ -n*(n-1)*(-h1)**(n-2), -n*(n-1)*h1**(n-2), (-1)**(n-1) * ((h0+h1)**n - h0**n) / h0, & - ! (-h1)**(n-1), h2**(n-1), ((h2+h3)**n - h2**n) / h3 /) - - Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) - Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) - Asys(1:6,3) = (/ 6.0*h1, -6.0* h2, (3.0*h1_2 + h0*(3.0*h1 + h0)), & - h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) - Asys(1:6,4) = (/ -12.0*h1_2, -12.0*h2_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & - -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) - Asys(1:6,5) = (/ 20.0*h1_3, -20.0*h2_3, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & - h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) - Asys(1:6,6) = (/ -30.0*h1_4, -30.0*h2_4, & - -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & - -h1_5, h2_5, & - (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) - Bsys(1:6) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) - - call linear_solver( 6, Asys, Bsys, Csys ) - - alpha = Csys(1) - beta = Csys(2) - - tri_l(k+1) = alpha - tri_d(k+1) = 1.0 - tri_u(k+1) = beta - tri_b(k+1) = Csys(3) * u(k-1) + Csys(4) * u(k) + Csys(5) * u(k+1) + Csys(6) * u(k+2) - - enddo ! end loop on cells - - ! Use a right-biased stencil for the second row, as described in Eq. (53) of White and Adcroft (2009). - - ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) - h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) - h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) - - ! Auxiliary calculations - h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 - h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 - h01 = h0 + h1 ; h01_2 = h01 * h01 - - ! Compute matrix entries - Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) - Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) - Asys(1:6,3) = (/ 6.0*h01, 0.0, (3.0*h1_2 + h0*(3.0*h1 + h0)), & - h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) - Asys(1:6,4) = (/ -12.0*h01_2, 0.0, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & - -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) - Asys(1:6,5) = (/ 20.0*(h01*h01_2), 0.0, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & - h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) - Asys(1:6,6) = (/ -30.0*(h01_2*h01_2), 0.0, & - -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & - -h1_5, h2_5, & - (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) - Bsys(1:6) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) - - call linear_solver( 6, Asys, Bsys, Csys ) - - alpha = Csys(1) - beta = Csys(2) - - tri_l(2) = alpha - tri_d(2) = 1.0 - tri_u(2) = beta - tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) - - ! Boundary conditions: left boundary - x(1) = 0.0 - do i = 1,6 - dx = h(i) - xavg = x(i) + 0.5 * dx - Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & - (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & - xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) - Bsys(i) = u(i) - x(i+1) = x(i) + dx - enddo - - call linear_solver( 6, Asys, Bsys, Csys ) - - Dsys(1) = Csys(2) - Dsys(2) = 2.0 * Csys(3) - Dsys(3) = 3.0 * Csys(4) - Dsys(4) = 4.0 * Csys(5) - Dsys(5) = 5.0 * Csys(6) - - tri_d(1) = 0.0 - tri_d(1) = 1.0 - tri_u(1) = 0.0 - tri_b(1) = Csys(2) ! evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value - - ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). - - ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. - hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) - h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) - h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) - - ! Auxiliary calculations - h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 - h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 - - h23 = h2 + h3 ; h23_2 = h23 * h23 - - ! Compute matrix entries - Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) - Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) - Asys(1:6,3) = (/ 0.0, -6.0*h23, (3.0*h1_2 + h0*(3.0*h1 + h0)), & - h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) - Asys(1:6,4) = (/ 0.0, -12.0*h23_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & - -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) - Asys(1:6,5) = (/ 0.0, -20.0*(h23*h23_2), (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & - h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) - Asys(1:6,6) = (/ 0.0, -30.0*(h23_2*h23_2), & - -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & - -h1_5, h2_5, & - (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) - Bsys(1:6) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) - - call linear_solver( 6, Asys, Bsys, Csys ) - - alpha = Csys(1) - beta = Csys(2) - - tri_l(N) = alpha - tri_d(N) = 1.0 - tri_u(N) = beta - tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) - - ! Boundary conditions: right boundary - x(1) = 0.0 - do i = 1,6 - dx = h(N-6+i) - xavg = x(i) + 0.5*dx - Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & - (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & - xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) - Bsys(i) = u(N-6+i) - x(i+1) = x(i) + dx - enddo - - call linear_solver( 6, Asys, Bsys, Csys ) - - Dsys(1) = Csys(2) - Dsys(2) = 2.0 * Csys(3) - Dsys(3) = 3.0 * Csys(4) - Dsys(4) = 4.0 * Csys(5) - Dsys(5) = 5.0 * Csys(6) - - tri_l(N+1) = 0.0 - tri_d(N+1) = 1.0 - tri_u(N+1) = 0.0 - tri_b(N+1) = evaluation_polynomial( Dsys, 5, x(7) ) ! last edge value - - ! Solve tridiagonal system and assign edge values - call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) - - do i = 2,N - edge_slopes(i,1) = tri_x(i) - edge_slopes(i-1,2) = tri_x(i) - enddo - edge_slopes(1,1) = tri_x(1) - edge_slopes(N,2) = tri_x(N+1) - -end subroutine edge_slopes_implicit_h5 - -end module regrid_edge_slopes diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index a4b788cd56..c32f1d28b5 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -5,7 +5,6 @@ module regrid_edge_values use MOM_error_handler, only : MOM_error, FATAL use regrid_solvers, only : solve_linear_system, solve_tridiagonal_system -use regrid_solvers, only : solve_diag_dominant_tridiag, linear_solver use polynomial_functions, only : evaluation_polynomial implicit none ; private @@ -13,13 +12,11 @@ module regrid_edge_values ! ----------------------------------------------------------------------------- ! The following routines are visible to the outside world ! ----------------------------------------------------------------------------- -public bound_edge_values -public average_discontinuous_edge_values -public check_discontinuous_edge_values -public edge_values_explicit_h2 -public edge_values_explicit_h4 -public edge_values_implicit_h4 -public edge_values_implicit_h6 +public bound_edge_values, average_discontinuous_edge_values, check_discontinuous_edge_values +public edge_values_explicit_h2, edge_values_explicit_h4 +public edge_values_implicit_h4, edge_values_implicit_h6 +public edge_slopes_implicit_h3, edge_slopes_implicit_h5 +! public solve_diag_dominant_tridiag, linear_solver ! The following parameters are used to avoid singular matrices for boundary ! extrapolation. The are needed only in the case where thicknesses vanish @@ -682,6 +679,469 @@ subroutine end_value_h4(dz, u, Csys) end subroutine end_value_h4 +!------------------------------------------------------------------------------ +!> Compute ih3 edge slopes (implicit third order accurate) +!! in the same units as h. +!! +!! Compute edge slopes based on third-order implicit estimates. Note that +!! the estimates are fourth-order accurate on uniform grids +!! +!! Third-order implicit estimates of edge slopes are based on a two-cell +!! stencil. A tridiagonal system is set up and is based on expressing the +!! edge slopes in terms of neighboring cell averages. The generic +!! relationship is +!! +!! \f[ +!! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = +!! a \bar{u}_i + b \bar{u}_{i+1} +!! \f] +!! +!! and the stencil looks like this +!! +!! i i+1 +!! ..--o------o------o--.. +!! i-1/2 i+1/2 i+3/2 +!! +!! In this routine, the coefficients \f$\alpha\f$, \f$\beta\f$, a and b are computed, +!! the tridiagonal system is built, boundary conditions are prescribed and +!! the system is solved to yield edge-slope estimates. +!! +!! There are N+1 unknowns and we are able to write N-1 equations. The +!! boundary conditions close the system. +subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_2018 ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the + !! second index is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + ! Local variables + integer :: i, j ! loop indexes + real :: h0, h1 ! cell widths [H or nondim] + real :: h0_2, h1_2, h0h1 ! products of cell widths [H2 or nondim] + real :: h0_3, h1_3 ! products of three cell widths [H3 or nondim] + real :: h_min ! A minimal cell width [H] + real :: d ! A temporary variable [H3] + real :: I_d ! A temporary variable [nondim] + real :: I_h ! Inverses of thicknesses [H-1] + real :: alpha, beta ! stencil coefficients [nondim] + real :: a, b ! weights of cells [H-1] + real, parameter :: C1_12 = 1.0 / 12.0 + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real :: dx, xavg ! Differences and averages of successive values of x [H] + real, dimension(4,4) :: Asys ! matrix used to find boundary conditions + real, dimension(4) :: Bsys, Csys + real, dimension(3) :: Dsys + real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] + tri_d, & ! tridiagonal system (middle diagonal) [nondim] + tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u + tri_u, & ! tridiagonal system (upper diagonal) [nondim] + tri_b, & ! tridiagonal system (right hand side) [A H-1] + tri_x ! tridiagonal system (solution vector) [A H-1] + real :: hNeglect ! A negligible thickness [H]. + real :: hNeglect3 ! hNeglect^3 [H3]. + logical :: use_2018_answers ! If true use older, less acccurate expressions. + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + hNeglect3 = hNeglect**3 + use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 + + ! Loop on cells (except last one) + do i = 1,N-1 + + if (use_2018_answers) then + ! Get cell widths + h0 = h(i) + h1 = h(i+1) + + ! Auxiliary calculations + h0h1 = h0 * h1 + h0_2 = h0 * h0 + h1_2 = h1 * h1 + h0_3 = h0_2 * h0 + h1_3 = h1_2 * h1 + + d = 4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3 + + ! Coefficients + alpha = h1 * (h0_2 + h0h1 - h1_2) / ( d + hNeglect3 ) + beta = h0 * (h1_2 + h0h1 - h0_2) / ( d + hNeglect3 ) + a = -12.0 * h0h1 / ( d + hNeglect3 ) + b = -a + + tri_l(i+1) = alpha + tri_d(i+1) = 1.0 + tri_u(i+1) = beta + + tri_b(i+1) = a * u(i) + b * u(i+1) + else + ! Get cell widths + h0 = max(h(i), hNeglect) + h1 = max(h(i+1), hNeglect) + + I_h = 1.0 / (h0 + h1) + h0 = h0 * I_h ; h1 = h1 * I_h + + h0h1 = h0 * h1 ; h0_2 = h0 * h0 ; h1_2 = h1 * h1 + h0_3 = h0_2 * h0 ; h1_3 = h1_2 * h1 + + I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + h0*h1*(h0 + h1)) + + ! Set the tridiagonal coefficients + tri_l(i+1) = (h1 * ((h0_2 + h0h1) - h1_2)) * I_d + ! tri_d(i+1) = 1.0 + tri_c(i+1) = 2.0 * ((h0_2 + h1_2) * (h0 + h1)) * I_d + tri_u(i+1) = (h0 * ((h1_2 + h0h1) - h0_2)) * I_d + ! The following expressions have been simplified using the nondimensionalization above: + ! I_d = 1.0 / (1.0 + h0h1) + ! tri_l(i+1) = (h0h1 - h1_3) * I_d + ! tri_c(i+1) = 2.0 * (h0_2 + h1_2) * I_d + ! tri_u(i+1) = (h0h1 - h0_3) * I_d + + tri_b(i+1) = 12.0 * (h0h1 * I_d) * ((u(i+1) - u(i)) * I_h) + endif + + enddo ! end loop on cells + + ! Boundary conditions: set the first edge slope + if (use_2018_answers) then + x(1) = 0.0 + do i = 1,4 + dx = h(i) + x(i+1) = x(i) + dx + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) + tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! Set the first edge slope + tri_d(1) = 1.0 + else ! Use expressions with less sensitivity to roundoff + h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(i) ) + x(i+1) = x(i) + dx + xavg = x(i) + 0.5*dx + Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) + Bsys(i) = u(i) + enddo + + call linear_solver( 4, Asys, Bsys, Csys ) + + ! Set the first edge slope + tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) + tri_c(1) = 1.0 + endif + tri_u(1) = 0.0 ! tri_l(1) = 0.0 + + ! Boundary conditions: set the last edge slope + if (use_2018_answers) then + x(1) = 0.0 + do i = 1,4 + dx = h(N-4+i) + x(i+1) = x(i) + dx + do j = 1,4 ; Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j ; enddo + Bsys(i) = u(N-4+i) * dx + enddo + + call solve_linear_system( Asys, Bsys, Csys, 4 ) + + Dsys(1) = Csys(2) ; Dsys(2) = 2.0 * Csys(3) ; Dsys(3) = 3.0 * Csys(4) + ! Set the last edge slope + tri_b(N+1) = evaluation_polynomial( Dsys, 3, x(5) ) + tri_d(N+1) = 1.0 + else + ! Use expressions with less sensitivity to roundoff, including using a coordinate + ! system that sets the origin at the last interface in the domain. + h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) + x(1) = 0.0 + do i = 1,4 + dx = max(h_min, h(N+1-i) ) + x(i+1) = x(i) + dx + xavg = x(i) + 0.5*dx + Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) + Bsys(i) = u(N+1-i) + enddo + + call linear_solver( 4, Asys, Bsys, Csys ) + + ! Set the last edge slope + tri_b(N+1) = Csys(2) + tri_c(N+1) = 1.0 + endif + tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 + + ! Solve tridiagonal system and assign edge slopes + if (use_2018_answers) then + call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + else + call solve_diag_dominant_tridiag( tri_l, tri_c, tri_u, tri_b, tri_x, N+1 ) + endif + + do i = 2,N + edge_slopes(i,1) = tri_x(i) + edge_slopes(i-1,2) = tri_x(i) + enddo + edge_slopes(1,1) = tri_x(1) + edge_slopes(N,2) = tri_x(N+1) + +end subroutine edge_slopes_implicit_h3 + + +!------------------------------------------------------------------------------ +!> Compute ih5 edge slopes (implicit fifth order accurate) +subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_2018 ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_slopes !< Returned edge slopes [A H-1]; the + !! second index is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. +! ----------------------------------------------------------------------------- +! Fifth-order implicit estimates of edge slopes are based on a four-cell, +! three-edge stencil. A tridiagonal system is set up and is based on +! expressing the edge slopes in terms of neighboring cell averages. +! +! The generic relationship is +! +! \alpha u'_{i-1/2} + u'_{i+1/2} + \beta u'_{i+3/2} = +! a \bar{u}_{i-1} + b \bar{u}_i + c \bar{u}_{i+1} + d \bar{u}_{i+2} +! +! and the stencil looks like this +! +! i-1 i i+1 i+2 +! ..--o------o------o------o------o--.. +! i-1/2 i+1/2 i+3/2 +! +! In this routine, the coefficients \alpha, \beta, a, b, c and d are +! computed, the tridiagonal system is built, boundary conditions are +! prescribed and the system is solved to yield edge-value estimates. +! +! Note that the centered stencil only applies to edges 3 to N-1 (edges are +! numbered 1 to n+1), which yields N-3 equations for N+1 unknowns. Two other +! equations are written by using a right-biased stencil for edge 2 and a +! left-biased stencil for edge N. The prescription of boundary conditions +! (using sixth-order polynomials) closes the system. +! +! CAUTION: For each edge, in order to determine the coefficients of the +! implicit expression, a 6x6 linear system is solved. This may +! become computationally expensive if regridding is carried out +! often. Figuring out closed-form expressions for these coefficients +! on nonuniform meshes turned out to be intractable. +! ----------------------------------------------------------------------------- + + ! Local variables + real :: h0, h1, h2, h3 ! cell widths [H] + real :: hMin ! The minimum thickness used in these calculations [H] + real :: h01, h01_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: h23, h23_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] + real :: hNeglect ! A negligible thickness [H]. + real :: h1_2, h2_2 ! the coefficients of the + real :: h1_3, h2_3 ! tridiagonal system + real :: h1_4, h2_4 ! ... + real :: h1_5, h2_5 ! ... + real :: alpha, beta ! stencil coefficients + real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] + real, parameter :: C1_12 = 1.0 / 12.0 + real, parameter :: C5_6 = 5.0 / 6.0 + real :: dx, xavg ! Differences and averages of successive values of x [same units as h] + real, dimension(6,6) :: Asys ! matrix used to find boundary conditions + real, dimension(6) :: Bsys, Csys ! ... + real, dimension(5) :: Dsys ! derivative + real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) + tri_d, & ! trid. system (middle diagonal) + tri_u, & ! trid. system (upper diagonal) + tri_b, & ! trid. system (unknowns vector) + tri_x ! trid. system (rhs) + real :: h_Min_Frac = 1.0e-4 + integer :: i, j, k ! loop indexes + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! Loop on cells (except the first and last ones) + do k = 2,N-2 + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(k-1) + h(k)) + (h(k+1) + h(k+2)))) + h0 = max(h(k-1), hMin) ; h1 = max(h(k), hMin) + h2 = max(h(k+1), hMin) ; h3 = max(h(k+2), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + ! Compute matrix entries as described in Eq. (52) of White and Adcroft (2009). The last 4 rows are + ! Asys(1:6,n) = (/ -n*(n-1)*(-h1)**(n-2), -n*(n-1)*h1**(n-2), (-1)**(n-1) * ((h0+h1)**n - h0**n) / h0, & + ! (-h1)**(n-1), h2**(n-1), ((h2+h3)**n - h2**n) / h3 /) + + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 6.0*h1, -6.0* h2, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -12.0*h1_2, -12.0*h2_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 20.0*h1_3, -20.0*h2_3, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -30.0*h1_4, -30.0*h2_4, & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, 0.0, 0.0, 0.0, 0.0 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(k+1) = alpha + tri_d(k+1) = 1.0 + tri_u(k+1) = beta + tri_b(k+1) = Csys(3) * u(k-1) + Csys(4) * u(k) + Csys(5) * u(k+1) + Csys(6) * u(k+2) + + enddo ! end loop on cells + + ! Use a right-biased stencil for the second row, as described in Eq. (53) of White and Adcroft (2009). + + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(1) + h(2)) + (h(3) + h(4)))) + h0 = max(h(1), hMin) ; h1 = max(h(2), hMin) + h2 = max(h(3), hMin) ; h3 = max(h(4), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + h01 = h0 + h1 ; h01_2 = h01 * h01 + + ! Compute matrix entries + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 6.0*h01, 0.0, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ -12.0*h01_2, 0.0, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 20.0*(h01*h01_2), 0.0, (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ -30.0*(h01_2*h01_2), 0.0, & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, -6.0*h1, 12.0*h1_2, -20.0*h1_3, 30.0*h1_4 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(2) = alpha + tri_d(2) = 1.0 + tri_u(2) = beta + tri_b(2) = Csys(3) * u(1) + Csys(4) * u(2) + Csys(5) * u(3) + Csys(6) * u(4) + + ! Boundary conditions: left boundary + x(1) = 0.0 + do i = 1,6 + dx = h(i) + xavg = x(i) + 0.5 * dx + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) + Bsys(i) = u(i) + x(i+1) = x(i) + dx + enddo + + call linear_solver( 6, Asys, Bsys, Csys ) + + Dsys(1) = Csys(2) + Dsys(2) = 2.0 * Csys(3) + Dsys(3) = 3.0 * Csys(4) + Dsys(4) = 4.0 * Csys(5) + Dsys(5) = 5.0 * Csys(6) + + tri_d(1) = 0.0 + tri_d(1) = 1.0 + tri_u(1) = 0.0 + tri_b(1) = Csys(2) ! evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value + + ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). + + ! Store temporary cell widths, avoiding singularities from zero thicknesses or extreme changes. + hMin = max(hNeglect, h_Min_Frac*((h(N-3) + h(N-2)) + (h(N-1) + h(N)))) + h0 = max(h(N-3), hMin) ; h1 = max(h(N-2), hMin) + h2 = max(h(N-1), hMin) ; h3 = max(h(N), hMin) + + ! Auxiliary calculations + h1_2 = h1 * h1 ; h1_3 = h1_2 * h1 ; h1_4 = h1_2 * h1_2 ; h1_5 = h1_3 * h1_2 + h2_2 = h2 * h2 ; h2_3 = h2_2 * h2 ; h2_4 = h2_2 * h2_2 ; h2_5 = h2_3 * h2_2 + + h23 = h2 + h3 ; h23_2 = h23 * h23 + + ! Compute matrix entries + Asys(1:6,1) = (/ 0.0, 0.0, 1.0, 1.0, 1.0, 1.0 /) + Asys(1:6,2) = (/ 2.0, 2.0, (2.0*h1 + h0), h1, -h2, -(2.0*h2 + h3) /) + Asys(1:6,3) = (/ 0.0, -6.0*h23, (3.0*h1_2 + h0*(3.0*h1 + h0)), & + h1_2, h2_2, (3.0*h2_2 + h3*(3.0*h2 + h3)) /) + Asys(1:6,4) = (/ 0.0, -12.0*h23_2, -(4.0*h1_3 + h0*(6.0*h1_2 + h0*(4.0*h1 + h0))), & + -h1_3, h2_3, (4.0*h2_3 + h3*(6.0*h2_2 + h3*(4.0*h2 + h3))) /) + Asys(1:6,5) = (/ 0.0, -20.0*(h23*h23_2), (5.0*h1_4 + h0*(10.0*h1_3 + h0*(10.0*h1_2 + h0*(5.0*h1 + h0)))), & + h1_4, h2_4, (5.0*h2_4 + h3*(10.0*h2_3 + h3*(10.0*h2_2 + h3*(5.0*h2 + h3)))) /) + Asys(1:6,6) = (/ 0.0, -30.0*(h23_2*h23_2), & + -(6.0*h1_5 + h0*(15.0*h1_4 + h0*(20.0*h1_3 + h0*(15.0*h1_2 + h0*(6.0*h1 + h0))))), & + -h1_5, h2_5, & + (6.0*h2_5 + h3*(15.0*h2_4 + h3*(20.0*h2_3 + h3*(15.0*h2_2 + h3*(6.0*h2 + h3))))) /) + Bsys(1:6) = (/ 0.0, -2.0, 6.0*h2, 12.0*h2_2, 20.0*h2_3, 30.0*h2_4 /) + + call linear_solver( 6, Asys, Bsys, Csys ) + + alpha = Csys(1) + beta = Csys(2) + + tri_l(N) = alpha + tri_d(N) = 1.0 + tri_u(N) = beta + tri_b(N) = Csys(3) * u(N-3) + Csys(4) * u(N-2) + Csys(5) * u(N-1) + Csys(6) * u(N) + + ! Boundary conditions: right boundary + x(1) = 0.0 + do i = 1,6 + dx = h(N-6+i) + xavg = x(i) + 0.5*dx + Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & + (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & + xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) + Bsys(i) = u(N-6+i) + x(i+1) = x(i) + dx + enddo + + call linear_solver( 6, Asys, Bsys, Csys ) + + Dsys(1) = Csys(2) + Dsys(2) = 2.0 * Csys(3) + Dsys(3) = 3.0 * Csys(4) + Dsys(4) = 4.0 * Csys(5) + Dsys(5) = 5.0 * Csys(6) + + tri_l(N+1) = 0.0 + tri_d(N+1) = 1.0 + tri_u(N+1) = 0.0 + tri_b(N+1) = evaluation_polynomial( Dsys, 5, x(7) ) ! last edge value + + ! Solve tridiagonal system and assign edge values + call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) + + do i = 2,N + edge_slopes(i,1) = tri_x(i) + edge_slopes(i-1,2) = tri_x(i) + enddo + edge_slopes(1,1) = tri_x(1) + edge_slopes(N,2) = tri_x(N+1) + +end subroutine edge_slopes_implicit_h5 + + !> Compute ih6 edge values (implicit sixth order accurate) in the same units as u. !! !! Sixth-order implicit estimates of edge values are based on a four-cell, @@ -915,6 +1375,115 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_implicit_h6 +!> Solve the tridiagonal system AX = R +!! +!! This routine uses a variant of Thomas's algorithm to solve the tridiagonal system AX = R, in +!! a form that is guaranteed to avoid dividing by a zero pivot. The matrix A is made up of +!! lower (Al) and upper diagonals (Au) and a central diagonal Ad = Ac+Al+Au, where +!! Al, Au, and Ac are all positive (or negative) definite. However when Ac is smaller than +!! roundoff compared with (Al+Au), the answers are prone to inaccuracy. +subroutine solve_diag_dominant_tridiag( Al, Ac, Au, R, X, N ) + integer, intent(in) :: N !< The size of the system + real, dimension(N), intent(in) :: Ac !< Matrix center diagonal offset from Al + Au + real, dimension(N), intent(in) :: Al !< Matrix lower diagonal + real, dimension(N), intent(in) :: Au !< Matrix upper diagonal + real, dimension(N), intent(in) :: R !< system right-hand side + real, dimension(N), intent(out) :: X !< solution vector + ! Local variables + real, dimension(N) :: c1 ! Au / pivot for the backward sweep + real :: d1 ! The next value of 1.0 - c1 + real :: I_pivot ! The inverse of the most recent pivot + real :: denom_t1 ! The first term in the denominator of the inverse of the pivot. + integer :: k ! Loop index + + ! Factorization and forward sweep, in a form that will never give a division by a + ! zero pivot for positive definite Ac, Al, and Au. + I_pivot = 1.0 / (Ac(1) + Au(1)) + d1 = Ac(1) * I_pivot + c1(1) = Au(1) * I_pivot + X(1) = R(1) * I_pivot + do k=2,N-1 + denom_t1 = Ac(k) + d1 * Al(k) + I_pivot = 1.0 / (denom_t1 + Au(k)) + d1 = denom_t1 * I_pivot + c1(k) = Au(k) * I_pivot + X(k) = (R(k) - Al(k) * X(k-1)) * I_pivot + enddo + I_pivot = 1.0 / (Ac(N) + d1 * Al(N)) + X(N) = (R(N) - Al(N) * X(N-1)) * I_pivot + ! Backward sweep + do k=N-1,1,-1 + X(k) = X(k) - c1(k) * X(k+1) + enddo + +end subroutine solve_diag_dominant_tridiag + + +!> Solve the linear system AX = R by Gaussian elimination +!! +!! This routine uses Gauss's algorithm to transform the system's original +!! matrix into an upper triangular matrix. Back substitution then yields the answer. +!! The matrix A must be square, with the first index varing along the row. +subroutine linear_solver( N, A, R, X ) + integer, intent(in) :: N !< The size of the system + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] + real, dimension(N), intent(inout) :: R !< system right-hand side [A] + real, dimension(N), intent(inout) :: X !< solution vector [A] + + ! Local variables + real :: factor ! The factor that eliminates the leading nonzero element in a row. + real :: I_pivot ! The reciprocal of the pivot value [inverse of the input units of a row of A] + real :: swap + integer :: i, j, k + + ! Loop on rows to transform the problem into multiplication by an upper-right matrix. + do i=1,N-1 + ! Seek a pivot for column i starting in row i, and continuing into the remaining rows. If the + ! pivot is in a row other than i, swap them. If no valid pivot is found, i = N+1 after this loop. + do k=i,N ; if ( abs(A(i,k)) > 0.0 ) exit ; enddo ! end loop to find pivot + if ( k > N ) then ! No pivot could be found and the system is singular. + write(0,*) ' A=',A + call MOM_error( FATAL, 'The linear system sent to linear_solver is singular.' ) + endif + + ! If the pivot is in a row that is different than row i, swap those two rows, noting that both + ! rows start with i-1 zero values. + if ( k /= i ) then + do j=i,N ; swap = A(j,i) ; A(j,i) = A(j,k) ; A(j,k) = swap ; enddo + swap = R(i) ; R(i) = R(k) ; R(k) = swap + endif + + ! Transform the pivot to 1 by dividing the entire row (right-hand side included) by the pivot + I_pivot = 1.0 / A(i,i) + A(i,i) = 1.0 + do j=i+1,N ; A(j,i) = A(j,i) * I_pivot ; enddo + R(i) = R(i) * I_pivot + + ! Put zeros in column for all rows below that contain the pivot (which is row i) + do k=i+1,N ! k is the row index + factor = A(i,k) + ! A(i,k) = 0.0 ! These elements are not used again, so this line can be skipped for speed. + do j=i+1,N ; A(j,k) = A(j,k) - factor * A(j,i) ; enddo + R(k) = R(k) - factor * R(i) + enddo + + enddo ! end loop on i + + ! Solve the system by back substituting into what is now an upper-right matrix. + if (A(N,N) == 0.0) then ! No pivot could be found and the system is singular. + ! write(0,*) ' A=',A + call MOM_error( FATAL, 'The final pivot in linear_solver is zero.' ) + endif + X(N) = R(N) / A(N,N) ! The last row can now be solved trivially. + do i=N-1,1,-1 ! loop on rows, starting from second to last row + X(i) = R(i) + do j=i+1,N ; X(i) = X(i) - A(j,i) * X(j) ; enddo + enddo + +end subroutine linear_solver + + + ! Verify that A*C = R to within roundoff. subroutine test_line(msg, N, A, C, R, mag, tolerance) integer, intent(in) :: N diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 7b6bfd0e92..3faa5f46b1 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -8,7 +8,7 @@ module regrid_interp use regrid_edge_values, only : edge_values_explicit_h2, edge_values_explicit_h4 use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 -use regrid_edge_slopes, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 +use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation From 981e3cb4b17649a07d81121daf25cef3c948e8ce Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Jan 2020 18:38:46 -0500 Subject: [PATCH 10/15] (*)Corrected a sign error in edge_slopes_implicit_h3 Corrected a recently introduced sign error in the right end slope estimate of edge_slopes_implicit_h3 when REMAPPING_2018_ANSWERS is false. Also used a coordinate system that starts at the right edge for edge_values_implicit_h6 and edge_slopes_implicit_h5. This will change answers when REMAPPING_2018_ANSWERS is false and INTERPOLATION_SCHEME = "P3M_IH4IH3" or "PQM_IH4IH3" or REMAPPING_SCHEME = "PQM_IH4IH3", while answers are mathematically equivalent but change at roundoff when INTERPOLATION_SCHEME = "P3M_IH46H5" or "PQM_IH6IH5" or REMAPPING_SCHEME = "PQM_IH6IH5". Because these settings are not yet used in the MOM6-examples test cases, no answers are changed in the regression tests. --- src/ALE/regrid_edge_values.F90 | 31 ++++++++++--------------------- 1 file changed, 10 insertions(+), 21 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index c32f1d28b5..ea4f3a10fb 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -833,7 +833,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 call linear_solver( 4, Asys, Bsys, Csys ) ! Set the first edge slope - tri_b(1) = Csys(2) ! + x(1)*(2.0*Csys(3) + x(1)*(3.0*Csys(4))) + tri_b(1) = Csys(2) tri_c(1) = 1.0 endif tri_u(1) = 0.0 ! tri_l(1) = 0.0 @@ -870,7 +870,8 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 call linear_solver( 4, Asys, Bsys, Csys ) ! Set the last edge slope - tri_b(N+1) = Csys(2) + + tri_b(N+1) = -Csys(2) tri_c(N+1) = 1.0 endif tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 @@ -1055,16 +1056,10 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 call linear_solver( 6, Asys, Bsys, Csys ) - Dsys(1) = Csys(2) - Dsys(2) = 2.0 * Csys(3) - Dsys(3) = 3.0 * Csys(4) - Dsys(4) = 4.0 * Csys(5) - Dsys(5) = 5.0 * Csys(6) - tri_d(1) = 0.0 tri_d(1) = 1.0 tri_u(1) = 0.0 - tri_b(1) = Csys(2) ! evaluation_polynomial( Dsys, 5, x(1) ) ! first edge value + tri_b(1) = Csys(2) ! first edge value ! Use a left-biased stencil for the second to last row, as described in Eq. (54) of White and Adcroft (2009). @@ -1107,27 +1102,21 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! Boundary conditions: right boundary x(1) = 0.0 do i = 1,6 - dx = h(N-6+i) + dx = h(N+1-i) xavg = x(i) + 0.5*dx Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) - Bsys(i) = u(N-6+i) + Bsys(i) = u(N+1-i) x(i+1) = x(i) + dx enddo call linear_solver( 6, Asys, Bsys, Csys ) - Dsys(1) = Csys(2) - Dsys(2) = 2.0 * Csys(3) - Dsys(3) = 3.0 * Csys(4) - Dsys(4) = 4.0 * Csys(5) - Dsys(5) = 5.0 * Csys(6) - tri_l(N+1) = 0.0 tri_d(N+1) = 1.0 tri_u(N+1) = 0.0 - tri_b(N+1) = evaluation_polynomial( Dsys, 5, x(7) ) ! last edge value + tri_b(N+1) = -Csys(2) ! Solve tridiagonal system and assign edge values call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) @@ -1346,12 +1335,12 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) hMin = max( hNeglect, hMinFrac*(h(N-3) + h(N-2)) + ((h(N-1) + h(N)) + (h(N-5) + h(N-4))) ) x(1) = 0.0 do i = 1,6 - dx = max( hMin, h(N-6+i) ) + dx = max( hMin, h(N+1-i) ) xavg = x(i) + 0.5 * dx Asys(1:6,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2), & (xavg**4 + 0.5*xavg**2*dx**2 + 0.0125*dx**4), & xavg * (xavg**4 + C5_6*xavg**2*dx**2 + 0.0625*dx**4) /) - Bsys(i) = u(N-6+i) + Bsys(i) = u(N+1-i) x(i+1) = x(i) + dx enddo @@ -1360,7 +1349,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_l(N+1) = 0.0 tri_d(N+1) = 1.0 tri_u(N+1) = 0.0 - tri_b(N+1) = evaluation_polynomial( Csys, 6, x(7) ) ! last edge value + tri_b(N+1) = Csys(1) ! Solve tridiagonal system and assign edge values call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) From 515eb1121e6c51a0f781b5785033429649e1f06c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Jan 2020 19:14:19 -0500 Subject: [PATCH 11/15] (*)Use end_value_h4 in edge_slopes_implicit_h3 Use end_value_h4 to set end slopes in edge_slopes_implicit_h3. This changes answers in some cases with REMAPPING_2018_ANSWERS = False, but the existing MOM6-examples test cases are bitwise identical. --- src/ALE/regrid_edge_values.F90 | 28 ++++++++++------------------ 1 file changed, 10 insertions(+), 18 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index ea4f3a10fb..8b5396cc3a 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -728,6 +728,8 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 real :: alpha, beta ! stencil coefficients [nondim] real :: a, b ! weights of cells [H-1] real, parameter :: C1_12 = 1.0 / 12.0 + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! matrix used to find boundary conditions @@ -821,16 +823,11 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) - Bsys(i) = u(i) + do i=1,4 + dz(i) = max(h_min, h(i) ) + u_tmp(i) = u(i) enddo - - call linear_solver( 4, Asys, Bsys, Csys ) + call end_value_h4(dz, u_tmp, Csys) ! Set the first edge slope tri_b(1) = Csys(2) @@ -858,19 +855,14 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) - x(1) = 0.0 - do i = 1,4 - dx = max(h_min, h(N+1-i) ) - x(i+1) = x(i) + dx - xavg = x(i) + 0.5*dx - Asys(1:4,i) = (/ 1.0, xavg, (xavg**2 + C1_12*dx**2), xavg * (xavg**2 + 0.25*dx**2) /) - Bsys(i) = u(N+1-i) + do i=1,4 + dz(i) = max(h_min, h(N+1-i) ) + u_tmp(i) = u(N+1-i) enddo - call linear_solver( 4, Asys, Bsys, Csys ) + call end_value_h4(dz, u_tmp, Csys) ! Set the last edge slope - tri_b(N+1) = -Csys(2) tri_c(N+1) = 1.0 endif From 612b1643cdfd299cdcb48827b597db9e5a1a44f5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jan 2020 09:43:38 -0500 Subject: [PATCH 12/15] (*)Limit fractional thicknesses in end_value_h4 Set algorithmically motivated minimum fractional thicknesses in end_value_h4, and removed less germane minima in the thicknesses passed to end_value_h4. This changes answers in some cases with REMAPPING_2018_ANSWERS = False, but the existing MOM6-examples test cases are bitwise identical. --- src/ALE/regrid_edge_values.F90 | 65 ++++++++++------------------------ 1 file changed, 19 insertions(+), 46 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 8b5396cc3a..f262b8015d 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -315,13 +315,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) edge_val(1,1) = evaluation_polynomial( C, 4, x(1) ) edge_val(1,2) = evaluation_polynomial( C, 4, x(2) ) else ! Use expressions with less sensitivity to roundoff - h_min = hMinFrac*((h(1) + h(2)) + (h(3) + h(4))) - if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - - do i=1,4 - dz(i) = max(h_min, h(i) ) - u_tmp(i) = u(i) - enddo + do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, C) ! Set the edge values of the first cell @@ -350,12 +344,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - h_min = hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) - if (h_min == 0.0) h_min = 1.0 ! Handle the case of all massless layers. - do i=1,4 - dz(i) = max(h_min, h(N+1-i) ) - u_tmp(i) = u(N+1-i) - enddo + do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, C) ! Set the last and second to last edge values @@ -419,8 +408,6 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real :: dx, xavg ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! boundary conditions real, dimension(4) :: Bsys, Csys - real, dimension(4,4) :: Asys_orig ! boundary conditions - real, dimension(4) :: Bsys_orig real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] tri_d, & ! tridiagonal system (middle diagonal) [nondim] tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u @@ -504,15 +491,10 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) tri_b(1) = evaluation_polynomial( Csys, 4, x(1) ) ! Set the first edge value tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff - h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) - do i=1,4 - dz(i) = max(h_min, h(i) ) - u_tmp(i) = u(i) - enddo + do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, Csys) tri_b(1) = Csys(1) ! Set the first edge value. - tri_c(1) = 1.0 endif tri_u(1) = 0.0 ! tri_l(1) = 0.0 @@ -537,16 +519,10 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) - do i=1,4 - dz(i) = max(h_min, h(N+1-i) ) - u_tmp(i) = u(N+1-i) - enddo - + do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, Csys) - ! Set the last edge value - tri_b(N+1) = Csys(1) + tri_b(N+1) = Csys(1) ! Set the last edge value tri_c(N+1) = 1.0 endif tri_l(N+1) = 0.0 ! tri_u(N+1) = 0.0 @@ -589,14 +565,15 @@ subroutine end_value_h4(dz, u, Csys) real :: I_h1234 ! The inverse of the sum of all four thicknesses [H-1] real :: I_denom ! The inverse of the denominator some expressions [H-3] real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] + real :: min_frac = 1.0e-6 ! The square of min_frac should be much larger than roundoff [nondim] real, parameter :: C1_3 = 1.0 / 3.0 integer :: i, j, k ! These are only used for code verification - real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. - real :: zavg, u_mag, c_mag - character(len=128) :: mesg - real, parameter :: C1_12 = 1.0 / 12.0 + ! real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. + ! real :: zavg, u_mag, c_mag + ! character(len=128) :: mesg + ! real, parameter :: C1_12 = 1.0 / 12.0 ! if ((dz(1) == dz(2)) .and. (dz(1) == dz(3)) .and. (dz(1) == dz(4))) then ! ! There are simple closed-form expressions in this case @@ -610,6 +587,12 @@ subroutine end_value_h4(dz, u, Csys) ! Express the coefficients as sums of the differences between properties of succesive layers. h1 = dz(1) ; h2 = dz(2) ; h3 = dz(3) ; h4 = dz(4) + ! Some of the weights used below are proportional to (h1/(h2+h3))**2 or (h1/(h2+h3))*(h2/(h3+h4)) + ! so h2 and h3 should be adjusted to ensure that these ratios are not so large that property + ! differences at the level of roundoff are amplified to be of order 1. + if ((h2+h3) < min_frac*h1) h3 = min_frac*h1 - h2 + if ((h3+h4) < min_frac*h1) h4 = min_frac*h1 - h3 + h12 = h1+h2 ; h23 = h2+h3 ; h34 = h3+h4 h123 = h12 + h3 ; h234 = h2 + h34 ; h1234 = h12 + h34 ! Find 3 reciprocals with a single division for efficiency. @@ -788,9 +771,8 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 h0h1 = h0 * h1 ; h0_2 = h0 * h0 ; h1_2 = h1 * h1 h0_3 = h0_2 * h0 ; h1_3 = h1_2 * h1 - I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + h0*h1*(h0 + h1)) - ! Set the tridiagonal coefficients + I_d = 1.0 / (4.0 * h0h1 * ( h0 + h1 ) + h1_3 + h0_3) ! = 1 / ((h0 + h1)**3 + h0*h1*(h0 + h1)) tri_l(i+1) = (h1 * ((h0_2 + h0h1) - h1_2)) * I_d ! tri_d(i+1) = 1.0 tri_c(i+1) = 2.0 * ((h0_2 + h1_2) * (h0 + h1)) * I_d @@ -822,11 +804,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 tri_b(1) = evaluation_polynomial( Dsys, 3, x(1) ) ! Set the first edge slope tri_d(1) = 1.0 else ! Use expressions with less sensitivity to roundoff - h_min = max( hNeglect, hMinFrac * ((h(1) + h(2)) + (h(3) + h(4))) ) - do i=1,4 - dz(i) = max(h_min, h(i) ) - u_tmp(i) = u(i) - enddo + do i=1,4 ; dz(i) = max(hNeglect, h(i) ) ; u_tmp(i) = u(i) ; enddo call end_value_h4(dz, u_tmp, Csys) ! Set the first edge slope @@ -854,11 +832,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 else ! Use expressions with less sensitivity to roundoff, including using a coordinate ! system that sets the origin at the last interface in the domain. - h_min = max( hNeglect, hMinFrac * ((h(N-3) + h(N-2)) + (h(N-1) + h(N))) ) - do i=1,4 - dz(i) = max(h_min, h(N+1-i) ) - u_tmp(i) = u(N+1-i) - enddo + do i=1,4 ; dz(i) = max(hNeglect, h(N+1-i) ) ; u_tmp(i) = u(N+1-i) ; enddo call end_value_h4(dz, u_tmp, Csys) @@ -945,7 +919,6 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 real :: dx, xavg ! Differences and averages of successive values of x [same units as h] real, dimension(6,6) :: Asys ! matrix used to find boundary conditions real, dimension(6) :: Bsys, Csys ! ... - real, dimension(5) :: Dsys ! derivative real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) tri_d, & ! trid. system (middle diagonal) tri_u, & ! trid. system (upper diagonal) From 626bc2feba553248145ef0134854e27d42dc3005 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jan 2020 13:55:33 -0500 Subject: [PATCH 13/15] +Add optional argument tol to test_answers Allow for a finite tolerance in tests in test_answer. This is needed because (1./3. + 2./3.) is only equal to 1 to within a tolerance of order 10^-15. --- src/ALE/MOM_remapping.F90 | 31 +++++++++++++++++++------------ 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index d886015115..6255a6fce8 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -1810,9 +1810,11 @@ logical function remapping_unit_tests(verbose) call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & h_neglect=1e-10, answers_2018=answers_2018 ) - ! The next two tests currently fail due to roundoff. - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges') - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges') + ! The next two tests currently fail due to roundoff, but pass when given a reasonable tolerance. + thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) + remapping_unit_tests = remapping_unit_tests .or. thisTest + thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) + remapping_unit_tests = remapping_unit_tests .or. thisTest ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & @@ -1826,9 +1828,11 @@ logical function remapping_unit_tests(verbose) call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & h_neglect=1e-10, answers_2018=answers_2018 ) - ! The next two tests currently fail due to roundoff. - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges') - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges') + ! The next two tests are now passing when answers_2018 = .false., but otherwise only work to roundoff. + thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) + remapping_unit_tests = remapping_unit_tests .or. thisTest + thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) + remapping_unit_tests = remapping_unit_tests .or. thisTest ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & @@ -1878,23 +1882,26 @@ logical function remapping_unit_tests(verbose) end function remapping_unit_tests !> Returns true if any cell of u and u_true are not identical. Returns false otherwise. -logical function test_answer(verbose, n, u, u_true, label) +logical function test_answer(verbose, n, u, u_true, label, tol) logical, intent(in) :: verbose !< If true, write results to stdout - integer, intent(in) :: n !< Number of cells in u - real, dimension(n), intent(in) :: u !< Values to test + integer, intent(in) :: n !< Number of cells in u + real, dimension(n), intent(in) :: u !< Values to test real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) - character(len=*), intent(in) :: label !< Message + character(len=*), intent(in) :: label !< Message + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true ! Local variables + real :: tolerance ! The tolerance for differences between u and u_true integer :: k + tolerance = 0.0 ; if (present(tol)) tolerance = tol test_answer = .false. do k = 1, n - if (u(k) /= u_true(k)) test_answer = .true. + if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. enddo if (test_answer .or. verbose) then write(*,'(a4,2a24,x,a)') 'k','Calculated value','Correct value',label do k = 1, n - if (u(k) /= u_true(k)) then + if (abs(u(k) - u_true(k)) > tolerance) then write(*,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' else write(*,'(i4,1p2e24.16)') k,u(k),u_true(k) From 4d0833c6d9b7123d359b126f8c16ea1d489de244 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jan 2020 13:58:16 -0500 Subject: [PATCH 14/15] (*)Minor refactoring of edge_values_explicit_h4 Mathematically equivalent refactoring of edge_values_explicit_h4 when REMAPPING_2018_ANSWERS is false. These new expressions should exhibit smaller errors from roundoff, but are mathematically equivalent to the previous forms. All answers in the existing MOM6-examples test cases are bitwise identical. --- src/ALE/regrid_edge_values.F90 | 40 ++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index f262b8015d..4f7833a2d8 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -228,12 +228,14 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables - integer :: i, j - real :: h0, h1, h2, h3 ! temporary thicknesses [H] - real :: h_sum ! A sum of adjacent thicknesses [H] - real :: h_min ! A minimal cell width [H] - real :: f1, f2, f3 ! auxiliary variables with various units - real :: et1, et2, et3 ! terms the expresson for edge values [A H] + real :: h0, h1, h2, h3 ! temporary thicknesses [H] + real :: h_sum ! A sum of adjacent thicknesses [H] + real :: h_min ! A minimal cell width [H] + real :: f1, f2, f3 ! auxiliary variables with various units + real :: et1, et2, et3 ! terms the expresson for edge values [A H] + real :: I_h12 ! The inverse of the sum of the two central thicknesses [H-1] + real :: I_h012, I_h123 ! Inverses of sums of three succesive thicknesses [H-1] + real :: I_den_et2, I_den_et3 ! Inverses of denominators in edge value terms [H-2] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] @@ -242,6 +244,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real, dimension(4,4) :: A ! values near the boundaries real, dimension(4) :: B, C real :: hNeglect ! A negligible thickness in the same units as h. + integer :: i, j logical :: use_2018_answers ! If true use older, less acccurate expressions. use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 @@ -277,21 +280,20 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) f2 = h2 * u(i-1) + h1 * u(i) f3 = 1.0 / (h0+h1+h2) + 1.0 / (h1+h2+h3) et1 = f1 * f2 * f3 - else - et1 = ( (h0+h1) * (h2+h3) * ((h1+h2+h3) + (h0+h1+h2)) / & - (((h1+h2) * ((h0+h1+h2) * (h1+h2+h3)))) ) * & - (h2 * u(i-1) + h1 * u(i)) - endif - - et2 = ( h2 * (h2+h3) / ( (h0+h1+h2)*(h0+h1) ) ) * & - ((h0+2.0*h1) * u(i-1) - h1 * u(i-2)) - - et3 = ( h1 * (h0+h1) / ( (h1+h2+h3)*(h2+h3) ) ) * & - ((2.0*h2+h3) * u(i) - h2 * u(i+1)) - - if (use_2018_answers) then + et2 = ( h2 * (h2+h3) / ( (h0+h1+h2)*(h0+h1) ) ) * & + ((h0+2.0*h1) * u(i-1) - h1 * u(i-2)) + et3 = ( h1 * (h0+h1) / ( (h1+h2+h3)*(h2+h3) ) ) * & + ((2.0*h2+h3) * u(i) - h2 * u(i+1)) edge_val(i,1) = (et1 + et2 + et3) / ( h0 + h1 + h2 + h3) else + I_h12 = 1.0 / (h1+h2) + I_den_et2 = 1.0 / ( ((h0+h1)+h2)*(h0+h1) ) ; I_h012 = (h0+h1) * I_den_et2 + I_den_et3 = 1.0 / ( (h1+(h2+h3))*(h2+h3) ) ; I_h123 = (h2+h3) * I_den_et3 + + et1 = ( 1.0 + (h1 * I_h012 + (h0+h1) * I_h123) ) * I_h12 * (h2*(h2+h3)) * u(i-1) + & + ( 1.0 + (h2 * I_h123 + (h2+h3) * I_h012) ) * I_h12 * (h1*(h0+h1)) * u(i) + et2 = ( h1 * (h2*(h2+h3)) * I_den_et2 ) * (u(i-1)-u(i-2)) + et3 = ( h2 * (h1*(h0+h1)) * I_den_et3 ) * (u(i) - u(i+1)) edge_val(i,1) = (et1 + (et2 + et3)) / ((h0 + h1) + (h2 + h3)) endif edge_val(i-1,2) = edge_val(i,1) From f94dd0c9c41dd138e93237c0402874c1d8700a64 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Jan 2020 17:05:05 -0500 Subject: [PATCH 15/15] Added dOxygen comments to test_line Added the missing dOxygen comments to the debugging routine test_line in regrid_edge_values.F90. All answers are bitwise identical. --- src/ALE/regrid_edge_values.F90 | 26 ++++++++++++-------------- 1 file changed, 12 insertions(+), 14 deletions(-) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 4f7833a2d8..46570b26b9 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -658,7 +658,7 @@ subroutine end_value_h4(dz, u, Csys) ! Atest(4) = zavg * (zavg**2 + 0.25*dz(i)**2) ! = ( (z(i+1)**4) - (z(i)**4) ) / (4*dz(i)) ! c_mag = 1.0 ; do k=0,3 ; do j=1,3 ; c_mag = c_mag + abs(Wt(j,k+1) * zavg**k) ; enddo ; enddo ! write(mesg, '("end_value_h4 line ", i2, " c_mag = ", es10.2, " u_mag = ", es10.2)') i, c_mag, u_mag -! call test_line(mesg, 4, Atest, Csys, u(i), u_mag*c_mag, tolerance=1.0e-15) +! call test_line(mesg, 4, Atest, Csys, u(i), u_mag*c_mag, tol=1.0e-15) ! enddo end subroutine end_value_h4 @@ -1440,36 +1440,34 @@ end subroutine linear_solver -! Verify that A*C = R to within roundoff. -subroutine test_line(msg, N, A, C, R, mag, tolerance) - integer, intent(in) :: N - real, dimension(4), intent(in) :: A - real, dimension(4), intent(in) :: C - real, intent(in) :: R +!> Test that A*C = R to within a tolerance, issuing a fatal error with an explanatory message if they do not. +subroutine test_line(msg, N, A, C, R, mag, tol) real, intent(in) :: mag !< The magnitude of leading order terms in this line - real, optional, intent(in) :: tolerance - character(len=*) :: msg + integer, intent(in) :: N !< The number of points in the system + real, dimension(4), intent(in) :: A !< One of the two vectors being multiplied + real, dimension(4), intent(in) :: C !< One of the two vectors being multiplied + real, intent(in) :: R !< The expected solution of the equation + character(len=*), intent(in) :: msg !< An identifying message for this test + real, optional, intent(in) :: tol !< The fractional tolerance for the two solutions real :: sum, sum_mag - real :: tol + real :: tolerance character(len=128) :: mesg2 integer :: i - tol = 1.0e-12 ; if (present(tolerance)) tol = tolerance + tolerance = 1.0e-12 ; if (present(tol)) tolerance = tol sum = 0.0 ; sum_mag = max(0.0,mag) - do i=1,N sum = sum + A(i) * C(i) sum_mag = sum_mag + abs(A(i) * C(i)) enddo - if (abs(sum - R) > tol * (sum_mag + abs(R))) then + if (abs(sum - R) > tolerance * (sum_mag + abs(R))) then write(mesg2, '(", Fractional error = ", es12.4,", sum = ", es12.4)') (sum - R) / (sum_mag + abs(R)), sum call MOM_error(FATAL, "Failed line test: "//trim(msg)//trim(mesg2)) endif end subroutine test_line - end module regrid_edge_values