! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     https://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

module curve

  use, intrinsic :: iso_c_binding, only: c_double, c_int, c_bool
  use types, only: dp
  use helpers, only: cross_product, contains_nd
  use quadpack, only: dqagse
  implicit none
  private &
       MAX_LOCATE_SUBDIVISIONS, LOCATE_STD_CAP, &
       SQRT_PREC, REDUCE_THRESHOLD, &
       specialize_curve_generic, specialize_curve_quadratic, &
       subdivide_nodes_generic, split_candidate, allocate_candidates, &
       update_candidates, projection_error, can_reduce
  public &
       CurveData, LOCATE_MISS, LOCATE_INVALID, evaluate_curve_vs, &
       evaluate_curve_de_casteljau, evaluate_curve_barycentric, &
       evaluate_multi, specialize_curve, evaluate_hodograph, subdivide_nodes, &
       newton_refine, locate_point, elevate_nodes, get_curvature, &
       reduce_pseudo_inverse, full_reduce, compute_length, curves_equal, &
       subdivide_curve

  ! NOTE: This (for now) is not meant to be C-interoperable. This is mostly
  !       because the shape is encoded in ``nodes``, so it would be wasteful to
  !       also store ``num_nodes`` and ``dimension``. In addition,
  !       ``allocatable`` (rather than ``type(c_ptr)``) is used for the
  !       ``nodes`` so that the data is scoped with the ``CurveData`` instance
  !       and we don't need to worry about memory management.
  type :: CurveData
     real(c_double) :: start = 0.0_dp
     real(c_double) :: end_ = 1.0_dp
     real(c_double), allocatable :: nodes(:, :)
  end type CurveData

  ! NOTE: These values are also defined in equivalent Python source.
  integer(c_int), parameter :: MAX_LOCATE_SUBDIVISIONS = 20
  real(c_double), parameter :: LOCATE_STD_CAP = 0.5_dp**20
  ! NOTE: Should probably use ``d1mach`` to determine ``SQRT_PREC``.
  real(c_double), parameter :: SQRT_PREC = 0.5_dp**26
  real(c_double), parameter :: REDUCE_THRESHOLD = SQRT_PREC
  real(c_double), parameter :: LOCATE_MISS = -1
  real(c_double), parameter :: LOCATE_INVALID = -2

contains

  subroutine evaluate_curve_vs( &
       num_nodes, dimension_, nodes, num_vals, lambda1, lambda2, evaluated)

    ! NOTE: This is evaluate_multi_vs for a Bezier curve.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: num_vals
    real(c_double), intent(in) :: lambda1(num_vals)
    real(c_double), intent(in) :: lambda2(num_vals)
    real(c_double), intent(out) :: evaluated(dimension_, num_vals)
    ! Variables outside of signature.
    integer(c_int) :: i, j
    real(c_double) :: lambda2_pow(num_vals)
    real(c_double) :: binom_val

    lambda2_pow = 1.0_dp
    binom_val = 1

    forall (i = 1:num_vals)
       evaluated(:, i) = lambda1(i) * nodes(:, 1)
    end forall

    do i = 2, num_nodes - 1
       lambda2_pow = lambda2_pow * lambda2
       binom_val = (binom_val * (num_nodes - i + 1)) / (i - 1)
       forall (j = 1:num_vals)
          evaluated(:, j) = ( &
               evaluated(:, j) + &
               binom_val * lambda2_pow(j) * nodes(:, i)) * lambda1(j)
       end forall
    end do

    forall (i = 1:num_vals)
       evaluated(:, i) = ( &
            evaluated(:, i) + &
            lambda2_pow(i) * lambda2(i) * nodes(:, num_nodes))
    end forall

  end subroutine evaluate_curve_vs

  subroutine evaluate_curve_de_casteljau( &
       num_nodes, dimension_, nodes, num_vals, lambda1, lambda2, evaluated)

    ! NOTE: This is evaluate_multi_de_casteljau for a Bezier curve.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: num_vals
    real(c_double), intent(in) :: lambda1(num_vals)
    real(c_double), intent(in) :: lambda2(num_vals)
    real(c_double), intent(out) :: evaluated(dimension_, num_vals)
    ! Variables outside of signature.
    integer(c_int) :: i
    real(c_double) :: lambda1_wide(dimension_, num_vals, num_nodes - 1)
    real(c_double) :: lambda2_wide(dimension_, num_vals, num_nodes - 1)
    real(c_double) :: workspace(dimension_, num_vals, num_nodes - 1)

    forall (i = 1:num_vals)
       lambda1_wide(:, i, :) = lambda1(i)
       lambda2_wide(:, i, :) = lambda2(i)
       workspace(:, i, :) = ( &
            lambda1(i) * nodes(:, :num_nodes - 1) + lambda2(i) * nodes(:, 2:))
    end forall

    do i = num_nodes - 2, 1, -1
       workspace(:, :, :i) = ( &
            lambda1_wide(:, :, :i) * workspace(:, :, :i) + &
            lambda2_wide(:, :, :i) * workspace(:, :, 2:(i+1)))
    end do

    evaluated = workspace(:, :, 1)

  end subroutine evaluate_curve_de_casteljau

  subroutine evaluate_curve_barycentric( &
       num_nodes, dimension_, nodes, num_vals, lambda1, lambda2, evaluated) &
       bind(c, name='BEZ_evaluate_curve_barycentric')

    ! NOTE: This is evaluate_multi_barycentric for a Bezier curve.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: num_vals
    real(c_double), intent(in) :: lambda1(num_vals)
    real(c_double), intent(in) :: lambda2(num_vals)
    real(c_double), intent(out) :: evaluated(dimension_, num_vals)

    if (num_nodes > 55) then
       call evaluate_curve_de_casteljau( &
            num_nodes, dimension_, nodes, num_vals, lambda1, lambda2, evaluated)
       return
    end if

    call evaluate_curve_vs( &
         num_nodes, dimension_, nodes, num_vals, lambda1, lambda2, evaluated)
  end subroutine evaluate_curve_barycentric

  subroutine evaluate_multi( &
       num_nodes, dimension_, nodes, num_vals, s_vals, evaluated) &
       bind(c, name='BEZ_evaluate_multi')

    ! NOTE: This is evaluate_multi for a Bezier curve.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: num_vals
    real(c_double), intent(in) :: s_vals(num_vals)
    real(c_double), intent(out) :: evaluated(dimension_, num_vals)
    ! Variables outside of signature.
    real(c_double) :: one_less(num_vals)

    one_less = 1.0_dp - s_vals
    call evaluate_curve_barycentric( &
         num_nodes, dimension_, nodes, num_vals, one_less, s_vals, evaluated)
  end subroutine evaluate_multi

  subroutine specialize_curve_generic( &
       num_nodes, dimension_, nodes, start, end_, new_nodes)

    ! NOTE: This is a helper for ``specialize_curve`` that works on any degree.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(in) :: start, end_
    real(c_double), intent(out) :: new_nodes(dimension_, num_nodes)
    ! Variables outside of signature.
    real(c_double) :: workspace(dimension_, num_nodes - 1, num_nodes)
    integer(c_int) :: index_, curr_size, j
    real(c_double) :: minus_start, minus_end

    minus_start = 1.0_dp - start
    minus_end = 1.0_dp - end_
    workspace(:, :, 1) = ( &
         minus_start * nodes(:, :num_nodes - 1) + start * nodes(:, 2:))
    workspace(:, :, 2) = ( &
         minus_end * nodes(:, :num_nodes - 1) + end_ * nodes(:, 2:))

    curr_size = num_nodes - 1
    do index_ = 3, num_nodes
       curr_size = curr_size - 1
       ! First add a new "column" (or whatever the 3rd dimension is called)
       ! at the end using ``end_``.
       workspace(:, :curr_size, index_) = ( &
            minus_end * workspace(:, :curr_size, index_ - 1) + &
            end_ * workspace(:, 2:curr_size + 1, index_ - 1))
       ! Update all the values in place by using de Casteljau with the
       ! ``start`` parameter.
       forall (j = 1:index_ - 1)
          workspace(:, :curr_size, j) = ( &
               minus_start * workspace(:, :curr_size, j) + &
               start * workspace(:, 2:curr_size + 1, j))
       end forall
    end do

    ! Move the final "column" (or whatever the 3rd dimension is called)
    ! of the workspace into ``new_nodes``.
    forall (index_ = 1:num_nodes)
       new_nodes(:, index_) = workspace(:, 1, index_)
    end forall

  end subroutine specialize_curve_generic

  subroutine specialize_curve_quadratic( &
       dimension_, nodes, start, end_, new_nodes)

    integer(c_int), intent(in) :: dimension_
    real(c_double), intent(in) :: nodes(dimension_, 3)
    real(c_double), intent(in) :: start, end_
    real(c_double), intent(out) :: new_nodes(dimension_, 3)
    ! Variables outside of signature.
    real(c_double) :: minus_start, minus_end, prod_both

    minus_start = 1.0_dp - start
    minus_end = 1.0_dp - end_
    prod_both = start * end_

    new_nodes(:, 1) = ( &
         minus_start * minus_start * nodes(:, 1) + &
         2.0_dp * start * minus_start * nodes(:, 2) + &
         start * start * nodes(:, 3))
    new_nodes(:, 2) = ( &
         minus_start * minus_end * nodes(:, 1) + &
         (end_ + start - 2.0_dp * prod_both) * nodes(:, 2) + &
         prod_both * nodes(:, 3))
    new_nodes(:, 3) = ( &
         minus_end * minus_end * nodes(:, 1) + &
         2.0_dp * end_ * minus_end * nodes(:, 2) + &
         end_ * end_ * nodes(:, 3))

  end subroutine specialize_curve_quadratic

  subroutine specialize_curve( &
       num_nodes, dimension_, nodes, start, end_, new_nodes) &
       bind(c, name='BEZ_specialize_curve')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(in) :: start, end_
    real(c_double), intent(out) :: new_nodes(dimension_, num_nodes)

    if (num_nodes == 2) then
       new_nodes(:, 1) = (1.0_dp - start) * nodes(:, 1) + start * nodes(:, 2)
       new_nodes(:, 2) = (1.0_dp - end_) * nodes(:, 1) + end_ * nodes(:, 2)
    else if (num_nodes == 3) then
       call specialize_curve_quadratic( &
            dimension_, nodes, start, end_, new_nodes)
    else
       call specialize_curve_generic( &
            num_nodes, dimension_, nodes, start, end_, new_nodes)
    end if

  end subroutine specialize_curve

  subroutine evaluate_hodograph( &
       s, num_nodes, dimension_, nodes, hodograph) &
       bind(c, name='BEZ_evaluate_hodograph')

    real(c_double), intent(in) :: s
    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(out) :: hodograph(dimension_, 1)
    ! Variables outside of signature.
    real(c_double) :: first_deriv(dimension_, num_nodes - 1)

    first_deriv = nodes(:, 2:) - nodes(:, :num_nodes - 1)
    call evaluate_multi( &
         num_nodes - 1, dimension_, first_deriv, 1, [s], hodograph)
    hodograph = (num_nodes - 1) * hodograph

  end subroutine evaluate_hodograph

  subroutine subdivide_nodes_generic( &
       num_nodes, dimension_, nodes, left_nodes, right_nodes)

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(out) :: left_nodes(dimension_, num_nodes)
    real(c_double), intent(out) :: right_nodes(dimension_, num_nodes)
    ! Variables outside of signature.
    real(c_double) :: pascals_triangle(num_nodes)
    integer(c_int) :: elt_index, pascal_index

    pascals_triangle = 0  ! Make sure all zero.
    pascals_triangle(1) = 1

    do elt_index = 1, num_nodes
       ! Update Pascal's triangle (intentionally at beginning, not end).
       if (elt_index > 1) then
          pascals_triangle(:elt_index) = 0.5_dp * ( &
               pascals_triangle(:elt_index) + pascals_triangle(elt_index:1:-1))
       end if

       left_nodes(:, elt_index) = 0
       right_nodes(:, num_nodes + 1 - elt_index) = 0
       do pascal_index = 1, elt_index
          left_nodes(:, elt_index) = ( &
               left_nodes(:, elt_index) + &
               pascals_triangle(pascal_index) * nodes(:, pascal_index))
          right_nodes(:, num_nodes + 1 - elt_index) = ( &
               right_nodes(:, num_nodes + 1 - elt_index) + &
               pascals_triangle(pascal_index) * &
               nodes(:, num_nodes + 1 - pascal_index))
       end do
    end do

  end subroutine subdivide_nodes_generic

  subroutine subdivide_nodes( &
       num_nodes, dimension_, nodes, left_nodes, right_nodes) &
       bind(c, name='BEZ_subdivide_nodes_curve')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(out) :: left_nodes(dimension_, num_nodes)
    real(c_double), intent(out) :: right_nodes(dimension_, num_nodes)

    if (num_nodes == 2) then
       left_nodes(:, 1) = nodes(:, 1)
       left_nodes(:, 2) = 0.5_dp * (nodes(:, 1) + nodes(:, 2))
       right_nodes(:, 1) = left_nodes(:, 2)
       right_nodes(:, 2) = nodes(:, 2)
    else if (num_nodes == 3) then
       left_nodes(:, 1) = nodes(:, 1)
       left_nodes(:, 2) = 0.5_dp * (nodes(:, 1) + nodes(:, 2))
       left_nodes(:, 3) = 0.25_dp * ( &
            nodes(:, 1) + 2 * nodes(:, 2) + nodes(:, 3))
       right_nodes(:, 1) = left_nodes(:, 3)
       right_nodes(:, 2) = 0.5_dp * (nodes(:, 2) + nodes(:, 3))
       right_nodes(:, 3) = nodes(:, 3)
    else if (num_nodes == 4) then
       left_nodes(:, 1) = nodes(:, 1)
       left_nodes(:, 2) = 0.5_dp * (nodes(:, 1) + nodes(:, 2))
       left_nodes(:, 3) = 0.25_dp * ( &
            nodes(:, 1) + 2 * nodes(:, 2) + nodes(:, 3))
       left_nodes(:, 4) = 0.125_dp * ( &
            nodes(:, 1) + 3 * nodes(:, 2) + 3 * nodes(:, 3) + nodes(:, 4))
       right_nodes(:, 1) = left_nodes(:, 4)
       right_nodes(:, 2) = 0.25_dp * ( &
            nodes(:, 2) + 2 * nodes(:, 3) + nodes(:, 4))
       right_nodes(:, 3) = 0.5_dp * (nodes(:, 3) + nodes(:, 4))
       right_nodes(:, 4) = nodes(:, 4)
    else
       call subdivide_nodes_generic( &
            num_nodes, dimension_, nodes, left_nodes, right_nodes)
    end if

  end subroutine subdivide_nodes

  subroutine newton_refine( &
       num_nodes, dimension_, nodes, point, s, updated_s) &
       bind(c, name='BEZ_newton_refine_curve')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(in) :: point(dimension_, 1)
    real(c_double), intent(in) :: s
    real(c_double), intent(out) :: updated_s
    ! Variables outside of signature.
    real(c_double) :: pt_delta(dimension_, 1)
    real(c_double) :: derivative(dimension_, 1)

    call evaluate_multi( &
         num_nodes, dimension_, nodes, 1, [s], pt_delta)
    pt_delta = point - pt_delta
    ! At this point `pt_delta` is `p - B(s)`.
    call evaluate_hodograph( &
         s, num_nodes, dimension_, nodes, derivative)

    updated_s = ( &
         s + &
         (dot_product(pt_delta(:, 1), derivative(:, 1)) / &
         dot_product(derivative(:, 1), derivative(:, 1))))

  end subroutine newton_refine

  subroutine split_candidate( &
       num_nodes, dimension_, candidate, num_next_candidates, next_candidates)

    integer(c_int), intent(in) :: num_nodes, dimension_
    type(CurveData), intent(in) :: candidate
    integer(c_int), intent(in) :: num_next_candidates
    type(CurveData), intent(inout) :: next_candidates(:)

    ! Allocate the new nodes and call sub-divide.
    ! NOTE: This **assumes** but does not check that if the nodes are
    !       allocated, they are also the correct shape.
    if (.NOT. allocated(next_candidates(num_next_candidates - 1)%nodes)) then
       allocate(next_candidates(num_next_candidates - 1)%nodes(dimension_, num_nodes))
    end if
    if (.NOT. allocated(next_candidates(num_next_candidates)%nodes)) then
       allocate(next_candidates(num_next_candidates)%nodes(dimension_, num_nodes))
    end if

    call subdivide_nodes( &
         num_nodes, dimension_, candidate%nodes, &
         next_candidates(num_next_candidates - 1)%nodes, &
         next_candidates(num_next_candidates)%nodes)

    ! Left half.
    next_candidates(num_next_candidates - 1)%start = candidate%start
    next_candidates(num_next_candidates - 1)%end_ = ( &
         0.5_dp * (candidate%start + candidate%end_))
    ! Right half.
    next_candidates(num_next_candidates)%start = ( &
         next_candidates(num_next_candidates - 1)%end_)
    next_candidates(num_next_candidates)%end_ = candidate%end_

  end subroutine split_candidate

  subroutine allocate_candidates(num_candidates, next_candidates)
    integer(c_int), intent(in) :: num_candidates
    type(CurveData), allocatable, intent(inout) :: next_candidates(:)

    if (allocated(next_candidates)) then
       if (size(next_candidates) < 2 * num_candidates) then
          deallocate(next_candidates)
          allocate(next_candidates(2 * num_candidates))
       end if
    else
       allocate(next_candidates(2 * num_candidates))
    end if

  end subroutine allocate_candidates

  subroutine update_candidates( &
       num_nodes, dimension_, point, num_candidates, candidates, &
       num_next_candidates, next_candidates)

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: point(dimension_, 1)
    integer(c_int), intent(in) :: num_candidates
    type(CurveData), intent(in) :: candidates(:)
    integer(c_int), intent(inout) :: num_next_candidates
    type(CurveData), allocatable, intent(inout) :: next_candidates(:)
    ! Variables outside of signature.
    integer(c_int) :: cand_index
    logical(c_bool) :: predicate

    ! Allocate maximum amount of space needed.
    call allocate_candidates(num_candidates, next_candidates)

    do cand_index = 1, num_candidates
       call contains_nd( &
            num_nodes, dimension_, candidates(cand_index)%nodes, &
            point(:, 1), predicate)
       if (predicate) then
          num_next_candidates = num_next_candidates + 2
          call split_candidate( &
               num_nodes, dimension_, candidates(cand_index), &
               num_next_candidates, next_candidates)
       end if
    end do

  end subroutine update_candidates

  subroutine locate_point( &
       num_nodes, dimension_, nodes, point, s_approx) &
       bind(c, name='BEZ_locate_point_curve')

    ! NOTE: This returns ``-1`` (``LOCATE_MISS``) as a signal for "point is
    !       not on the curve" and ``-2`` (``LOCATE_INVALID``) for "point is
    !       on separate segments" (i.e. the standard deviation of the
    !       parameters is too large).

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(in) :: point(dimension_, 1)
    real(c_double), intent(out) :: s_approx
    ! Variables outside of signature.
    integer(c_int) :: sub_index
    integer(c_int) :: num_candidates, num_next_candidates
    type(CurveData), allocatable :: candidates_odd(:), candidates_even(:)
    real(c_double), allocatable :: s_params(:)
    real(c_double) :: std_dev
    logical(c_bool) :: is_even

    ! Start out with the full curve.
    allocate(candidates_odd(1))  ! First iteration is odd.
    candidates_odd(1) = CurveData(0.0_dp, 1.0_dp, nodes)
    ! NOTE: `num_candidates` will be tracked separately
    !       from `size(candidates)`.
    num_candidates = 1
    s_approx = LOCATE_MISS

    is_even = .TRUE.  ! At zero.
    do sub_index = 1, MAX_LOCATE_SUBDIVISIONS + 1
       is_even = .NOT. is_even  ! Switch parity.
       num_next_candidates = 0

       if (is_even) then
          ! Read from even, write to odd.
          call update_candidates( &
               num_nodes, dimension_, point, num_candidates, candidates_even, &
               num_next_candidates, candidates_odd)
       else
          ! Read from odd, write to even.
          call update_candidates( &
               num_nodes, dimension_, point, num_candidates, candidates_odd, &
               num_next_candidates, candidates_even)
       end if

       ! If there are no more candidates, we are done.
       if (num_next_candidates == 0) then
          return
       end if

       num_candidates = num_next_candidates

    end do

    ! Compute the s-parameter as the mean of the **start** and
    ! **end** parameters.
    allocate(s_params(2 * num_candidates))
    if (is_even) then
       ! NOTE: We "exclude" this block from ``lcov`` because it can never
       !       be invoked while ``MAX_LOCATE_SUBDIVISIONS`` is even.
       ! LCOV_EXCL_START
       s_params(:num_candidates) = ( &
            candidates_odd(:num_candidates)%start)
       s_params(num_candidates + 1:) = ( &
            candidates_odd(:num_candidates)%end_)
       ! LCOV_EXCL_STOP
    else
       s_params(:num_candidates) = candidates_even(:num_candidates)%start
       s_params(num_candidates + 1:) = candidates_even(:num_candidates)%end_
    end if
    s_approx = sum(s_params) / (2 * num_candidates)

    std_dev = sqrt(sum((s_params - s_approx)**2) / (2 * num_candidates))
    if (std_dev > LOCATE_STD_CAP) then
       s_approx = LOCATE_INVALID
       return
    end if

    ! NOTE: Use ``std_dev`` variable as a "placeholder" for the update.
    call newton_refine( &
         num_nodes, dimension_, nodes, point, s_approx, std_dev)
    ! NOTE: Since ``mean(s_params)`` must be in ``[0, 1]`` it's
    !       "safe" to push the Newton-refined value back into the unit
    !       interval.
    if (std_dev < 0.0_dp) then
       s_approx = 0.0_dp
    else if (std_dev > 1.0_dp) then
       s_approx = 1.0_dp
    else
       s_approx = std_dev
    end if

  end subroutine locate_point

  subroutine elevate_nodes( &
       num_nodes, dimension_, nodes, elevated) &
       bind(c, name='BEZ_elevate_nodes_curve')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(out) :: elevated(dimension_, num_nodes + 1)
    ! Variables outside of signature.
    integer(c_int) :: i

    elevated(:, 1) = nodes(:, 1)
    forall (i = 1:num_nodes - 1)
       elevated(:, i + 1) = ( &
            i * nodes(:, i) + (num_nodes - i) * nodes(:, i + 1)) / num_nodes
    end forall
    elevated(:, num_nodes + 1) = nodes(:, num_nodes)

  end subroutine elevate_nodes

  subroutine get_curvature( &
       num_nodes, nodes, tangent_vec, s, curvature) &
       bind(c, name='BEZ_get_curvature')

    ! NOTE: This **only** computes curvature for plane curves (i.e. curves
    !       in R^2). An equivalent notion of curvature exists for space
    !       curves, but support for that is not implemented here.

    integer(c_int), intent(in) :: num_nodes
    real(c_double), intent(in) :: nodes(2, num_nodes)
    real(c_double), intent(in) :: tangent_vec(2, 1)
    real(c_double), intent(in) :: s
    real(c_double), intent(out) :: curvature
    ! Variables outside of signature.
    real(c_double) :: work(2, num_nodes - 1)
    real(c_double) :: concavity(2, 1)

    if (num_nodes == 2) then
       curvature = 0
       return
    end if

    ! NOTE: We somewhat replicate code in ``evaluate_hodograph()`` here.

    ! First derivative:
    work = nodes(:, 2:) - nodes(:, :num_nodes - 1)
    ! Second derivative (no need for last element of work array):
    work(:, :num_nodes - 2) = work(:, 2:) - work(:, :num_nodes - 2)

    ! NOTE: The degree being evaluated is ``degree - 2 == num_nodes - 3``.
    call evaluate_multi( &
         num_nodes - 2, 2, work(:, :num_nodes - 2), 1, [s], concavity)
    ! B''(s) = d (d - 1) D(s) where D(s) is defined by the "double hodograph".
    concavity = concavity * (num_nodes - 1) * (num_nodes - 2)

    call cross_product(tangent_vec, concavity, curvature)
    curvature = curvature / norm2(tangent_vec)**3

  end subroutine get_curvature

  subroutine reduce_pseudo_inverse( &
       num_nodes, dimension_, nodes, reduced, not_implemented) &
       bind(c, name='BEZ_reduce_pseudo_inverse')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(out) :: reduced(dimension_, num_nodes - 1)
    logical(c_bool), intent(out) :: not_implemented

    not_implemented = .FALSE.
    if (num_nodes == 2) then
       reduced(:, 1) = 0.5_dp * (nodes(:, 1) + nodes(:, 2))
    else if (num_nodes == 3) then
       reduced(:, 1) = (5 * nodes(:, 1) + 2 * nodes(:, 2) - nodes(:, 3)) / 6
       reduced(:, 2) = (-nodes(:, 1) + 2 * nodes(:, 2) + 5 * nodes(:, 3)) / 6
    else if (num_nodes == 4) then
       reduced(:, 1) = ( &
            19 * nodes(:, 1) + 3 * nodes(:, 2) - &
            3 * nodes(:, 3) + nodes(:, 4)) / 20
       reduced(:, 2) = 0.25_dp * ( &
            -nodes(:, 1) + 3 * nodes(:, 2) + &
            3 * nodes(:, 3) - nodes(:, 4))
       reduced(:, 3) = ( &
            nodes(:, 1) - 3 * nodes(:, 2) + &
            3 * nodes(:, 3) + 19 * nodes(:, 4)) / 20
    else if (num_nodes == 5) then
       reduced(:, 1) = ( &
            69 * nodes(:, 1) + 4 * nodes(:, 2) - 6 * nodes(:, 3) + &
            4 * nodes(:, 4) - nodes(:, 5)) / 70
       reduced(:, 2) = ( &
            -53 * nodes(:, 1) + 212 * nodes(:, 2) + 102 * nodes(:, 3) - &
            68 * nodes(:, 4) + 17 * nodes(:, 5)) / 210
       reduced(:, 3) = ( &
            17 * nodes(:, 1) - 68 * nodes(:, 2) + 102 * nodes(:, 3) + &
            212 * nodes(:, 4) - 53 * nodes(:, 5)) / 210
       reduced(:, 4) = ( &
            -nodes(:, 1) + 4 * nodes(:, 2) - 6 * nodes(:, 3) + &
            4 * nodes(:, 4) + 69 * nodes(:, 5)) / 70
    else
       not_implemented = .TRUE.
    end if

  end subroutine reduce_pseudo_inverse

  subroutine projection_error( &
       num_nodes, dimension_, nodes, projected, error)

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(in) :: projected(dimension_, num_nodes)
    real(c_double), intent(out) :: error

    ! If "dim" is not passed to ``norm2``, will be Frobenius norm.
    error = norm2(nodes - projected)
    if (error == 0.0_dp) then
       return
    end if

    ! Make the error relative (in Frobenius norm).
    error = error / norm2(nodes)

  end subroutine projection_error

  subroutine can_reduce( &
       num_nodes, dimension_, nodes, success)

    ! NOTE: This returns ``success = 0`` for "Failure", ``success = 1`` for
    !       "Success" and ``success = -1`` for "Not Implemented".
    ! NOTE: This subroutine is not part of the C ABI for this module,
    !       but it is (for now) public, so that it can be tested.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(out) :: success
    ! Variables outside of signature.
    real(c_double) :: reduced(dimension_, num_nodes)
    real(c_double) :: relative_err

    if (num_nodes < 2 .OR. num_nodes > 5) then
       ! The only caller `full_reduce` will never try to reduce a point
       ! (i.e. `num_nodes == `). So these cases (along with higher degre
       ! than quartics) are "Not Implemented".
       success = -1
       return
    end if

    ! First, put the "projection" in ``reduced``.
    if (num_nodes == 2) then
       reduced(:, 1) = 0.5_dp * (nodes(:, 1) + nodes(:, 2))
       reduced(:, 2) = reduced(:, 1)
    else if (num_nodes == 3) then
       reduced(:, 1) = (5 * nodes(:, 1) + 2 * nodes(:, 2) - nodes(:, 3)) / 6
       reduced(:, 2) = (nodes(:, 1) + nodes(:, 2) + nodes(:, 3)) / 3
       reduced(:, 3) = (-nodes(:, 1) + 2 * nodes(:, 2) + 5 * nodes(:, 3)) / 6
    else if (num_nodes == 4) then
       reduced(:, 1) = ( &
            19 * nodes(:, 1) + 3 * nodes(:, 2) - &
            3 * nodes(:, 3) + nodes(:, 4)) / 20
       reduced(:, 2) = ( &
            3 * nodes(:, 1) + 11 * nodes(:, 2) + &
            9 * nodes(:, 3) - 3 * nodes(:, 4)) / 20
       reduced(:, 3) = ( &
            -3 * nodes(:, 1) + 9 * nodes(:, 2) + &
            11 * nodes(:, 3) + 3 * nodes(:, 4)) / 20
       reduced(:, 4) = ( &
            nodes(:, 1) - 3 * nodes(:, 2) + &
            3 * nodes(:, 3) + 19 * nodes(:, 4)) / 20
    else if (num_nodes == 5) then
       reduced(:, 1) = ( &
            69 * nodes(:, 1) + 4 * nodes(:, 2) - 6 * nodes(:, 3) + &
            4 * nodes(:, 4) - nodes(:, 5)) / 70
       reduced(:, 2) = ( &
            2 * nodes(:, 1) + 27 * nodes(:, 2) + 12 * nodes(:, 3) - &
            8 * nodes(:, 4) + 2 * nodes(:, 5)) / 35
       reduced(:, 3) = ( &
            -3 * nodes(:, 1) + 12 * nodes(:, 2) + 17 * nodes(:, 3) + &
            12 * nodes(:, 4) - 3 * nodes(:, 5)) / 35
       reduced(:, 4) = ( &
            2 * nodes(:, 1) - 8 * nodes(:, 2) + 12 * nodes(:, 3) + &
            27 * nodes(:, 4) + 2 * nodes(:, 5)) / 35
       reduced(:, 5) = ( &
            -nodes(:, 1) + 4 * nodes(:, 2) - 6 * nodes(:, 3) + &
            4 * nodes(:, 4) + 69 * nodes(:, 5)) / 70
    end if

    call projection_error(num_nodes, dimension_, nodes, reduced, relative_err)
    if (relative_err < REDUCE_THRESHOLD) then
       success = 1
    else
       success = 0
    end if

  end subroutine can_reduce

  subroutine full_reduce( &
       num_nodes, dimension_, nodes, num_reduced_nodes, &
       reduced, not_implemented) &
       bind(c, name='BEZ_full_reduce')

    ! NOTE: The size of ``reduced`` represents the **maximum** possible
    !       size, but ``num_reduced_nodes`` actually reflects the number
    !       of nodes in the fully reduced nodes.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(out) :: num_reduced_nodes
    real(c_double), intent(out) :: reduced(dimension_, num_nodes)
    logical(c_bool), intent(out) :: not_implemented
    ! Variables outside of signature.
    integer(c_int) :: i, cr_success
    real(c_double) :: work(dimension_, num_nodes - 1)

    reduced = nodes
    num_reduced_nodes = num_nodes
    not_implemented = .FALSE.
    ! We can make at most ``num_nodes - 1`` reductions since
    ! we can't reduce past one node (i.e. degree zero).
    do i = 1, num_nodes - 1
       call can_reduce( &
            num_reduced_nodes, dimension_, &
            reduced(:, :num_reduced_nodes), cr_success)

       if (cr_success == 1) then
          ! Actually reduce the nodes.
          call reduce_pseudo_inverse( &
               num_reduced_nodes, dimension_, reduced(:, :num_reduced_nodes), &
               work(:, :num_reduced_nodes - 1), not_implemented)
          if (not_implemented) then
             return  ! LCOV_EXCL_LINE
          else
             num_reduced_nodes = num_reduced_nodes - 1
             ! Update `reduced` based on the **new** number of nodes.
             reduced(:, :num_reduced_nodes) = work(:, :num_reduced_nodes)
          end if
       else if (cr_success == 0) then
          return
       else
          ! ``cr_success == -1`` means "Not Implemented"
          not_implemented = .TRUE.
          return
       end if
    end do

  end subroutine full_reduce

  subroutine compute_length( &
       num_nodes, dimension_, nodes, length, error_val) &
       bind(c, name='BEZ_compute_length')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    real(c_double), intent(out) :: length
    integer(c_int), intent(out) :: error_val
    ! Variables outside of signature.
    real(c_double) :: first_deriv(dimension_, num_nodes - 1)
    real(c_double) :: abserr
    integer(c_int) :: neval
    real(c_double) :: alist(50)
    real(c_double) :: blist(50)
    real(c_double) :: rlist(50)
    real(c_double) :: elist(50)
    integer(c_int) :: iord(50)
    integer(c_int) :: last

    ! NOTE: We somewhat replicate code in ``evaluate_hodograph()``
    !       here. This is so we don't re-compute the nodes for the first
    !       derivative every time it is evaluated.
    first_deriv = (num_nodes - 1) * (nodes(:, 2:) - nodes(:, :num_nodes - 1))
    if (num_nodes == 0) then
       error_val = -1
       return
    else if (num_nodes == 1) then
       length = 0.0
       error_val = 0
       return
    else if (num_nodes == 2) then
       length = norm2(first_deriv)
       error_val = 0
       return
    end if

    call dqagse( &
         vec_size, 0.0_dp, 1.0_dp, SQRT_PREC, SQRT_PREC, 50, length, &
         abserr, neval, error_val, alist, blist, rlist, &
         elist, iord, last)

  contains

    ! Define a closure that evaluates ||B'(s)||_2 where ``s``
    ! is the argument and ``B'(s)`` is parameterized by ``first_deriv``.
    real(c_double) function vec_size(s_val) result(norm_)
      real(c_double), intent(in) :: s_val
      ! Variables outside of signature.
      real(c_double) :: evaluated(dimension_, 1)

      ! ``evaluate_multi`` takes degree, which is one less than the number
      ! of nodes, so our derivative is one less than that.
      call evaluate_multi( &
           num_nodes - 1, dimension_, first_deriv, 1, [s_val], evaluated)
      norm_ = norm2(evaluated)

    end function vec_size

  end subroutine compute_length

  logical(c_bool) function curves_equal(curve1, curve2) result(same)

    ! NOTE: This is **explicitly** not intended for C inter-op.
    ! NOTE: This is really intended to be used by diagnostic / test code
    !       and not during the course of computation.

    type(CurveData), intent(in) :: curve1, curve2

    same = .TRUE.

    ! First, check the scalars.
    if (curve1%start /= curve2%start .OR. curve1%end_ /= curve2%end_) then
       same = .FALSE.
       return
    end if

    ! Then, check the nodes.
    if (allocated(curve1%nodes)) then
       if (allocated(curve2%nodes)) then
          if (all(shape(curve1%nodes) == shape(curve2%nodes))) then
             ! Here, since the same shape, we only exit early
             ! if the nodes aren't identical.
             if (.NOT. all(curve1%nodes == curve2%nodes)) then
                same = .FALSE.
                return
             end if
          else
             ! Different shapes can't be equal.
             same = .FALSE.
             return
          end if
       else
          ! nodes1 are allocated, nodes2 are not, can't be equal.
          same = .FALSE.
          return
       end if
    else
       if (allocated(curve2%nodes)) then
          ! nodes2 are allocated, nodes1 are not, can't be equal.
          same = .FALSE.
          return
       end if
       ! In the implicit ``else`` branch here, both sets of nots are
       ! un-allocated, hence they are the "same".
    end if

  end function curves_equal

  subroutine subdivide_curve(curve_data, left, right)

    ! NOTE: This is **explicitly** not intended for C inter-op.
    ! NOTE: This **assumes** but does not check that ``curve_data%nodes``
    !       is allocated.

    type(CurveData), intent(in) :: curve_data
    type(CurveData), intent(out) :: left, right
    ! Variables outside of signature.
    integer(c_int) :: num_nodes, dimension_

    num_nodes = size(curve_data%nodes, 2)
    dimension_ = size(curve_data%nodes, 1)

    left%start = curve_data%start
    left%end_ = 0.5_dp * (curve_data%start + curve_data%end_)
    allocate(left%nodes(dimension_, num_nodes))

    right%start = left%end_
    right%end_ = curve_data%end_
    allocate(right%nodes(dimension_, num_nodes))

    call subdivide_nodes( &
         num_nodes, dimension_, curve_data%nodes, left%nodes, right%nodes)

  end subroutine subdivide_curve

end module curve


! $UWHPSC/codes/fortran/sub3.f90

module sub3module

contains

subroutine fsub(x,f)
  ! compute f(x) = x**2 for all elements of the array x.
  implicit none
  real(kind=8), dimension(:), intent(in) :: x
  real(kind=8), dimension(size(x)), intent(out) :: f
  f = x**2
end subroutine fsub

end module sub3module

!----------------------------------------------

program sub3
    use sub3module
    implicit none
    real(kind=8), dimension(3) :: y,z

    y = (/2., 3., 4./)
    call fsub(y,z)
    print *, "z = ",z
end program sub3


program save_and_load_list_neighbours
! given a point find all neighbouring points

! use the sphere_tesselate module
! (this is what we want to test after all)
use sphere_tesselate

! implicit none as always
implicit none

! declare a tesselation which defines our icosahedron
! (kind of like a mesh)
type(tesselation) :: tess
type(point) :: pt
type(triangle) :: tr
type(list_neighbours) :: lnbrs
integer :: pt_id

! build the icosadron with the following arguments:
! -- level = 0
! -- shape = icosahedron
! -- point at poles = true
tess = st_new(2,'ico',.true.)

! generate list of neighbours
call st_generate_list_neighbours(tess,lnbrs)

!!!! Fortran Binary
write(*,*) 'Testing Fortran binary formatted neighbours files'
! save list to ascii file for human inspection
call st_save_neighbours(lnbrs,'test_list_of_neighbours.bin')
! now load it back in
call st_load_neighbours('test_list_of_neighbours.bin',lnbrs)
! check it's read in properly
pt_id = 98
write(*,*) 'pt_id:',pt_id
write(*,*) 'neighbours:',lnbrs%list(pt_id)%idxs

!!!! ASCII
write(*,*) 'Testing ASCII formatted neighbours files'

! save list to ascii file for human inspection

call st_save_neighbours(lnbrs,'test_list_of_neighbours.txt',.true.)

! now load it back in
call st_load_neighbours('test_list_of_neighbours.txt',lnbrs,.true.)
! check it's read in properly
pt_id = 98
write(*,*) 'pt_id:',pt_id
write(*,*) 'neighbours:',lnbrs%list(pt_id)%idxs

end program


module trafo_mod

use constants_mod

contains

pure function minmod(uL, uC, uR) result(slope)

    real(dp), intent(in) :: uL, uC, uR
    real(dp) :: slope, dL, dR

    dL = uC-uL
    dR = uR-uC

    slope = sign(1.0_dp,dL)*merge(min(abs(dL),abs(dR)), 0.0_dp, dL*dR > 0)

end function

pure subroutine linear_scale_up_1d(N, src, snk)

    integer, intent(in) :: N
    real(dp), intent(in)    :: src(0:N+1)
    real(dp), intent(out)   :: snk(2*N)

    integer :: i
    real(dp) :: slope
    real(dp), parameter :: beta = 0.5_dp

    do i = 2,2*N,2
        associate(uL => src(i/2-1), uC => src(i/2), uR => src(i/2+1))
        slope = minmod(uL, uC, uR)
        snk(i-1) = uC - beta*slope
        snk(i+0) = uC + beta*slope
        end associate
    end do

end subroutine

pure subroutine linear_scale_up_2d(N, src, snk)

    integer, intent(in) :: N
    real(dp), intent(in)    :: src(0:N+1,0:N+1)
    real(dp), intent(out)   :: snk(2*N,2*N)

    integer :: i,j
    real(dp) :: xslope, yslope
    real(dp), parameter :: beta = 0.75_dp

    do i = 2,2*N,2
    do j = 2,2*N,2
        associate(uN => src(i/2-1,j/2), uS => src(i/2+1,j/2))
        associate(uW => src(i/2,j/2-1), uE => src(i/2,j/2+1), uC => src(i/2,j/2))
        xslope = minmod(uN, uC, uS)
        yslope = minmod(uW, uC, uE)
        snk(i-1,j-1) = uC - 0.5_dp*beta*(xslope + yslope)
        snk(i-0,j-1) = uC - 0.5_dp*beta*(yslope - xslope)
        snk(i-1,j+0) = uC - 0.5_dp*beta*(xslope - yslope)
        snk(i+0,j+0) = uC + 0.5_dp*beta*(xslope + yslope)
        end associate
        end associate
    end do
    end do

end subroutine

pure subroutine scale_up_2d(bar, foo)

    !! R^(N x N) -> R^(2*N x 2*N)

    use constants_mod

    real(dp), intent(in)   :: bar(:,:)
    real(dp), intent(out)  :: foo(:,:)

    integer :: i,j,k,l, ndims(2)

    ndims = shape(bar)

    do j = 1,ndims(2); do i = 1,ndims(1)
        do l = 0,1; do k = 0,1
            foo(2*i-k,2*j-l) = bar(i,j)
        end do; end do
    end do; end do

end subroutine

pure subroutine scale_down_2d(foo, bar)

    !! R^(2*N x 2*N) -> R^(N x N)

    use constants_mod

    real(dp), intent(in)    :: foo(:,:)
    real(dp), intent(out)   :: bar(:,:)

    integer :: i,j,k,l, ndims(2)

    ndims = shape(bar)
    bar   = 0.0

    do j = 1,ndims(2); do i = 1,ndims(1)
        do l = 0,1; do k = 0,1
            bar(i,j) = bar(i,j) + 0.25*foo(2*i-k,2*j-l)
        end do; end do
    end do; end do

end subroutine

pure subroutine scale_up_3d(bar, foo)

    !! R^(N x N x N) -> R^(2*N x 2*N x 2*N)

    use constants_mod

    real(dp), intent(in)   :: bar(:,:,:)
    real(dp), intent(out)  :: foo(:,:,:)

    integer :: i,j,k
    integer :: q,r,s
    integer :: ndims(3)

    ndims = shape(bar)

    do k = 1,ndims(3)
    do j = 1,ndims(2)
    do i = 1,ndims(1)
        do s = 0,1
        do r = 0,1
        do q = 0,1
            foo(2*i-q,2*j-r,2*k-s) = bar(i,j,k)
        end do
        end do
        end do
    end do
    end do
    end do

end subroutine

pure subroutine scale_down_3d(foo, bar)

    !! R^(2*N x 2*N x 2*N) -> R^(N x N x N)

    use constants_mod

    real(dp), intent(in)    :: foo(:,:,:)
    real(dp), intent(out)   :: bar(:,:,:)

    integer :: i,j,k
    integer :: q,r,s
    integer :: ndims(3)

    ndims = shape(bar)
    bar   = 0.0

    do k = 1,ndims(3)
    do j = 1,ndims(2)
    do i = 1,ndims(1)
        do s = 0,1
        do r = 0,1
        do q = 0,1
             bar(i,j,k) = bar(i,j,k) + 0.125_dp*foo(2*i-q,2*j-r,2*k-s)
        end do
        end do
        end do
    end do
    end do
    end do

end subroutine

end module


!*==dlartg.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLARTG generates a plane rotation with real cosine and real sine.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLARTG + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLARTG( F, G, CS, SN, R )
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION   CS, F, G, R, SN
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLARTG generate a plane rotation so that
!>
!>    [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.
!>    [ -SN  CS  ]     [ G ]     [ 0 ]
!>
!> This is a slower, more accurate version of the BLAS1 routine DROTG,
!> with the following other differences:
!>    F and G are unchanged on return.
!>    If G=0, then CS=1 and SN=0.
!>    If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
!>       floating point operations (saves work in DBDSQR when
!>       there are zeros on the diagonal).
!>
!> If F exceeds G in magnitude, CS will be positive.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] F
!> \verbatim
!>          F is DOUBLE PRECISION
!>          The first component of vector to be rotated.
!> \endverbatim
!>
!> \param[in] G
!> \verbatim
!>          G is DOUBLE PRECISION
!>          The second component of vector to be rotated.
!> \endverbatim
!>
!> \param[out] CS
!> \verbatim
!>          CS is DOUBLE PRECISION
!>          The cosine of the rotation.
!> \endverbatim
!>
!> \param[out] SN
!> \verbatim
!>          SN is DOUBLE PRECISION
!>          The sine of the rotation.
!> \endverbatim
!>
!> \param[out] R
!> \verbatim
!>          R is DOUBLE PRECISION
!>          The nonzero component of the rotated vector.
!>
!>  This version has a few statements commented out for thread safety
!>  (machine parameters are computed on each entry). 10 feb 03, SJH.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup OTHERauxiliary
!
!  =====================================================================
      SUBROUTINE DLARTG(F,G,Cs,Sn,R)
      IMPLICIT NONE
!*--DLARTG101
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      DOUBLE PRECISION Cs , F , G , R , Sn
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D0)
      DOUBLE PRECISION ONE
      PARAMETER (ONE=1.0D0)
      DOUBLE PRECISION TWO
      PARAMETER (TWO=2.0D0)
!     ..
!     .. Local Scalars ..
!     LOGICAL            FIRST
      INTEGER count , i
      DOUBLE PRECISION eps , f1 , g1 , safmin , safmn2 , safmx2 , scale
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL DLAMCH
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , INT , LOG , MAX , SQRT
!     ..
!     .. Save statement ..
!     SAVE               FIRST, SAFMX2, SAFMIN, SAFMN2
!     ..
!     .. Data statements ..
!     DATA               FIRST / .TRUE. /
!     ..
!     .. Executable Statements ..
!
!     IF( FIRST ) THEN
      safmin = DLAMCH('S')
      eps = DLAMCH('E')
      safmn2 = DLAMCH('B')**INT(LOG(safmin/eps)/LOG(DLAMCH('B'))/TWO)
      safmx2 = ONE/safmn2
!        FIRST = .FALSE.
!     END IF
      IF ( G==ZERO ) THEN
         Cs = ONE
         Sn = ZERO
         R = F
      ELSEIF ( F==ZERO ) THEN
         Cs = ZERO
         Sn = ONE
         R = G
      ELSE
         f1 = F
         g1 = G
         scale = MAX(ABS(f1),ABS(g1))
         IF ( scale>=safmx2 ) THEN
            count = 0
            DO
               count = count + 1
               f1 = f1*safmn2
               g1 = g1*safmn2
               scale = MAX(ABS(f1),ABS(g1))
               IF ( scale<safmx2 .OR. count>=20 ) THEN
                  R = SQRT(f1**2+g1**2)
                  Cs = f1/R
                  Sn = g1/R
                  DO i = 1 , count
                     R = R*safmx2
                  ENDDO
                  EXIT
               ENDIF
            ENDDO
         ELSEIF ( scale<=safmn2 ) THEN
            count = 0
            DO
               count = count + 1
               f1 = f1*safmx2
               g1 = g1*safmx2
               scale = MAX(ABS(f1),ABS(g1))
               IF ( scale>safmn2 ) THEN
                  R = SQRT(f1**2+g1**2)
                  Cs = f1/R
                  Sn = g1/R
                  DO i = 1 , count
                     R = R*safmn2
                  ENDDO
                  EXIT
               ENDIF
            ENDDO
         ELSE
            R = SQRT(f1**2+g1**2)
            Cs = f1/R
            Sn = g1/R
         ENDIF
         IF ( ABS(F)>ABS(G) .AND. Cs<ZERO ) THEN
            Cs = -Cs
            Sn = -Sn
            R = -R
         ENDIF
      ENDIF
!
!     End of DLARTG
!
      END SUBROUTINE DLARTG


subroutine advect2_mom_xy

!        momentum tendency due to 2nd-order-central horizontal advection

use vars

implicit none

real fu(0:nx,1-YES3D:ny,nzm)
real fv(0:nx,1-YES3D:ny,nzm)
real fw(0:nx,1-YES3D:ny,nzm)
real dx25, dy25, irho

integer i, j, k, kc, kcu, ic, jb, ib, jc

dx25 = 0.25 / dx
dy25 = 0.25 / dy

if(RUN3D) then

do k = 1,nzm
 kc= k+1
 kcu =min(kc, nzm)
 irho = 1./(rhow(kc)*adzw(kc))

 do j = 1, ny
  jb = j-1
  do i = 0, nx
   ic = i+1
   fu(i,j,k)=dx25*(u(ic,j,k)+u(i,j,k))*(u(i,j,k)+u(ic,j,k))
   fv(i,j,k)=dx25*(u(ic,j,k)+u(ic,jb,k))*(v(i,j,k)+v(ic,j,k))
   fw(i,j,k)=dx25*(u(ic,j,k)*rho(k)*adz(k)+ &
             u(ic,j,kcu)*rho(kcu)*adz(kcu))*(w(i,j,kc)+w(ic,j,kc))
  end do
  do i = 1, nx
   ib = i-1
    dudt(i,j,k,na)  = dudt(i,j,k,na)  - (fu(i,j,k)-fu(ib,j,k))
    dvdt(i,j,k,na)  = dvdt(i,j,k,na)  - (fv(i,j,k)-fv(ib,j,k))
    dwdt(i,j,kc,na) = dwdt(i,j,kc,na)-irho*(fw(i,j,k)-fw(ib,j,k))
  end do
 end do

 do j = 0, ny
  jc = j+1
  do i = 1, nx
   ib = i-1
   fu(i,j,k)=dy25*(v(i,jc,k)+v(ib,jc,k))*(u(i,j,k)+u(i,jc,k))
   fv(i,j,k)=dy25*(v(i,jc,k)+v(i,j,k))*(v(i,j,k)+v(i,jc,k))
   fw(i,j,k)=dy25*(v(i,jc,k)*rho(k)*adz(k)+ &
             v(i,jc,kcu)*rho(kcu)*adz(kcu))*(w(i,j,kc)+w(i,jc,kc))
  end do
 end do
 do j = 1,ny
  jb = j-1
  do i = 1, nx
   dudt(i,j,k,na) = dudt(i,j,k,na) - (fu(i,j,k) - fu(i,jb,k))
   dvdt(i,j,k,na) = dvdt(i,j,k,na) - (fv(i,j,k) - fv(i,jb,k))
   dwdt(i,j,kc,na)= dwdt(i,j,kc,na)-irho*(fw(i,j,k)-fw(i,jb,k))
  end do
 end do

end do ! k

else

j=1

do k = 1,nzm
 kc= k+1
 kcu =min(kc, nzm)
 irho = 1./(rhow(kc)*adzw(kc))

  do i = 0, nx
   ic = i+1
   fu(i,j,k)=dx25*(u(ic,j,k)+u(i,j,k))*(u(i,j,k)+u(ic,j,k))
   fv(i,j,k)=dx25*(u(ic,j,k)+u(i,j,k))*(v(i,j,k)+v(ic,j,k))
   fw(i,j,k)=dx25*(u(ic,j,k)*rho(k)*adz(k)+ &
             u(ic,j,kcu)*rho(kcu)*adz(kcu))*(w(i,j,kc)+w(ic,j,kc))
  end do
  do i = 1, nx
   ib = i-1
    dudt(i,j,k,na)  = dudt(i,j,k,na)  - (fu(i,j,k)-fu(ib,j,k))
    dvdt(i,j,k,na)  = dvdt(i,j,k,na)  - (fv(i,j,k)-fv(ib,j,k))
    dwdt(i,j,kc,na) = dwdt(i,j,kc,na)-irho*(fw(i,j,k)-fw(ib,j,k))
  end do

end do ! k

endif

end subroutine advect2_mom_xy


   	SUBROUTINE RMIE (X,REFREL,NANG,S1,S2,QEXT,QSCA,QBACK)
C***********************************************************************
C  	SUBROUTINE RMIE CALCULATES AMPLITUDE SCATTERING MATRIX ELEMENTS
C  	AND EFFICIENCIES FOR EXTINCTION, TOTAL SCATTERING AND BACK
C  	SCATTERING FOR A GIVEN SIZE PARAMETER AND RELATIVE REF. INDEX;
C	(ROUTINE IS FROM BOHREN AND HUFFMAN, "ABSORPTION AND SCATTERING
C	OF LIGHT BY SMALL PARTICLES," 1983.)
C  	CODED SEPT 1992 BY BRAD ADAMS
C***********************************************************************
   	DIMENSION AMU(100),THETA(100),PI(100),TAU(100),PI0(100),PI1(100)
   	COMPLEX D(3000),Y,REFREL,XI,XI0,XI1,AN,BN,S1(200),S2(200)
    	DOUBLE PRECISION PSI0,PSI1,PSI,DN,DX
   	DX=X
   	Y=X*REFREL
C***********************************************************************
C  	SERIES TERMINATED AFTER NSTOP TERMS
C***********************************************************************
   	XSTOP=X+4.0*X**.3333+2.0
   	NSTOP=XSTOP
   	YMOD=CABS(Y)
   	NMX=AMAX1(XSTOP,YMOD)+15
    	DANG=1.570796327/FLOAT(NANG-1)
   	DO 555 J=1,NANG
   	  THETA(J)=(FLOAT(J)-1.0)*DANG
 555	AMU(J)=COS(THETA(J))
C***********************************************************************
C  	LOGARITIMIC DERIVATIVE D(J) CALCULATED BY DOWNWARD
C  	RECURRENCE BEGINNING WITH INITAL VALUE 0.0+I*0.0
C  	AT J= NMX
C***********************************************************************
    	D(NMX)=CMPLX(0.0,0.0)
    	NN=NMX-1
    	DO 120 N=1,NN
    	  RN=NMX-N+1
 120	D(NMX-N)=(RN/Y)-(1.0/(D(NMX-N+1)+RN/Y))
    	DO 666 J=1,NANG
    	  PI0(J)=0.0
 666	PI1(J)=1.0
    	NN=2*NANG-1
    	DO 777 J=1,NN
    	  S1(J)=CMPLX(0.0,0.0)
 777	S2(J)=CMPLX(0.0,0.0)
C***********************************************************************
C   	RICCATI-BESSEL FUNCTION WITH REAL ARGUMENT X
C   	CALCULATED BY UPWARD RECURRENCE
C***********************************************************************
    	PSI0=DCOS(DX)
    	PSI1=DSIN(DX)
    	CHI0=-SIN(X)
    	CHI1=COS(X)
    	APSI0=PSI0
    	APSI1=PSI1
        XI0=CMPLX(APSI0,-CHI0)
    	XI1=CMPLX(APSI1,-CHI1)
    	QSCA=0.0
    	N=1
 200	DN=N
    	RN=N
    	FN=(2.0*RN+1.0)/(RN*(RN+1.0))
    	PSI=(2.0*DN-1.0)*PSI1/DX-PSI0
    	APSI=PSI
    	CHI=(2.0*RN-1.0)*CHI1/X-CHI0
    	XI=CMPLX(APSI,-CHI)
    	AN=(D(N)/REFREL+RN/X)*APSI-APSI1
    	AN=AN/((D(N)/REFREL+RN/X)*XI-XI1)
    	BN=(REFREL*D(N)+RN/X)*APSI-APSI1
    	BN=BN/((REFREL*D(N)+RN/X)*XI-XI1)
    	QSCA=QSCA+(2.0*RN+1.0)*(CABS(AN)*CABS(AN)+CABS(BN)*CABS(BN))
    	DO 789 J=1,NANG
    	  JJ=2*NANG-J
    	  PI(J)=PI1(J)
     	  TAU(J)=RN*AMU(J)*PI(J)-(RN+1.0)*PI0(J)
    	  P=(-1.0)**(N-1)
    	  S1(J)=S1(J)+FN*(AN*PI(J)+BN*TAU(J))
    	  T=(-1.0)**N
    	  S2(J)=S2(J)+FN*(AN*TAU(J)+BN*PI(J))
    	  IF(J.EQ.JJ) GO TO 789
    	  S1(JJ)=S1(JJ)+FN*(AN*PI(J)*P+BN*TAU(J)*T)
    	  S2(JJ)=S2(JJ)+FN*(AN*TAU(J)*T+BN*PI(J)*P)
 789	CONTINUE
    	PSI0=PSI1
     	PSI1=PSI
    	APSI1=PSI1
    	CHI0=CHI1
    	CHI1=CHI
    	XI1=CMPLX(APSI1,-CHI1)
    	N=N+1
    	RN=N
    	DO 999 J=1,NANG
    	  PI1(J)=((2.0*RN-1.0)/(RN-1.0))*AMU(J)*PI(J)
    	  PI1(J)=PI1(J)-RN*PI0(J)/(RN-1.0)
 999	PI0(J)=PI(J)
    	IF (N-1-NSTOP) 200,300,300
 300	QSCA=(2.0/(X*X))*QSCA
    	QEXT=(4.0/(X*X))*REAL(S1(1))
    	QBACK=(4.0/(X*X))*CABS(S1(2*NANG-1))*CABS(S1(2*NANG-1))
C
     	RETURN
    	END


!c     This program is for thermal finite element calculation
!c     Variable rRn, rRn_1, rRn_2, correspond to variable at
!c     current, last, last two time step.
!c     Variable rTn, rTn_1, rTn_2, correspond to variable at
!c     current, last, last two time step.

subroutine CN_FEM_Solver(y, z, id, u,matp)!, ElemCount,NodeCount)
        use  mod_dtimeSpecs
        use CN_Objects_manager

!        implicit none
!        real,     intent(in) :: y(*), z(*),  u(*)!connect(4,*),
!        integer,  intent(in) :: id(2,*)!,ElemCount,NodeCount
!        real , intent(in) ::matp(*)
        dimension y(*), z(*), matp(*),  u(*),id(2,*)

      real*8 N(4,4),ShpFcnDeriv(4,2,4),coords(4,2)
      real*8 Jmatrix(2,2),Gamma(2,2),B(4,2,4)
      real*8 rhocp(ElemCountAct),Jacob(ElemCountAct,4)

      real*8 kappa(2,2)
      real*8 B1(2,4),B2(2,4),B3(2,4),B4(2,4)
      real*8 B1T(4,2),B2T(4,2),B3T(4,2),B4T(4,2)
      real*8 ke1a(2,4),ke2a(2,4),ke3a(2,4),ke4a(2,4)
      real*8 ke1b(4,4),ke2b(4,4),ke3b(4,4),ke4b(4,4)
      real*8 ke1(4,4),ke2(4,4),ke3(4,4),ke4(4,4)
	  real*8 ks1(4,4),ks2(4,4),ks3(4,4),ks4(4,4)

      real*8 Ce(ElemCountAct,4,4),ke(ElemCountAct,4,4)
      real*8 Cglobal(NodeCountAct,NodeCountAct), Kglobal(NodeCountAct,NodeCountAct)
      real*8  rRn(NodeCountAct),rTn(NodeCountAct)
      real*8  Rq(ElemCountAct,4)
      real*8 thermalkd(ElemCountAct),DijSijd(ElemCountAct)!,rTn_1(NodeCountAct)

!!!!!!      real hycon
      integer idt,i,idtPrintOutput,j,iNodes(4)
      real*8 rDiffCoeffElem,DtCondDiff
      integer node1,node2,node3,node4

      DtCondDiff=DtCurrent
      DtCondDiff=DtCurrent/idtimeStepsSol(1)
! ##################################################
      do idt=1,idtimeStepsSol(1) !---- this is the refinement loop, chops dt by n-sections
        Cglobal=0.0;        Kglobal=0.0
        DijSijd=0.0;        thermalkd=0.0
        rhocp=1.0
        Rq=0.0;
        rRn=0.0;rTn=0.0
        ke=0.0;  Ce=0.0
        !!!!!!!!!!!!!        pressnode=0.0

!!!!!!!!!! ##################################################
        call CNGet_kd_RoCp_DijSij(thermalkd,DijSijd,rhocp)

!!!!!!!!!!!!        write(*,*) '#################################################'
!!!!!!!!!!!!        write(*,*) matp(1:100)
!!!!!!!!!!!!        write(*,*) int(matp(1:100))
!!!!!!!!!!!!        write(*,*) ElemCountAct
        CALL CNGet_press_kd(matp,thermalkd)
!!!  we can update this here b/c rTn is saved
!!!!        rTn_1(1:NodeCountAct)=rTn(1:NodeCountAct)

        CALL CNCalShpFcnDeriv(ShpFcnDeriv)
! ##################################################

!c     starting the big element loop
        do i=1,ElemCountAct
!c      reading nodes associated with element i
            iNodes(1:4)=iElemConnect(1:4,i)

            Coords(1:4,1)=y(iNodes(1:4))+u(id(1,iNodes(1:4)))          ! current configuration
            Coords(1:4,2)=z(iNodes(1:4))+u(id(2,iNodes(1:4)))          ! current configuration

!c     given shape function derivatives wrt isoparametric coords
!c     and coordinate matrix for the 4 Gauss points, find the B-matrix
            do j=1,GaussIntPtsCount
                Jmatrix=matmul(ShpFcnDeriv(j,1:2,1:4),Coords)
                Jacob(i,j)=Jmatrix(1,1)*Jmatrix(2,2)-Jmatrix(2,1)*Jmatrix(1,2)
                Gamma(1,1)=1/Jacob(i,j)*Jmatrix(2,2)
                Gamma(1,2)=-1/Jacob(i,j)*Jmatrix(1,2)
                Gamma(2,1)=-1/Jacob(i,j)*Jmatrix(2,1)
                Gamma(2,2)=1/Jacob(i,j)*Jmatrix(2,2)
                B(j,1:2,1:4)=matmul(Gamma,ShpFcnDeriv(j,1:2,1:4))
            enddo
            B1(1:2,1:4)=B(1,1:2,1:4)
            B2(1:2,1:4)=B(2,1:2,1:4)
            B3(1:2,1:4)=B(3,1:2,1:4)
            B4(1:2,1:4)=B(4,1:2,1:4)

            call matrixtrans(B1,B1T,2,4)
            call matrixtrans(B2,B2T,2,4)
            call matrixtrans(B3,B3T,2,4)
            call matrixtrans(B4,B4T,2,4)

            !c           thermal conductivity   / or diffusion
            kappa(1,1)=thermalkd(i)
            kappa(1,2)=0.
            kappa(2,1)=0.
            kappa(2,2)=thermalkd(i)

            ke1a=matmul(kappa,B1)
            ke2a=matmul(kappa,B2)
            ke3a=matmul(kappa,B3)
            ke4a=matmul(kappa,B4)

            ke1b=matmul(B1T,ke1a)
            ke2b=matmul(B2T,ke2a)
            ke3b=matmul(B3T,ke3a)
            ke4b=matmul(B4T,ke4a)
            !c      Element k matrix for the 4 Gauss points
            ke1(1:4,1:4)=ke1b(1:4,1:4)*Jacob(i,1)*GaussIntPtsWeight
            ke2(1:4,1:4)=ke2b(1:4,1:4)*Jacob(i,2)*GaussIntPtsWeight
            ke3(1:4,1:4)=ke3b(1:4,1:4)*Jacob(i,3)*GaussIntPtsWeight
            ke4(1:4,1:4)=ke4b(1:4,1:4)*Jacob(i,4)*GaussIntPtsWeight

            CALL CNGet_Rq_Ce(i,rhocp,Jacob,DijSijd,Rq,Ce)
            CALL CNGet_Ks(i,ke1,ke2,ke3,ke4,B1,B2,B3,B4,ks1,ks2,ks3,ks4)

            ke(i,1:4,1:4)=ke1(1:4,1:4)+ke2(1:4,1:4)+ke3(1:4,1:4)+ke4(1:4,1:4)!-ks1(1:4,1:4)-ks2(1:4,1:4) -ks3(1:4,1:4)-ks4(1:4,1:4)
!!!!!!            write(*,*)ke(i,1:4,1)
!!!!!!            write(*,*)ke(i,1:4,2)
!!!!!!            write(*,*)ke(i,1:4,3)
!!!!!!            write(*,*)ke(i,1:4,4)
!!!!!!c     Assembling global matrices
            Kglobal(iNodes(1:4),iNodes(1:4))=Kglobal(iNodes(1:4),iNodes(1:4))+ke(i,1:4,1:4)
            Cglobal(iNodes(1:4),iNodes(1:4))=Cglobal(iNodes(1:4),iNodes(1:4))+Ce(i,1:4,1:4)
            rRn(iNodes(1:4))=rRn(iNodes(1:4))+Rq(i,1:4)

        enddo
!!!!        do i=1,NodeCountAct
!!!!        write(2102,*)Kglobal(i,1:NodeCountAct)
!!!!        enddo

!!!!!!c     Assembling global matrices
!!!!!        do i=1,ElemCountAct
!!!!!!!!!            node1=iElemConnect(1,i)
!!!!!!!!!            node2=iElemConnect(2,i)
!!!!!!!!!            node3=iElemConnect(3,i)
!!!!!!!!!            node4=iElemConnect(4,i)
!!!!!
!!!!!            Kglobal(iElemConnect(1:4,i),iElemConnect(1:4,i))=Kglobal(iElemConnect(1:4,i),iElemConnect(1:4,i))+ke(i,1:4,1:4)
!!!!!            Cglobal(iElemConnect(1:4,i),iElemConnect(1:4,i))=Cglobal(iElemConnect(1:4,i),iElemConnect(1:4,i))+Ce(i,1:4,1:4)
!!!!!            rRn(iElemConnect(1:4,i))=rRn(iElemConnect(1:4,i))+Rq(i,1:4)
!!!!!        enddo
!!!!!     Crank-Nicolson
        call CNmanagerGetSolution (DtCondDiff,Cglobal,Kglobal,rRn,rTn)
!!!        write(*,*)rTn(13:15)
!!!  we can't update this here b/c rTn_1 is not saved in any block but rTn is saved
!!!!!!!      rTn_1(1:NodeCount,1)=rTn(1:NodeCount,1)       ! this is the current step solution
!!!!      write(*,*)'rTn(1:NodeCount,1)',rTn(1:NodeCount,1)
!!!!      write(*,*)'hycon(1:NodeCount,1)',hycon(1:ElemCount,1)
!!!!! ##################################################
        if(iPrintOutputFlag .eq. 1) then
            idtPrintOutput=mod(idt,idtimeStepsOutput(1))
            !!!        idtPrintOutput=mod(idt,1)
            if(idtPrintOutput == 0) then ! there is a reminder  ex. 2200/1000 = 200 but 3000/1000 =0
              ! if nstep is not divisible with iprint then do not print
                CALL CNWriteOutputFiles()
            endif

        endif
!!!!!!                --print output for node 32 for testing
!!!!!      write(iFU_temperNodeID_out,26) TdSol(40,1) ! nodes ID
!!!!!      write(iFU_temperElemID_out,26) TdSol(26,1) !elem ID

!!!!!! ##################################################
        enddo !do idt=1,idtimeStepsSol(1) !---- this is the refinement loop, chops dt by n-sections
!!!!!! ##################################################
        if(iPrintOutputFlag .eq. 1) then
            CALL CNWriteOutputFilesDijSij(DijSijd,rhocp,thermalkd)
            CALL CNmanager_WriteFiles21_2_3_4()
        endif

   26 format(e15.6)

      end

!!!            Kglobal(node1,iElemConnect(1:4,i))=Kglobal(node1,iElemConnect(1:4,i))+ke(i,1,1:4)
!!!            Kglobal(node2,iElemConnect(1:4,i))=Kglobal(node2,iElemConnect(1:4,i))+ke(i,2,1:4)
!!!            Kglobal(node3,iElemConnect(1:4,i))=Kglobal(node3,iElemConnect(1:4,i))+ke(i,3,1:4)
!!!            Kglobal(node4,iElemConnect(1:4,i))=Kglobal(node4,iElemConnect(1:4,i))+ke(i,4,1:4)

!!!!!            Kglobal(node1,node1)=Kglobal(node1,node1)+ke(i,1,1)
!!!!!            Kglobal(node1,node2)=Kglobal(node1,node2)+ke(i,1,2)
!!!!!            Kglobal(node1,node3)=Kglobal(node1,node3)+ke(i,1,3)
!!!!!            Kglobal(node1,node4)=Kglobal(node1,node4)+ke(i,1,4)
!!!!!
!!!!!            Kglobal(node2,node1)=Kglobal(node2,node1)+ke(i,2,1)
!!!!!            Kglobal(node2,node2)=Kglobal(node2,node2)+ke(i,2,2)
!!!!!            Kglobal(node2,node3)=Kglobal(node2,node3)+ke(i,2,3)
!!!!!            Kglobal(node2,node4)=Kglobal(node2,node4)+ke(i,2,4)
!!!!!
!!!!!            Kglobal(node3,node1)=Kglobal(node3,node1)+ke(i,3,1)
!!!!!            Kglobal(node3,node2)=Kglobal(node3,node2)+ke(i,3,2)
!!!!!            Kglobal(node3,node3)=Kglobal(node3,node3)+ke(i,3,3)
!!!!!            Kglobal(node3,node4)=Kglobal(node3,node4)+ke(i,3,4)
!!!!!
!!!!!            Kglobal(node4,node1)=Kglobal(node4,node1)+ke(i,4,1)
!!!!!            Kglobal(node4,node2)=Kglobal(node4,node2)+ke(i,4,2)
!!!!!            Kglobal(node4,node3)=Kglobal(node4,node3)+ke(i,4,3)
!!!!!            Kglobal(node4,node4)=Kglobal(node4,node4)+ke(i,4,4)

      !!!!            Cglobal(node1,iElemConnect(1:4,i))=Cglobal(node1,iElemConnect(1:4,i))+Ce(i,1,1:4)
!!!!            Cglobal(node2,iElemConnect(1:4,i))=Cglobal(node2,iElemConnect(1:4,i))+Ce(i,2,1:4)
!!!!            Cglobal(node3,iElemConnect(1:4,i))=Cglobal(node3,iElemConnect(1:4,i))+Ce(i,3,1:4)
!!!!            Cglobal(node4,iElemConnect(1:4,i))=Cglobal(node4,iElemConnect(1:4,i))+Ce(i,4,1:4)

!!!!            Cglobal(node1,node1)=Cglobal(node1,node1)+Ce(i,1,1)
!!!!            Cglobal(node1,node2)=Cglobal(node1,node2)+Ce(i,1,2)
!!!!            Cglobal(node1,node3)=Cglobal(node1,node3)+Ce(i,1,3)
!!!!            Cglobal(node1,node4)=Cglobal(node1,node4)+Ce(i,1,4)
!!!!
!!!!            Cglobal(node2,node1)=Cglobal(node2,node1)+Ce(i,2,1)
!!!!            Cglobal(node2,node2)=Cglobal(node2,node2)+Ce(i,2,2)
!!!!            Cglobal(node2,node3)=Cglobal(node2,node3)+Ce(i,2,3)
!!!!            Cglobal(node2,node4)=Cglobal(node2,node4)+Ce(i,2,4)
!!!!
!!!!            Cglobal(node3,node1)=Cglobal(node3,node1)+Ce(i,3,1)
!!!!            Cglobal(node3,node2)=Cglobal(node3,node2)+Ce(i,3,2)
!!!!            Cglobal(node3,node3)=Cglobal(node3,node3)+Ce(i,3,3)
!!!!            Cglobal(node3,node4)=Cglobal(node3,node4)+Ce(i,3,4)
!!!!
!!!!            Cglobal(node4,node1)=Cglobal(node4,node1)+Ce(i,4,1)
!!!!            Cglobal(node4,node2)=Cglobal(node4,node2)+Ce(i,4,2)
!!!!            Cglobal(node4,node3)=Cglobal(node4,node3)+Ce(i,4,3)
!!!!            Cglobal(node4,node4)=Cglobal(node4,node4)+Ce(i,4,4)

!!!            rRn(node1)=rRn(node1)+Rq(i,1)
!!!            rRn(node2)=rRn(node2)+Rq(i,2)
!!!            rRn(node3)=rRn(node3)+Rq(i,3)
!!!            rRn(node4)=rRn(node4)+Rq(i,4)


module global_variables
    implicit none

    ! CONSTANTS
    real, parameter :: KB = 1.38064852e-23, EE = 1.6021766208e-19, PI = 3.14159265, KE = 8.99e9, NA = 6.02214086e23
    real, parameter :: P = 101325.0, Mg = 29.2e-3
    ! KB = boltzmann Constant (SI)
    ! EE = elementary charge on an electron
    ! KE = 1/(4.0*PI*eps0)
    ! NA = Avagadro's Constant (mol-1)
    ! P = Pressure (N/m2)
    ! Mg = Molecular Weight of gas (Kg/mol)

    ! MOLECULAR WEIGHT AND DENSITY
     double precision :: mw = 100e-3, rho = 1000.0, Temp = 300 !1200.0
    ! mw = Molecular Weight (Kg/mol)
    ! rho = Density (Kg/m3)
    ! Temp = temperature (K)

    ! NUMBER OF DISCRETE SIZES, CHARGES
    integer :: n_discrete = 100 ! number of discrete sizes eg. 100
    !integer :: n_charge = 1 ! number of possible charges eg. 3
    !integer, dimension(:), allocatable :: charge  ! possible charges eg. 0 -1 +1

    ! INITIAL
    double precision :: dp0, v0 = 1e-27  !Inital size of the discrete sizes, dp0 (m)
    double precision, dimension(:), allocatable :: Nc0 ! Initial number concentration for each
    ! discrete size (n_discrete, n_charge)

    ! FINAL
     double precision, dimension(:), allocatable :: Nc ! Number concentration for each  (#/m^3)
    ! discrete size (n_discrete, n_charge) at a fixed t

    double precision, dimension(:), allocatable :: YNc !, YNc_mono ! for solver (#/m^3)

    double precision, dimension(:), allocatable :: dp_dis !dp in each discrete section (m)

    ! OTHERS
    integer :: flag ! defines coagulation theory to be used

    ! SOLVER VARIABLES
    double precision :: rtol , t0 = 0.0, tf , dt
    double precision, dimension(:), allocatable :: atol
    integer :: istate , itask = 1, neq

    ! FOR TEMPHIST
    !double precision, dimension(:,:), allocatable :: T_data
    !integer :: time_points

    ! Non-Dimensional Parameters
    !double precision :: K_coag = 8.0*KB*1200.0/(3.0*1.81e-5)
    !double precision :: N_infi_0, tau,
    !double precision :: tau_mono

    ! For beta calculation storage
    double precision, dimension(:,:), allocatable :: beta_all
    double precision :: N_infi_0, K_coag, tau, N_track_min
    ! beta_all is the matrix which contains all the values of the beta
    ! beta_safe is the module
    ! beta is the function which finds the value of beta
    ! fill_beta is the subroutine which fills in all the values of beta

end module global_variables

!program test_global_variables
!    use global_variables
!    implicit none
!
!    print*, n_charge
!
!end program test_global_variables


     program demo_sort_heap
     use M_sort, only : sort_heap
     implicit none
     integer,parameter            :: isz=10000
     real                         :: rr(isz)
     integer                      :: ii(isz)
     character(len=63)            :: cc(isz)
     integer                      :: indx(isz)
     integer                      :: i
     write(*,*)'initializing array with ',isz,' random numbers'
     CALL RANDOM_NUMBER(RR)
     rr=rr*450000.0
     ii=rr
     do i=1,size(cc)
        cc(i)=random_string('abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 ',len(cc))
     enddo

     write(*,*)'checking if real values are sorted(3f)'
     call sort_heap(rr,indx)
     ! use the index array to actually move the input array into a sorted order
     rr=rr(indx)
     do i=1,isz-1
        if(rr(i).gt.rr(i+1))then
           write(*,*)'Error in sorting reals small to large ',i,rr(i),rr(i+1)
        endif
     enddo
     write(*,*)'test of real sort_heap(3f) complete'

     write(*,*)'checking if integer values are sorted(3f)'
     call sort_heap(ii,indx)
     ! use the index array to actually move the input array into a sorted order
     ii=ii(indx)
     do i=1,isz-1
        if(ii(i).gt.ii(i+1))then
           write(*,*)'Error in sorting integer small to large ',i,ii(i),ii(i+1)
        endif
     enddo
     write(*,*)'test of integer sort_heap(3f) complete'

     write(*,*)'checking if character values are sorted(3f)'
     call sort_heap(cc,indx)
     ! use the index array to actually move the input array into a sorted order
     cc=cc(indx)
     do i=1,isz-1
        if(cc(i).gt.cc(i+1))then
           write(*,*)'Error in sorting character small to large ',i,cc(i),cc(i+1)
        endif
     enddo
     write(*,*)'test of character sort_heap(3f) complete'

     contains

     function random_string(chars,length) result(out)

     !$@(#) M_random::random_string(3f): create random string composed of provided characters of specified length

     character(len=*),intent(in)     :: chars
     integer,intent(in)              :: length
     character(len=:),allocatable    :: out
        real                         :: x
        integer                      :: ilen   ! length of list of characters
        integer                      :: which
        integer                      :: i
        ilen=len(chars)
        out=''
        if(ilen.gt.0)then
           do i=1,length
              call random_number(x)
              which=nint(real(ilen-1)*x)+1
              out=out//chars(which:which)
           enddo
        endif
     end function random_string

     end program demo_sort_heap


module median_stats_mod
    use :: stats_mod
    use :: quicksort_mod
    implicit none

    private

    type, extends(descriptive_stats_t), public :: median_stats_t
        private
        real, dimension(:), allocatable :: values
    contains
        procedure, public, pass :: add_value, get_median
        final :: finalize_stats
    end type median_stats_t
    interface median_stats_t
        module procedure init_stats
    end interface

contains

    function init_stats(nr_values) result(stats)
        use, intrinsic :: iso_fortran_env, only : error_unit
        integer, value :: nr_values
        type(median_stats_t) :: stats
        integer :: status

        allocate(stats%values(nr_values), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(A, I0, A)') &
                'error: can not allocated memory for ', nr_values, ' values'
            stop 3
        end if
    end function init_stats

    subroutine add_value(stats, new_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        class(median_stats_t), intent(inout) :: stats
        real, value :: new_value

        if (stats%get_nr_values() + 1 > size(stats%values)) then
            write (unit=error_unit, fmt='(A, I0, A)') &
                'error: capacity exceeded, maximum ', size(stats%values), &
                ' can be processed'
            stop 4
        end if
        call stats%descriptive_stats_t%add_value(new_value)
        stats%values(stats%get_nr_values()) = new_value
    end subroutine add_value

    function get_median(stats) result(median_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        class(median_stats_t), intent(inout) :: stats
        real :: median_value

        if (stats%get_nr_values() == 0) then
            write (unit=error_unit, fmt='(A)') &
                'error: too few data value to compute median'
            stop 1
        end if
        associate(n => stats%get_nr_values(), values => stats%values)
            call qsort(values)
            if (mod(n, 2) == 0) then
                median_value = (values(n/2) + values(n/2 + 1))/2.0
            else
                median_value = values(n/2 + 1)
            end if
        end associate
    end function get_median

    subroutine finalize_stats(stats)
        use, intrinsic :: iso_fortran_env, only : error_unit
        type(median_stats_t), intent(inout) :: stats
        integer :: istat

        deallocate(stats%values, stat=istat)
    end subroutine finalize_stats

end module median_stats_mod


MODULE Constants
    REAL(4), PARAMETER          :: RPS2RPM = 9.5492966                  ! Factor to convert radians per second to revolutions per minute.
    REAL(4), PARAMETER          :: R2D = 57.295780                      ! Factor to convert radians to degrees.
    REAL(4), PARAMETER          :: PI = 3.14159265359                   ! Mathematical constant pi
    INTEGER(4), PARAMETER       :: NP_1 = 1                             ! First rotational harmonic
    INTEGER(4), PARAMETER       :: NP_2 = 2                             ! Second rotational harmonic
END MODULE Constants


      FUNCTION DARSIN(X)
      IMPLICIT REAL *8(A-H,O-Z)
      IF(DABS(X).LT.1.D0) GO TO 1
      DARSIN=DSIGN(1.D0,X)*1.5707963267948966D0
      RETURN
    1 IF(DABS(X).GT.1.D-7) GO TO 2
      DARSIN=X
      RETURN
    2 DARSIN=DATAN(X/DSQRT(1.D0-X**2))
      RETURN
      END


program SWETestCase2

use NumberKindsModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use EdgesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use PSEDirectSumModule
use SphereGeomModule
use SphereSWEModule
use SphereSWESolverModule

implicit none

include 'mpif.h'

! mesh variables
type(SWEMesh) :: sphere
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: meshSeed
integer(kint) :: amrLimit
integer(kint) :: faceKind
real(kreal), parameter :: radius = 1.0_kreal
namelist /meshDefine/ faceKind, initNest, maxNest, amrLimit

! test case variables
real(kreal), parameter :: u0 = 2.0_kreal * PI / 12.0_kreal
real(kreal), parameter :: g = 11490.1_kreal
real(kreal), parameter :: h0 = 0.00047055_kreal
real(kreal), parameter :: omg = 2.0_kreal * PI

!
! timestepping
!
type(SWESolver) :: solver
real(kreal) :: dt
real(kreal) :: t
real(kreal) :: tfinal
integer(kint) :: timeJ
integer(kint) :: nTimesteps
type(PSE) :: pseSetup

namelist /timestepping/ dt, tfinal

!
! i/o variables
!
character(len=MAX_STRING_LENGTH) :: outputDir
character(len=MAX_STRING_LENGTH) :: outputRoot
character(len=MAX_STRING_LENGTH) :: vtkFile
character(len=MAX_STRING_LENGTH) :: matlabFile
character(len=MAX_STRING_LENGTH) :: vtkRoot
character(len=MAX_STRING_LENGTH) :: meshString
integer(kint) :: frameOut
integer(kint) :: frameCounter
namelist /fileIO/ outputDir, outputRoot, frameOut

!
!	computing environment
!
type(Logger) :: exeLog
character(len=MAX_STRING_LENGTH) :: logstring
character(len=15) :: logKey = "SWE_TC2"
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
character(len=MAX_STRING_LENGTH) :: namelistFilename
integer(kint) :: mpiErrCode
real(kreal) :: programStart, programEnd

!--------------------------------
!	initialize : setup computing environment
!--------------------------------
call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD, numProcs, mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD, procRank, mpiErrCode)

call InitLogger(exeLog, procRank)

programStart = MPI_WTIME()

call ReadNamelistFile(procRank)

!--------------------------------
!	initialize : build mesh / problem setup
!--------------------------------

call New(sphere, meshSeed, initNest, maxNest, amrLimit, radius, omg, g)
call SetInitialRelVortOnMesh( sphere, TestCase2Vorticity )
call SetInitialDivergenceOnMesh( sphere, TestCase2Divergence )
call SetInitialVelocityOnMesh( sphere, TestCase2Velocity )
call SetInitialHOnMesh( sphere, TestCase2Height )
call SetInitialPotVortOnMesh(sphere)

call New(solver, sphere)
nTimesteps = floor(tfinal/dt)
t = 0.0_kreal
frameCounter = 1

call New(pseSetup, sphere%mesh)

if ( procRank == 0 ) then

	call LogStats(sphere, exeLog)

	if ( meshSeed == ICOS_TRI_SPHERE_SEED ) then
		write(meshString,'(A,I1,A)') '_icosTri', initNest, '_'
	elseif (meshSeed == CUBED_SPHERE_SEED ) then
		write(meshString,'(A,I1,A)') '_cubedSph', initNest, '_'
	endif

	write(vtkRoot,'(4A)') trim(outputDir), '/vtkOut/', trim(outputRoot), trim(meshString)
	write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), 0, '.vtk'

	call OutputToVTK( sphere, vtkFile )

	call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" t = ", t )
endif

!--------------------------------
!	run : evolve the problem in time (currently no remeshing)
!--------------------------------

do timeJ = 0, nTimesteps - 1

	call Timestep( solver, sphere, dt, pseSetup )
	call SetFieldToZero(sphere%divergence)

	t = real(timeJ + 1, kreal) * dt
	sphere%mesh%t = t

	if ( procRank == 0 .AND. mod(timeJ+1, frameOut) == 0 ) then
		write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'

		call OutputToVTK( sphere, vtkFile )
		frameCounter = frameCounter + 1

		call Logmessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" t = ", t)
	endif
enddo

!--------------------------------
!	finalize : clean up
!--------------------------------

programEnd = MPI_WTIME()
write(logstring,'(A,F12.2,A)') "PROGRAM COMPLETE : elapsed time ", programEnd - programStart, " seconds."
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" ", logstring)

call Delete(pseSetup)
call Delete(solver)
call Delete(sphere)

call MPI_FINALIZE(mpiErrCode)

contains

subroutine ReadNamelistFile( rank )
	integer(kint), intent(in) :: rank
	!
	character(len=MAX_STRING_LENGTH) :: namelistFilename
	integer(kint), parameter :: initBCAST_intSize = 5
	integer(kint), parameter :: initBCAST_realSize = 2
	integer(kint) :: readStat
	integer(kint), dimension(initBCAST_intSize) :: bcastIntegers
	real(kreal), dimension(initBCAST_realSize) :: bcastReals
	integer(kint) :: mpiErrCode

	if ( COMMAND_ARGUMENT_COUNT() /=1 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey), " ERROR: expected namelist file as 1st argument.")
		stop
	endif

	if ( rank == 0 ) then
		call GET_COMMAND_ARGUMENT(1, namelistFilename)

		open(unit=READ_UNIT, file=namelistFilename, status='OLD', action='READ', iostat=readStat)
			if ( readStat /= 0 ) then
				call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey), " ERROR: cannot read namelist file.")
				stop
			endif

			read(READ_UNIT, nml=meshDefine)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=timestepping)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=fileIO)
		close(READ_UNIT)

		if ( faceKind == 3 ) then
			meshSeed = ICOS_TRI_SPHERE_SEED
		elseif ( faceKind == 4) then
			meshSeed = CUBED_SPHERE_SEED
		else
			call LogMessage(exeLog, WARNING_LOGGING_LEVEL, trim(logkey)//" ReadNamelistFile WARNING : ", &
				" invalid faceKind -- using triangles.")
			meshSeed = ICOS_TRI_SPHERE_SEED
		endif

		if ( amrLimit == 0 ) maxNest = initNest

		bcastIntegers(1) = meshSeed
		bcastIntegers(2) = initNest
		bcastIntegers(3) = maxNest
		bcastIntegers(4) = amrLimit
		bcastIntegers(5) = frameOut

		bcastReals(1) = dt
		bcastReals(2) = tfinal
	endif

	call MPI_BCAST(bcastIntegers, initBCAST_intSize, MPI_INTEGER, 0, MPI_COMM_WORLD, mpiErrCode)
	if ( mpiErrCode /= 0 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey)//" bcastIntegers, MPI_BCAST ERROR : ", mpiErrCode)
	endif

	call MPI_BCAST(bcastReals, initBCAST_realSize, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, mpiErrCode)
	if ( mpiErrCode /= 0 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey)//" bcastReals, MPI_BCAST ERROR : ", mpiErrCode)
	endif

	meshSeed = bcastIntegers(1)
	initNest = bcastIntegers(2)
	maxNest = bcastIntegers(3)
	amrLimit = bcastIntegers(4)
	frameOut = bcastIntegers(5)

	dt = bcastReals(1)
	tfinal = bcastReals(2)
end subroutine

function TestCase2Vorticity( x, y, z)
!   Equation 94 from Williamson et al. 1992
	real(kreal) :: TestCase2Vorticity
	real(kreal), intent(in) :: x, y, z
	!
	real(kreal) :: lat
	lat = Latitude(x, y, z)
	TestCase2Vorticity = 2.0_kreal * u0 / radius * sin(lat)
end function

function TestCase2Height( x, y, z )
!   Equation 95 from Williamson et al. 1992
	real(kreal) :: TestCase2Height
	real(kreal), intent(in) :: x, y, z
	!
	real(kreal) :: lat
	lat = Latitude(x, y, z)
	TestCase2Height = h0 - ( radius * omg * u0 + 0.5_kreal * u0*u0 ) * ( sin(lat) * sin(lat) ) / g
end function

function TestCase2Divergence( x, y, z )
	real(kreal) :: TestCase2Divergence
	real(kreal), intent(in) :: x, y, z
	TestCase2Divergence = 0.0_kreal
end function

function TestCase2Velocity( x, y, z )
	real(kreal), dimension(3) :: TestCase2Velocity
	real(kreal), intent(in) :: x, y, z

	TestCase2Velocity(1) = -u0 * y
	TestCase2Velocity(2) =  u0 * x
	TestCase2Velocity(3) = 0.0_kreal
end function

subroutine InitLogger(log, rank)
	type(Logger), intent(inout) :: log
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		call New(log, logLevel)
	else
		call New(log, ERROR_LOGGING_LEVEL)
	endif
	write(logKey,'(A,I0.2,A)') trim(logKey)//"_", rank, ":"
end subroutine

end program


c     Demo using FINUFFT for double-precision 4d transforms in legacy fortran.
c     Does types 1,2,3, including math test against direct summation.
c     Default opts only (see simple1d1 for how to change opts).
c
c     A slight modification of drivers from the CMCL NUFFT, (C) 2004-2009,
c     Leslie Greengard and June-Yub Lee. See: cmcl_license.txt.
c
c     Tweaked by Alex Barnett to call FINUFFT 2/17/17.
c     dyn malloc; type 2 uses same input data fk0, 3/8/17
c     Also see: ../README.
c
c     Compile with, eg (GCC, multithreaded, static, paste to a single line):
c
c     gfortran nufft4d_demo.f ../directft/dirft4d.f -o nufft4d_demo
c     ../../lib-static/libfinufft.a -lstdc++ -lfftw3 -lfftw3_omp -lm -fopenmp
c
      program nufft4d_demo
      implicit none

c     our fortran-header, always needed
      include 'finufft.fh'
c
      integer i,ier,iflag,j,k1,k2,k3,k4,mx,n1,n2,n3,n4
      integer*8 ms,mt,mu,mv,nj,nk
      real*8, allocatable :: xj(:),yj(:),zj(:),pj(:),sk(:),tk(:),
     $                       uk(:),vk(:)
      real*8 err,pi,eps,salg,ealg
      parameter (pi=3.141592653589793238462643383279502884197d0)
      complex*16, allocatable :: cj(:),cj0(:),cj1(:),fk0(:),fk1(:)
c     for default opts, make a null pointer...
      type(nufft_opts), pointer :: defopts => null()
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
c
      ms = 24/2
      mt = 16/2
      mu = 18/2
      mv = 14/2
      n1 = 16/2
      n2 = 18/2
      n3 = 24/2
      n4 = 14/2
      nj = n1*n2*n3*n4
      nk = ms*mt*mu*mv
c     first alloc everything
      allocate(fk0(nk))
      allocate(fk1(nk))
      allocate(sk(nk))
      allocate(tk(nk))
      allocate(uk(nk))
      allocate(vk(nk))
      allocate(xj(nj))
      allocate(yj(nj))
      allocate(zj(nj))
      allocate(pj(nj))
      allocate(cj(nj))
      allocate(cj0(nj))
      allocate(cj1(nj))
      do k4 = -n4/2, (n4-1)/2
            do k3 = -n3/2, (n3-1)/2
                  do k2 = -n2/2, (n2-1)/2
                        do k1 = -n1/2, (n1-1)/2
                        j =  (k1+n1/2+1) + (k2+n2/2)*n1
     &                    + (k3+n3/2)*n1*n2 + (k4+n4/2)*n1*n2*n3
                        xj(j) = pi*dcos(-pi*k1/n1)
                        yj(j) = pi*dcos(-pi*k2/n2)
                        zj(j) = pi*dcos(-pi*k3/n3)
                        pj(j) = pi*dcos(-pi*k4/n4)
                        cj(j) = dcmplx(dsin(pi*j/n1),dcos(pi*j/n2))
                        enddo
                  enddo
            enddo
      enddo
c
c     -----------------------
c     start tests
c     -----------------------
c
      iflag = 1
      print*,'Starting 4D testing: ','nj =',nj,'ms,mt,mu,mv =',
     &        ms,mt,mu,mv
      do i = 1,4
         if (i.eq.1) eps=1d-4
         if (i.eq.2) eps=1d-8
         if (i.eq.3) eps=1d-12
         if (i.eq.4) eps=1d-16
c extended/quad precision tests
         if (i.eq.5) eps=1d-20
         if (i.eq.6) eps=1d-24
         if (i.eq.7) eps=1d-28
         if (i.eq.8) eps=1d-32
	 print*,' '
	 print*,' Requested precision eps =',eps
	 print*,' '
c
c     -----------------------
c     call 4D Type 1 method
c     -----------------------
c
         call dirft4d1(nj,xj,yj,zj,pj,cj,iflag,ms,mt,mu,mv,fk0)
         call finufft4d1(nj,xj,yj,zj,pj,cj,iflag,eps,ms,mt,mu,mv,
     &                  fk1,defopts,ier)
         print *, ' ier = ',ier
         call errcomp(fk0,fk1,nk,err)
         print *, ' type 1 error = ',err
c
c     -----------------------
c      call 4D Type 2 method
c     -----------------------
         call dirft4d2(nj,xj,yj,zj,pj,cj0,iflag,ms,mt,mu,mv,fk0)
         call finufft4d2(nj,xj,yj,zj,pj,cj1,iflag,eps,ms,mt,mu,mv,fk0,
     &        defopts,ier)
         print *, ' ier = ',ier
         call errcomp(cj0,cj1,nj,err)
         print *, ' type 2 error = ',err
c
c     -----------------------
c      call 4D Type3 method
c     -----------------------
         do k1 = 1, nk
            sk(k1) = 12*(dcos(k1*pi/nk))
            tk(k1) = 8*(dsin(-pi/2+k1*pi/nk))
            uk(k1) = 10*(dcos(k1*pi/nk))
            vk(k1) = 6*(dcos(-pi/2+k1*pi/nk))
      enddo

         call dirft4d3(nj,xj,yj,zj,pj,cj,iflag,nk,sk,tk,uk,vk,fk0)
         call finufft4d3(nj,xj,yj,zj,pj,cj,iflag,eps,nk,sk,tk,uk,vk,
     &                   fk1,defopts,ier)
         print *, ' ier = ',ier
         call errcomp(fk0,fk1,nk,err)
         print *, ' type 3 error = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer*8 k,n
      complex*16 fk0(n), fk1(n)
      real *8 salg,ealg,err
c
      ealg = 0d0
      salg = 0d0
      do k = 1, n
         ealg = ealg + cdabs(fk1(k)-fk0(k))**2
         salg = salg + cdabs(fk0(k))**2
      enddo
      err = sqrt(ealg/salg)
      return
      end


	SUBROUTINE VC_SGMA  ( p, ps, ptop, nxy, sgma, iret )
C************************************************************************
C* VC_SGMA								*
C*									*
C* This subroutine computes sigma coordinate values.			*
C*									*
C* VC_SGMA ( P, PS, PTOP, NXY, SGMA,  IRET )				*
C*									*
C* Input parameters:							*
C*	P  (NXY)	REAL		Pressure			*
C*	PS (NXY)	REAL		Surface pressure		*
C*	PTOP		REAL		Top pressure			*
C*	NXY		INTEGER		Number of grid points		*
C*									*
C* Output parameters:							*
C*	SGMA (NXY)	REAL		Output sigma values * 10000	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +1 = all missing		*
C**									*
C* Log:									*
C* K. Brill/NMC      06/92						*
C* R. Miller/COMET   06/94  Changed 100000 to 10000 for eta and sgma    *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		p (*), ps (*), sgma (*)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
	iret = 0
C
C*	Compute the sigma coordinate values.
C
	icnt = 0
	DO i = 1, nxy
	    IF ( ERMISS ( p (i) ) .or. ERMISS ( ps (i) ) ) THEN
		sgma (i) = RMISSD
		icnt = icnt + 1
	    ELSE
		sgma (i) = ( p (i) - ptop ) / ( ps (i) - ptop )
		sgma (i) = sgma (i) * 10000.
	    END IF
	END DO
C*
	IF ( icnt .eq. nxy ) iret = +1
C*
	RETURN
	END


subroutine set_implicit_boundary_data(t, x_lower_values, x_upper_values,  &
                                      y_lower_values, y_upper_values)

    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, intent(in) :: t
    double precision, dimension(2, my), intent(out) :: x_lower_values, x_upper_values
    double precision, dimension(2, mx), intent(out) :: y_lower_values, y_upper_values

    character(len=2), dimension(4, 10) :: bc_options
    common /bc_config/ bc_options

    integer :: order, ix, iy
    double precision, external :: true_solution, gen_derivative
    double precision, dimension(4, my) :: cell_values_my
    double precision, dimension(mx, 4) :: cell_values_mx
    double precision, dimension(4) :: cell_values

    if (bc_options(1, 1) /= 'p') then
        read(bc_options(1, 1), '(I1)') order
        do iy = 1, my
            call get_true_solution_by_index_range(-1, 2, iy, iy, t, cell_values)
            x_lower_values(1, iy) = gen_derivative(order, cell_values, dx)
        end do

        read(bc_options(2, 1), '(I1)') order
        do iy = 1, my
            call get_true_solution_by_index_range(mx-1, mx+2, iy, iy, t, cell_values)
            x_upper_values(1, iy) = gen_derivative(order, cell_values, dx)
        end do
    end if

    if (bc_options(3, 1) /= 'p') then
        read(bc_options(3, 1), '(I1)') order
        do ix = 1, my
            call get_true_solution_by_index_range(ix, ix, -1, 2, t, cell_values)
            y_lower_values(1, ix) = gen_derivative(order, cell_values, dy)
        end do

        read(bc_options(4, 1), '(I1)') order
        do ix = 1, my
            call get_true_solution_by_index_range(ix, ix, my-1, my+2, t, cell_values)
            y_upper_values(1, ix) = gen_derivative(order, cell_values, dy)
        end do
    end if

end subroutine set_implicit_boundary_data


!##############################################################################
! PROGRAM household4
!
! ## The life cycle model with portfolio choice
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog05_04m.f90"

program household4

    use globals
    use toolbox

    implicit none
    real*8 :: x(2*(1+n_w*n_R))
    real*8 :: fret, low(2*(1+n_w*n_R)), up(2*(1+n_w*n_R))
    real*8 :: wag(3,n_w*n_R,n_R), inc(3,n_w*n_R,n_R)
    real*8 :: sav(3,n_w*n_R,n_R), alp(3,n_w*n_R,n_R)
    real*8 :: E_st(2), Var_st(2), rho_st
    integer :: j, iw, ir2, ir3, ic, iwR

    ! set tolerance level of minimization routine
    call settol_min(1d-14)

    ! discretize w and R in period 2
    call log_normal_discrete((/n_w, n_R/), wR, weight_wR, &
        (/mu_w, mu_R/), (/sig_w, sig_R/), rho_wR)

    ! discretize log(R) in period 3
    call log_normal_discrete(R, weight_R, mu_R, sig_R)

    ! lower and upper border and initial guess
    low = 0d0
    up(1) = mu_w
    up(2) = 1d0
    ic = 3
    iwR = 1
    do iw = 1, n_w
        do ir2 = 1, n_R
            up(ic) = wR(iwR,2)*mu_w+wR(iwR,1)
            up(ic+1) = 1d0
            ic = ic+2
            iwR = iwR+1
        enddo
    enddo
    x = up/2d0

    ! minimization routine
    call fminsearch(x, fret, low, up, utility)

    ! set up data for output
    iwR = 1
    do iw = 1, n_w
        do ir2 = 1, n_R
            do ir3 = 1, n_R
                wag(1,iwR,ir3) = mu_w
                inc(1,iwR,ir3) = mu_w
                sav(1,iwR,ir3) = a(2,1)
                alp(1,iwR,ir3) = omega(1,1)*100d0

                wag(2,iwR,ir3) = wR(iwR,1)
                inc(2,iwR,ir3) = wR(iwR,1)+(Rf+omega(1,1)*(wR(iwR,2)-Rf))*a(2,1)
                sav(2,iwR,ir3) = a(3,iwR)
                alp(2,iwR,ir3) = omega(2,iwR)*100d0

                wag(3,iwR,ir3) = 0d0
                inc(3,iwR,ir3) = (Rf+omega(2,iwR)*(R(ir3)-Rf))*a(3,iwR)
                sav(3,iwR,ir3) = 0d0
                alp(3,iwR,ir3) = 0d0
            enddo
            iwR = iwR+1
        enddo
    enddo

    ! output
    write(*,'(/a/)')' AGE   CONS   WAGE    INC    SAV  SHARE'
    do j = 1, 3
        write(*,'(i4,5f7.2,a)')j,E(c(j,:,:)),E(wag(j,:,:)),&
            E(inc(j,:,:)),E(sav(j,:,:)),E(alp(j,:,:)),' (MEAN)'
        write(*,'(4x,5f7.2,a/)')Std(c(j,:,:)),Std(wag(j,:,:)),&
            Std(inc(j,:,:))/E(inc(j,:,:)),Std(sav(j,:,:)),Std(alp(j,:,:)),' (STD)'
    enddo

    ! calculate w and R statistics
    E_st(1) = sum(wR(:,1)*weight_wR)
    E_st(2) = sum(wR(:,2)*weight_wR)
    Var_st(1) = sum(wR(:,1)**2*weight_wR)-E_st(1)**2
    Var_st(2) = sum(wR(:,2)**2*weight_wR)-E_st(2)**2
    rho_st = sum((wR(:,1)-E_st(1))*(wR(:,2)-E_st(2))*weight_wR)/&
        sqrt(max(Var_st(1)*Var_st(2), 1d-10))

    write(*,'(/2(a,f6.2))')' E(w)  = ',E_st(1),'   Var(w)  = ', &
        Var_st(1)
    write(*,'(3(a,f6.2))')' E(R2) = ',E_st(2),'   Var(R2) = ', &
        Var_st(2),'   rho(w, R2) = ',rho_st
    write(*,'(2(a,f6.2))')' E(R3) = ',sum(weight_R*R),'   Var(R3) = ', &
        sum(weight_R*R**2)-sum(weight_R*R)**2

end program


program open_close_read_write
implicit none

character(len=20) :: msg = 'Some error occured'
real, dimension(100) :: x, y
real, dimension(100) :: p, q
integer, target :: i, u = 1
integer, pointer :: u_ptr;
u_ptr => u

do i = 1, 100
    x(i) = i * 0.1
    y(i) = sin(x(i)) * (1 - cos(x(i)/3.0))
end do

open(unit=u_ptr, file='data.dat', status='replace')
do i = 1, 100
    write(u, '(10F8.2)') x(i), y(i)
end do
close(1, err=999, iomsg=msg, iostat=u)

999 open (2, file='data.dat', status='old')
do i = 1, 100
    read(2, *) p(i), q(i)
end do
close(2)

do i = 1, 100
    write(*, *) p(i), q(i)
end do

end program


module module_kernels_par_multiply

    contains

subroutine map_result_array_8(input_array,factor,tsize,result_array)

    integer, Dimension(tsize), Intent(In) :: input_array
    integer, Intent(In) :: factor
    integer, Intent(In) :: tsize
    integer, Dimension(tsize), Intent(Out) :: result_array
    integer :: global_id
    call get_global_id(global_id,0)

    ! ParallelFortran: Synthesised loop variables
    i_rel = global_id
    i = (i_rel + 1)

    ! ParallelFortran: Original code
   result_array(i) = input_array(i)*factor

end subroutine map_result_array_8

end module module_kernels_par_multiply