!
!===============================================================================
!-- DEC Module
!> Module containing routines for performing DEC operations
!===============================================================================
!/****/h* modules|dec/dec_mod
!* SYNOPSIS
MODULE dec_mod
!* PURPOSE
!*   Module containing routines for performing DEC operations
!* INCLUDES
!*   Name                    Purpose
!*   common_mod              variable definitions
!*   mpi_mod                 ???
!*   math_mod                basic math functions
!* CONTAINS
!*   Subroutine              Purpose
!*   calc_orientation        sort nodal indices and compute ±1 orientation
!*   calc_bndry_cobndry      recursively compute element (co-)boundaries
!*   build_bndry_work_array  build boundary data working array
!*   count_bndry_cobndry     count [co-]boundaries: internal, external, surface
!*   set_bndry_cobndry       set [co-]boundaries: internal, external, surface
!*   initialise_geo          initialise geometric quantities for the given mesh
!*   get_lcl_node_indx       create map between global and local node indices
!*   calc_circumcenters      compute circumcenter of given elements
!*   calc_prml_sgnd_vlm      compute signed volume of primal elements
!*   calc_prml_unsgnd_vlm    compute unsigned volume of primal elements
!*   calc_dual_vlm           compute volume for dual elements of all geometric order
!*   calc_dual_vlm_i         recursively add to dual volume calculation
!*   add_points_i            recursively adds points for dual volume calculation
!*   calc_unsgnd_vlm         compute unsigned volume for given set of points
!*   exchange_dual_vlm       exchange external dual volumes between adjacent processes
!*   exchange_dual_dir       exchange external dual edge directions between adjacent processes
!*   calc_prml_unsgnd_vlm    compute unsigned volume of primal elements
!*   calc_hodge_star         compute hodge star and it's inverse from primal and dual volumes
!*   calc_prml_dir           compute the unit direction of primal edges
!*   calc_dual_dir           compute the unit direction of dual edges
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2020/09/16: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2020/09/16
!> Module containing routines for performing DEC operations
!===============================================================================

  !-- use statements and implicit none --
  USE common_mod
  USE mpi_mod
  USE math_mod

  IMPLICIT NONE

!===============================================================================
CONTAINS
!===============================================================================
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_orientation
!* SYNOPSIS
  SUBROUTINE calc_orientation(elm,orientation)
!* PURPOSE
!*   Sort nodal indices and compute ± orientation of an element
!* INPUTS
!*   Name                    Description
!*   elem
!*   orientation
!* OUTPUTS
!*   Name                    Description
!*   elem
!*   orientation
!* SIDE EFFECTS
!*   - the nodal indices of elm are sorted numerically in ascending order
!*   - orientation contains the ±1 orientation of the element
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!* NOTES
!*   Procedure adapted from:
!*   https://rosettacode.org/wiki/Sorting_algorithms/Insertion_sort#Fortran
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Sort nodal indices and compute ± orientation of an element
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER, INTENT(INOUT) :: elm(:)           !> nodal indices of elements
    INTEGER, INTENT(INOUT) :: orientation      !> orientations of the elements

    !-- local variables --
    INTEGER                :: i,j              !> loop counters
    INTEGER                :: length           !> size of elm array
    INTEGER                :: work             !> work variable

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- check size of argument --
    length  = SIZE(elm,DIM=1)

    !-------------------------------------------------------------------------
    !-- sort indices using insertion sort and count the number of swaps --
    !-------------------------------------------------------------------------
    orientation = 0
    !-- loop through all indices, starting from the second --
    DO i = 2, length
      !-- get next value to insert --
      work = elm(i)
      j = i - 1
      !-- find location to insert given value --
      DO WHILE (j >= 1)
        !-- ??? found location ??? --
        IF (elm(j) <= work) EXIT
        !-- shuffle (swap) values --
        elm(j + 1) = elm(j)
        j = j - 1
        !-- count swaps --
        orientation = orientation + 1
      END DO
      !-- insert value --
      elm(j + 1) = work
    END DO

    !-- compute orientation from number of swaps --
    orientation = 1 - 2*MOD(orientation,2)

    RETURN

  END SUBROUTINE
! dec_mod/calc_orientation
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_bndry_cobndry
!* SYNOPSIS
  SUBROUTINE calc_bndry_cobndry()
!* PURPOSE
!*   Recursively compute element (co-)boundaries from highest to lowest geometric order
!* ASSUMPTION
!*   Mesh is a simplicial complex in TetGen format
!* SIDE EFFECTS
!*   - the nodal indices of elm are sorted numerically in ascending order
!*   - orientation contains the ±1 orientation of the element
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2020/09/16: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/20
!> Recursively compute element (co-)boundaries from highest to lowest geometric order
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- local variables --
    INTEGER               :: k              !> simplicial order

    INTEGER, ALLOCATABLE  :: bndry(:,:)     !> temp. boundary work array
    INTEGER, ALLOCATABLE  :: bndry_cnt(:)   !> counter local boundaries
    INTEGER, ALLOCATABLE  :: cobndry_cnt(:) !> counter co-boundaries

    INTEGER               :: cnt            !> counter boundaries
    INTEGER               :: ext_cnt(2)     !> counter external boundaries
    INTEGER               :: surf_cnt       !> counter surface boundaries

    INTEGER, ALLOCATABLE  :: work(:,:)      !> work array for merge sort
    LOGICAL, ALLOCATABLE  :: lwork(:)       !> work array to determine locality

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !-- calculate signed adjacency [co-boundary operator] --
    !-- loop for each geometric order in complex in descending order --
    DO k=dim_cmplx+1,2,-1
      CALL syncwrite_log('===============================================================')
      !-- initial guess for the number of boundaries --
      num_elm(k-1) = k*num_elm(k)

      !-- build working array with element/boundary data --
      CALL syncwrite_log('> parallel_setup() - calc_bndry_cobndry '//&
        '- build_bndry_work_array')
      ALLOCATE(bndry(num_elm(k-1),k+2))
      CALL build_bndry_work_array(bndry,k);   CALL syncwrite_log_time()

      !-- sort working array --
      CALL syncwrite_log('> parallel_setup() - calc_bndry_cobndry '//&
        '- int_merge_sort_rows')
      ALLOCATE(work(num_elm(k-1),k+2))
      CALL int_merge_sort_rows(bndry,num_elm(k-1),1,k-1,work)
      DEALLOCATE(work);   CALL syncwrite_log_time()

      !-- count number of unique (local/external/surface) [co-]boundaries --
      CALL syncwrite_log('> parallel_setup() - calc_bndry_cobndry '//&
        '- count_bndry_cobndry')
      ALLOCATE(bndry_cnt(num_elm(k)),cobndry_cnt(num_elm(k-1)),&
        lwork(num_elm(k)*k))
      CALL count_bndry_cobndry(bndry,k,cnt,bndry_cnt,cobndry_cnt,ext_cnt,&
        surf_cnt,lwork);   CALL syncwrite_log_time()

      !-- allocate [co-]boundary structures and variables --
      CALL syncwrite_log('> parallel_setup() - calc_bndry_cobndry '//&
        '- allocate_bndry_cobndry')
      CALL allocate_bndry_cobndry(k,cnt,bndry_cnt,cobndry_cnt,ext_cnt,surf_cnt)
      CALL syncwrite_log_time()

      !-- setup boundaries external to the current process (not local),
      !   setup parallel mapping, setup node indices for (k-1)^th order element
      !   structure, and setup co-boundaries for (k-1)^th order element
      !   structure --
      CALL syncwrite_log('> parallel_setup() - calc_bndry_cobndry '//&
        '- set_bndry_cobndry')
      CALL set_bndry_cobndry(bndry,k,cnt,bndry_cnt,cobndry_cnt,ext_cnt,&
        surf_cnt,lwork);   CALL syncwrite_log_time()

      !-- clean up temporary variables --
      DEALLOCATE(bndry,bndry_cnt,cobndry_cnt,lwork)
    END DO
    CALL syncwrite_log('===============================================================')

    RETURN

  END SUBROUTINE
! dec_mod/calc_bndry_cobndry
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/build_bndry_work_array
!* SYNOPSIS
  SUBROUTINE build_bndry_work_array(bndry,k)
!* PURPOSE
!*   Build boundary data working array
!* INPUTS
!*   Name                    Description
!*
!* OUTPUTS
!*   Name                    Description
!*
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Build boundary data working array
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER, INTENT(INOUT)  :: bndry(:,:)     !> boundary work array
    INTEGER, INTENT(IN)     :: k              !> simplicial order

    !-- local variables --
    INTEGER                 :: i,j            !> loop index
    INTEGER                 :: iib,fib        !> array initial/final index

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    iib = 1;   fib = num_elm(k)
    DO i=1,k
      !-- get boundary node indices --
      bndry(iib:fib,1:i-1) = lcl_complex(k)%node_indx(:,1:i-1)
      bndry(iib:fib,i:k-1) = lcl_complex(k)%node_indx(:,i+1:k)

      !-- get simplex indices --
      bndry(iib:fib,k)   = (/ (j, j=1,num_elm(k)) /)
      bndry(iib:fib,k+1) = i

      !-- get orientation --
      IF (k == dim_cmplx+1) THEN
        bndry(iib:fib,k+2)  = (-1)**i*lcl_complex(k)%orientation
      ELSE
        bndry(iib:fib,k+2)  = (-1)**i
      END IF

      !-- update array indices --
      iib = iib + num_elm(k)
      fib = fib + num_elm(k)
    END DO

    RETURN

  END SUBROUTINE
! dec_mod/build_bndry_work_array
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/count_bndry_cobndry
!* SYNOPSIS
  SUBROUTINE count_bndry_cobndry(bndry,k,cnt,bndry_cnt,cobndry_cnt,ext_cnt,&
    surf_cnt,local)
!* PURPOSE
!*   Count [co-]boundaries: internal, external, surface
!* INPUTS
!*   Name                    Description
!*
!* OUTPUTS
!*   Name                    Description
!*
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Count [co-]boundaries: internal, external, surface
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER, INTENT(IN)     :: k                !> simplicial order
    INTEGER, INTENT(IN)     :: bndry(:,:)       !> boundary work array
    INTEGER, INTENT(INOUT)  :: bndry_cnt(:)     !> counter local boundaries
    INTEGER, INTENT(INOUT)  :: cobndry_cnt(:)   !> counter co-boundaries
    INTEGER, INTENT(INOUT)  :: cnt              !> counter (k-1) element
    INTEGER, INTENT(INOUT)  :: ext_cnt(2)       !> counter external boundaries
    INTEGER, INTENT(INOUT)  :: surf_cnt         !> counter surface boundaries
    LOGICAL, INTENT(INOUT)  :: local(:)         !> locality work array

    !-- local variables --
    INTEGER                 :: i                !> counter

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- reset counters --
    cnt = 0; bndry_cnt = 0; cobndry_cnt = 0; ext_cnt = 0; surf_cnt = 0

    !-- loop for all boundaries --
    DO i = 1, num_elm(k)*k
      IF (i == 1 .OR. ANY(bndry(i,1:k-1) /= bndry(max(1,i-1),1:k-1))) THEN
        !-- boundary different from previous: new boundary --
        cnt = cnt + 1
        IF (any_element_in_list(bndry(i,1:k-1),lcl_complex(1)%glb_indx)) THEN
          !-- boundary is local --
          local(i) = .TRUE.
          IF (ANY(bndry(i,1:k-1) /= bndry(min(i+1,num_elm(k)*k),1:k-1)) .OR. &
            i == num_elm(k)*k) THEN
            !-- boundary is unique: count surface boundaries --
            surf_cnt = surf_cnt + 1
          ELSE
            !-- boundary is NOT unique: count local boundaries --
            bndry_cnt(bndry(i,k)) = bndry_cnt(bndry(i,k)) + 1
          END IF
          !-- count number of co-boundaries for each local boundary --
          cobndry_cnt(cnt) = cobndry_cnt(cnt) + 1
        ELSE
          local(i) = .FALSE.
          !-- boundary is non-local: count external boundaries --
          ext_cnt = ext_cnt + 1
        END IF
      ELSE
        !-- boundary same as previous --
        IF (any_element_in_list(bndry(i,1:k-1),lcl_complex(1)%glb_indx)) THEN
          !-- boundary is local --
          local(i) = .TRUE.
          !-- count local boundaries --
          bndry_cnt(bndry(i,k)) = bndry_cnt(bndry(i,k)) + 1
          !-- count number of co-boundaries for each local boundary --
          cobndry_cnt(cnt) = cobndry_cnt(cnt) + 1
        ELSE
          local(i) = .FALSE.
          !-- boundary is non-local: count external boundaries --
          ext_cnt(1) = ext_cnt(1) + 1
        END IF
      END IF
    END DO

    RETURN

  END SUBROUTINE
! dec_mod/count_bndry_cobndry
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/allocate_bndry_cobndry
!* SYNOPSIS
  SUBROUTINE allocate_bndry_cobndry(k,cnt,bndry_cnt,cobndry_cnt,ext_cnt,&
    surf_cnt)
!* PURPOSE
!*   Allocate [co-]boundaries structures/variables
!* INPUTS
!*   Name                    Description
!*
!* OUTPUTS
!*   Name                    Description
!*
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Allocate [co-]boundaries structures/variables
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER, INTENT(IN)     :: k                !> simplicial order
    INTEGER, INTENT(IN)     :: bndry_cnt(:)     !> temp # local boundaries
    INTEGER, INTENT(IN)     :: cobndry_cnt(:)   !> temp # co-boundaries
    INTEGER, INTENT(IN)     :: cnt              !> counter (k-1) element
    INTEGER, INTENT(IN)     :: ext_cnt(2)       !> counter external boundaries
    INTEGER, INTENT(IN)     :: surf_cnt         !> counter surface boundaries

    !-- local variables --
    INTEGER                 :: i                !> counter

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- allocate boundary structures and variables: k^th order --
    !-- # external boundaries and # expect MPI receives --
    lcl_complex(k)%num_ext = ext_cnt(1)
    lcl_complex(k)%num_recv = ext_cnt(2)
    ALLOCATE(&
      lcl_complex(k)%ext_indx(ext_cnt(1),3),&
      lcl_complex(k)%recv_indx(ext_cnt(2),2))
    !-- # surface boundaries --
    lcl_complex(k)%num_surf = surf_cnt
    ALLOCATE(lcl_complex(k)%surf_indx(surf_cnt,4))
    !-- # internal boundaries --
    ALLOCATE(&
      lcl_complex(k)%num_bndry(num_elm(k)),&
      lcl_complex(k)%bndry(num_elm(k)))
    lcl_complex(k)%num_bndry = bndry_cnt
    DO i=1,num_elm(k)
      ALLOCATE(&
        lcl_complex(k)%bndry(i)%sgn(lcl_complex(k)%num_bndry(i)),&
        lcl_complex(k)%bndry(i)%indx(lcl_complex(k)%num_bndry(i)))
    END DO

    !-- allocate [co-]boundary structures and variables: (k-1))^th order --
    !-- # (k-1))^th order elements --
    num_elm(k-1) = cnt
    ALLOCATE(lcl_complex(k-1)%node_indx(num_elm(k-1),k-1))
    !-- # (k-1))^th order coboundaries --
    ALLOCATE(&
      lcl_complex(k-1)%num_cobndry(num_elm(k-1)),&
      lcl_complex(k-1)%cobndry(num_elm(k-1)))
    lcl_complex(k-1)%num_cobndry = cobndry_cnt(1:num_elm(k-1))
    DO i=1,num_elm(k-1)
      ALLOCATE(&
        lcl_complex(k-1)%cobndry(i)%sgn(cobndry_cnt(i)),&
        lcl_complex(k-1)%cobndry(i)%indx(cobndry_cnt(i)))
    END DO

    RETURN

  END SUBROUTINE
! dec_mod/allocate_bndry_cobndry
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/set_bndry_cobndry
!* SYNOPSIS
  SUBROUTINE set_bndry_cobndry(bndry,k,cnt,bndry_cnt,cobndry_cnt,ext_cnt,surf_cnt,local)
!* PURPOSE
!*   Set [co-]boundaries: internal, external, surface
!* INPUTS
!*   Name                    Description
!*
!* OUTPUTS
!*   Name                    Description
!*
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Set [co-]boundaries: internal, external, surface
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER, INTENT(IN)     :: k                !> simplicial order
    INTEGER, INTENT(INOUT)  :: bndry(:,:)       !> boundary work array
    INTEGER, INTENT(INOUT)  :: bndry_cnt(:)     !> temp # local boundaries
    INTEGER, INTENT(INOUT)  :: cobndry_cnt(:)   !> temp # co-boundaries
    INTEGER, INTENT(INOUT)  :: cnt              !> counter (k-1) element
    INTEGER, INTENT(INOUT)  :: ext_cnt(2)       !> counter external boundaries
    INTEGER, INTENT(INOUT)  :: surf_cnt         !> counter surface boundaries
    LOGICAL, INTENT(INOUT)  :: local(:)         !> locality work array

    !-- local variables --
    INTEGER                 :: i                !> counter

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- reset counters --
    cnt = 0;  bndry_cnt = 0;  cobndry_cnt = 0;  ext_cnt = 0;  surf_cnt = 0

    !-- loop for all boundaries --
    DO i = 1, num_elm(k)*k
      IF (i == 1 .OR. ANY(bndry(i,1:k-1) /= bndry(max(1,i-1),1:k-1))) THEN
        !-- boundary different from previous: new boundary --
        cnt = cnt + 1
        IF (local(i)) THEN
          !-- boundary is local --
          IF (ANY(bndry(i,1:k-1) /= bndry(min(i+1,num_elm(k)*k),1:k-1)) .OR. &
            i == num_elm(k)*k) THEN
            !-- boundary is unique: set signed adjacency for surface boundaries --
            surf_cnt = surf_cnt + 1
            lcl_complex(k)%surf_indx(surf_cnt,:) = (/ -bndry(i,k+2), cnt, bndry(i,k) /)
          ELSE
            !-- boundary is NOT unique: set signed adjacency for local boundaries --
            bndry_cnt(bndry(i,k)) = bndry_cnt(bndry(i,k)) + 1
            lcl_complex(k)%bndry(bndry(i,k))%sgn(bndry_cnt(bndry(i,k))) = bndry(i,k+2)
            lcl_complex(k)%bndry(bndry(i,k))%indx(bndry_cnt(bndry(i,k))) = cnt
          END IF
          !-- set signed adjacency for co-boundaries for each local boundary --
          cobndry_cnt(cnt) = 1
          lcl_complex(k-1)%cobndry(cnt)%sgn(1) = bndry(i,k+2)
          lcl_complex(k-1)%cobndry(cnt)%indx(1) = bndry(i,k)
        ELSE
          !-- boundary is non-local: set signed adjacency for external boundaries --
          ext_cnt = ext_cnt + 1
          lcl_complex(k)%ext_indx(ext_cnt(1),:) = (/ bndry(i,k+2), cnt, bndry(i,k) /)
          lcl_complex(k)%recv_indx(ext_cnt(2),:) = (/ elm2proc(bndry(i,1)), cnt /)                          !????? find actual global index
        END IF
        !-- set node indices for (k-1)^th order elements --
        lcl_complex(k-1)%node_indx(cnt,:) = bndry(i,1:k-1)
      ELSE
        !-- boundary same as previous --
        IF (local(i)) THEN
          !-- boundary is local: set signed adjacency for local boundaries --
          bndry_cnt(bndry(i,k)) = bndry_cnt(bndry(i,k)) + 1
          lcl_complex(k)%bndry(bndry(i,k))%sgn(bndry_cnt(bndry(i,k))) = bndry(i,k+2)
          lcl_complex(k)%bndry(bndry(i,k))%indx(bndry_cnt(bndry(i,k))) = cnt
          !-- set signed adjacency for co-boundaries for each local boundary --
          cobndry_cnt(cnt) = cobndry_cnt(cnt) + 1
          lcl_complex(k-1)%cobndry(cnt)%sgn(cobndry_cnt(cnt)) = bndry(i,k+2)
          lcl_complex(k-1)%cobndry(cnt)%indx(cobndry_cnt(cnt)) = bndry(i,k)
        ELSE
          !-- boundary is non-local: set signed adjacency for external boundaries --
          ext_cnt(1) = ext_cnt(1) + 1
          lcl_complex(k)%ext_indx(ext_cnt(1),:) = (/ bndry(i,k+2), cnt, bndry(i,k) /)
        END IF
      END IF
    END DO

    RETURN

  END SUBROUTINE
! dec_mod/set_bndry_cobndry
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/initialise_geo
!* SYNOPSIS
  SUBROUTINE initialise_geo()
!* PURPOSE
!*   Initialise geometric quantities for the given mesh
!* INPUTS
!*   Name                    Description
!*
!* OUTPUTS
!*   Name                    Description
!*
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Initialise geometric quantities for the given mesh
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- local variables --
    INTEGER                 :: i,k               !> loop counters
    REAL(KIND=iwp)          :: minV,maxV,absminV !> min/max volumes
    CHARACTER(LEN=slen)     :: str               !> string for writing to log file

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    CALL syncwrite_log('> initialise_geo()')
    curnt_time = MPI_WTIME()

    !-- log element information --
    DO k =1,dim_cmplx+1
      write(str,'(A,I1,A,I10)') '   - number of C',k-1,': ',glb_num_elm(k)
      CALL rootwrite_log(str)
    END DO

    !-- get local node indices --
    CALL get_lcl_node_indx()

    !-- compute circumcenters --
    DO k =2,dim_cmplx+1
      CALL calc_circumcenters(k)
    END DO

    !-- compute signed primal volumes --
    IF (.NOT. ALLOCATED(lcl_complex(1)%prml_volume)) &
      ALLOCATE(lcl_complex(1)%prml_volume(num_elm(1)))
    lcl_complex(1)%prml_volume = 1
    DO k =2,dim_cmplx+1
      IF (k-1==dim_embbd) THEN
        CALL calc_prml_sgnd_vlm(k)
      ELSE
        CALL calc_prml_unsgnd_vlm(k)
      END IF
    END DO

    !-- compute signed dual volumes --
    CALL calc_dual_vlm()
    DO k =1,dim_cmplx
      CALL exchange_dual_vlm(k)
    END DO

    !-- assess maximumm and minimum volumes --
    DO k =1,dim_cmplx+1
      CALL MPI_REDUCE(minval(lcl_complex(k)%prml_volume),minV,1,&
        MPI_DOUBLE_PRECISION,MPI_MIN,0,MPI_COMM_WORLD,ier)
      CALL MPI_REDUCE(minval(abs(lcl_complex(k)%prml_volume)),absminV,1,&
        MPI_DOUBLE_PRECISION,MPI_MIN,0,MPI_COMM_WORLD,ier)
      CALL MPI_REDUCE(maxval(lcl_complex(k)%prml_volume),maxV,1,&
        MPI_DOUBLE_PRECISION,MPI_MAX,0,MPI_COMM_WORLD,ier)
      IF (rank == root) &
        write(str,'(A,I1,A,ES10.3,A,ES10.3,A,ES10.3)') '   - The min/abs(min)/max C',k-1,&
          ' volume is: ',minV,'/',absminV,'/',maxV
      CALL syncwrite_log(str)

      CALL MPI_REDUCE(minval(lcl_complex(k)%dual_volume),minV,1,&
        MPI_DOUBLE_PRECISION,MPI_MIN,0,MPI_COMM_WORLD,ier)
      CALL MPI_REDUCE(minval(abs(lcl_complex(k)%dual_volume)),absminV,1,&
        MPI_DOUBLE_PRECISION,MPI_MIN,0,MPI_COMM_WORLD,ier)
      CALL MPI_REDUCE(maxval(lcl_complex(k)%dual_volume),maxV,1,&
        MPI_DOUBLE_PRECISION,MPI_MAX,0,MPI_COMM_WORLD,ier)
      IF (rank == root) &
        write(str,'(A,I1,A,ES10.3,A,ES10.3,A,ES10.3)') '   - The min/abs(min)/max D',dim_cmplx+1-k,&
          ' volume is: ',minV,'/',absminV,'/',maxV
      CALL syncwrite_log(str)
    END DO

    !-- compute Hodge stars --
    DO k = 1,dim_cmplx+1
      CALL calc_hodge_star(k)
    END DO

    !-- compute primal and dual edge directions --
    CALL calc_prml_dir()
    CALL calc_dual_dir()

    !-- log time to initialise the geometric information --
    CALL syncwrite_log_time()

    RETURN

  END SUBROUTINE
! dec_mod/initialise_geo
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/get_lcl_node_indx
!* SYNOPSIS
  SUBROUTINE get_lcl_node_indx()
!* PURPOSE
!*   Create map between global and local node indices
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Create map between global and local node indices
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- local variables --
    INTEGER                 :: i,k,m,n        !> loop counters

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- allocate array for map and assign default value --
    DO k = 2, dim_cmplx+1
      IF (.NOT. ALLOCATED(lcl_complex(k)%lcl_node_indx)) &
        ALLOCATE(lcl_complex(k)%lcl_node_indx(num_elm(k),k))
      lcl_complex(k)%lcl_node_indx = -1
    END DO

    !-- build map --
    DO k = 2, dim_cmplx+1     !-- simplicial order --
      DO i=1,num_elm(1)       !-- local node index --
        DO n = 1,k            !-- element node index --
          DO m=1,num_elm(k)   !-- element index --
            IF (lcl_complex(k)%node_indx(m,n) == lcl_complex(1)%glb_indx(i)) &
              lcl_complex(k)%lcl_node_indx(m,n) = i
          END DO
        END DO
      END DO
    END DO

    RETURN

  END SUBROUTINE
! dec_mod/get_lcl_node_indx
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_circumcenters
!* SYNOPSIS
  SUBROUTINE calc_circumcenters(k)
!* PURPOSE
!*   Compute circumcenter of given elements
!* INPUTS
!*   Name                    Description
!*
!* OUTPUTS
!*   Name                    Description
!*
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Compute circumcenter of given elements
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER                     :: k                !> simplicial order

    !-- local variables --
    INTEGER                     :: kp               !> simplicial order plus one
    INTEGER                     :: i,j              !> loop indices
    REAL(KIND=iwp), ALLOCATABLE :: A(:,:),b(:)      !> solution variables
    REAL(KIND=iwp), ALLOCATABLE :: pts(:,:)         !> bounding points
    REAL(KIND=iwp), ALLOCATABLE :: ipiv(:),work(:)  !> work arrays

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- allocate centers and temp. variables --
    kp=k+1
    IF (.NOT. ALLOCATED(lcl_complex(k)%centers)) &
      ALLOCATE(lcl_complex(k)%centers(num_elm(k),dim_embbd))
    ALLOCATE(pts(k,dim_embbd),A(kp,kp),b(kp),ipiv(kp),work(kp))

    !-- compute circumcenters for all elements --
    !-- loop through all elements of this order --
    DO i = 1, num_elm(k)
      !-- get bounding points of the element --
      DO j = 1,k
        pts(j,:) = lcl_complex(1)%centers(lcl_complex(k)%lcl_node_indx(i,j),:)
      END DO

      !-- setup system to compute circumcenter --
      A(1:k,1:k) = 2*MATMUL(pts,TRANSPOSE(pts))
      A(1:k,kp) = 1;  A(kp,1:k) = 1;  A(kp,kp) = 0
      b(1:k) = sum(pts*pts,DIM=2)
      b(kp) = 1

      !-- solve system to compute circumcenter --
      CALL DSYSV('L',kp,1,A,kp,ipiv,b,kp,work,kp,ier)

      !-- assign circumcenter --
      lcl_complex(k)%centers(i,:) = MATMUL(b(1:k),pts)
    END DO

    !-- clean up --
    DEALLOCATE(pts,A,b,ipiv,work)

    RETURN

  END SUBROUTINE
! dec_mod/calc_circumcenters
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_prml_sgnd_vlm
!* SYNOPSIS
  SUBROUTINE calc_prml_sgnd_vlm(k)
!* PURPOSE
!*   Compute signed volume of primal elements
!* INPUTS
!*   Name                    Description
!*   k
!* OUTPUTS
!*   Name                    Description
!*   k
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Compute signed volume of primal elements
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER                     :: k            !> simplicial order

    !-- local variables --
    INTEGER                     :: i,j          !> loop counters
    INTEGER                     :: fac          !> factorial
    REAL(KIND=iwp), ALLOCATABLE :: A(:,:)       !> solution variable
    REAL(KIND=iwp), ALLOCATABLE :: pts(:)       !> bounding points

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- allocate volumes and temp. variables --
    IF (.NOT. ALLOCATED(lcl_complex(k)%prml_volume)) &
      ALLOCATE(lcl_complex(k)%prml_volume(num_elm(k)))
    ALLOCATE(pts(dim_embbd),A(dim_embbd,dim_embbd))

    !-- compute factorial of embedding dimension --
    fac = 1
    DO i=2,dim_embbd
      fac = fac*i
    END DO

    !-- compute signed volumes --
    !-- loop through all elements --
    DO i = 1, num_elm(k)
      !-- get a bounding point of the element --
      pts(:) = lcl_complex(1)%centers(lcl_complex(k)%lcl_node_indx(i,1),:)

      !-- build system matrix from bounding points of the element --
      DO j = 1,k-1
        A(j,:) = lcl_complex(1)%centers(lcl_complex(k)%lcl_node_indx(i,j+1),:) - pts
      END DO

      !-- compute and assign signed volume --
      lcl_complex(k)%prml_volume(i) = lcl_complex(k)%orientation(i)*determinant(A,dim_embbd)/fac
    END DO

    !-- clean up --
    DEALLOCATE(pts,A)

    RETURN

  END SUBROUTINE
! dec_mod/calc_prml_sgnd_vlm
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_prml_unsgnd_vlm
!* SYNOPSIS
  SUBROUTINE calc_prml_unsgnd_vlm(k)
!* PURPOSE
!*   Compute unsigned volume of primal elements
!* INPUTS
!*   Name                    Description
!*   k
!* OUTPUTS
!*   Name                    Description
!*   k
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Compute unsigned volume of primal elements
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER                     :: k            !> loop counters

    !-- local variables --
    INTEGER                     :: i,j          !> loop counters
    INTEGER                     :: fac          !> factorial
    REAL(KIND=iwp), ALLOCATABLE :: A(:,:)       !> solution variable
    REAL(KIND=iwp), ALLOCATABLE :: pts(:)       !> bounding points

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- allocate volumes and temp. variables --
    IF (.NOT. ALLOCATED(lcl_complex(k)%prml_volume)) &
      ALLOCATE(lcl_complex(k)%prml_volume(num_elm(k)))
    ALLOCATE(pts(dim_embbd),A(k-1,dim_embbd))

    !-- compute necessary factorial --
    fac = 1
    DO i=2,k-1
      fac = fac*i
    END DO

    !-- compute unsigned volumes --
    !-- loop for all elements --
    DO i = 1, num_elm(k)
      !-- get a bounding point of the element --
      pts(:) = lcl_complex(1)%centers(lcl_complex(k)%lcl_node_indx(i,1),:)

      !-- build system matrix from remaining bounding points of the element --
      DO j = 1,k-1
        A(j,:) = lcl_complex(1)%centers(lcl_complex(k)%lcl_node_indx(i,j+1),:) - pts
      END DO

      !-- compute and assign unsigned volume --
      lcl_complex(k)%prml_volume(i) = SQRT(ABS(determinant(MATMUL(A,TRANSPOSE(A)),k-1)))/fac
    END DO

    !-- clean up --
    DEALLOCATE(pts,A)

    RETURN

  END SUBROUTINE
! dec_mod/calc_prml_unsgnd_vlm
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_dual_vlm
!* SYNOPSIS
  SUBROUTINE calc_dual_vlm()
!* PURPOSE
!*   Compute volume for dual elements of all geometric order
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Compute volume for dual elements of all geometric order
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- local variables --
    INTEGER                 :: k                !> simplicial order
    INTEGER                 :: i,indx           !> loop counters
    REAL(KIND=iwp), ALLOCATABLE :: pts(:,:)     !> bounding points
    REAL(KIND=iwp), ALLOCATABLE :: sgn(:)       !> sign of volume elements

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- allocate volumes and temp. variables --
    DO k = 1,dim_cmplx+1
      IF (.NOT. ALLOCATED(lcl_complex(k)%dual_volume)) &
        ALLOCATE(lcl_complex(k)%dual_volume(num_elm(k)))
      lcl_complex(k)%dual_volume = 0.d0
    END DO
    ALLOCATE(pts(dim_cmplx+1,dim_embbd),sgn(dim_cmplx))
    sgn = 1.d0

    !-- start recursive computation of dual volumes on the interior --
    k = dim_cmplx+1
    DO i = 1, num_elm(k)
      CALL calc_dual_vlm_i(pts,sgn,i,i,k)
    END DO

    !-- start recurve addition of contributions from the surfaces --
    k = dim_cmplx+1
    DO i = 1, lcl_complex(k)%num_surf
      indx = lcl_complex(k)% surf_indx(i,2)
      CALL add_points_i(pts,indx,k-1)
      CALL calc_dual_vlm_i(pts,sgn,indx,lcl_complex(k)% surf_indx(i,3),k-1)
    END DO

    !-- clean up --
    DEALLOCATE(pts,sgn)

    RETURN

  END SUBROUTINE
! dec_mod/calc_dual_vlm
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_dual_vlm_i
!* SYNOPSIS
  RECURSIVE SUBROUTINE calc_dual_vlm_i(pts,sgn,indx,p_indx,k)
!* PURPOSE
!*   Recursively add to dual volume calculation
!* INPUTS
!*   Name                    Description
!*
!* OUTPUTS
!*   Name                    Description
!*
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Recursively add to dual volume calculation
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER, INTENT(IN)           :: k            !> simplicial order
    INTEGER, INTENT(IN)           :: indx,p_indx  !> element and parent index
    REAL(KIND=iwp), INTENT(INOUT) :: pts(:,:)     !> bounding points
    REAL(KIND=iwp), INTENT(INOUT) :: sgn(:)       !> sign of volume elements

    !-- local variables --
    INTEGER                       :: i            !> loop counters
    INTEGER                       :: t_indx       !> tmp index
    INTEGER                       :: n            !> number of points

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- add to array of bounding points --
    pts(k,:) = lcl_complex(k)%centers(indx,:)

    !-- get sign --
    IF (k>1 .AND. k<=dim_cmplx) THEN
      DO i = 1,k+1
        t_indx = lcl_complex(k+1)% node_indx(p_indx,i)
        IF (.NOT. ANY(lcl_complex(k)% node_indx(indx,:)==t_indx)) THEN
          pts(k-1,:) = lcl_complex(1)%centers(lcl_complex(k+1)%lcl_node_indx(p_indx,i),:)
          sgn(k-1) = sign(1.d0,dot_product(pts(k+1,:)-pts(k,:),pts(k-1,:)-pts(k,:)))
          EXIT
        END IF
      END DO
    END IF

    !-- compute number of points to be used in volume calculation --
    n = dim_cmplx + 1 - k

    !-- add to k^th order dual volume
    lcl_complex(k)%dual_volume(indx) = lcl_complex(k)%dual_volume(indx) + &
      product(sgn)*calc_unsgnd_vlm(pts(k:,:),n)

    !-- recursively add to dual volumes from lower order elements --
    IF (k>1) THEN
      DO i = 1, lcl_complex(k)% num_bndry(indx)
        CALL calc_dual_vlm_i(pts,sgn,lcl_complex(k)% bndry(indx)% indx(i),indx,k-1)
      END DO
    END IF

    IF (k>1 .AND. k<=dim_cmplx) sgn(k-1) = 1.d0

    RETURN

  END SUBROUTINE
! dec_mod/calc_dual_vlm_i
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/add_points_i
!* SYNOPSIS
  RECURSIVE SUBROUTINE add_points_i(pts,indx,k)
!* PURPOSE
!*   Recursively adds points for dual volume calculation
!* INPUTS
!*   Name                    Description
!*
!* OUTPUTS
!*   Name                    Description
!*
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Recursively adds points for dual volume calculation
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER, INTENT(IN)           :: k          !> simplicial order
    INTEGER, INTENT(IN)           :: indx       !> element index
    REAL(KIND=iwp), INTENT(INOUT) :: pts(:,:)   !> bounding points

    !-- local variables --
    INTEGER                       :: i          !> loop counters
    INTEGER                       :: n          !> number of points

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- add to array of points --
    pts(k,:) = lcl_complex(k)%centers(indx,:)

    !-- recursively add points from lower order elements --
    IF (k<dim_cmplx+1) THEN
      DO i = 1, lcl_complex(k)% num_cobndry(indx)
        CALL add_points_i(pts,lcl_complex(k)%cobndry(indx)%indx(i),k+1)
      END DO
    END IF

    RETURN

  END SUBROUTINE
! dec_mod/add_points_i
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/f* dec_mod/calc_unsgnd_vlm
!* SYNOPSIS
  FUNCTION calc_unsgnd_vlm(pts,n)
!* PURPOSE
!*   Compute unsigned volume for given set of points
!* INPUTS
!*   Name                    Description
!*
!* OUTPUTS
!*   Name                    Description
!*
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Compute unsigned volume for given set of points
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    REAL(KIND=iwp), INTENT(IN)  :: pts(:,:)         !> bounding points
    INTEGER, INTENT(IN)         :: n                !> # points to use

    !-- local variables --
    INTEGER                     :: i                !> loop counters
    INTEGER                     :: fac              !> factorial
    REAL(KIND=iwp), ALLOCATABLE :: A(:,:)           !> solution variable
    REAL(KIND=iwp)              :: calc_unsgnd_vlm  !> function value

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    IF (n==0) THEN
      !-- assign default value when no points are used --
      calc_unsgnd_vlm = 1.d0
    ELSE
      !-- allocate temp. variables --
      ALLOCATE(A(n,dim_embbd))

      !-- compute necessary factorial and build system matrix --
      fac = 1
      DO i=1,n
        fac = fac*i
        A(i,:) = pts(i+1,:) - pts(1,:)
      END DO

      !-- compute and assign unsigned volume --
      calc_unsgnd_vlm = SQRT(ABS(determinant(MATMUL(A,TRANSPOSE(A)),n)))/fac

      !-- clean up --
      DEALLOCATE(A)
    END IF

    RETURN

  END FUNCTION
! dec_mod/calc_unsgnd_vlm
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/exchange_dual_vlm
!* SYNOPSIS
  SUBROUTINE exchange_dual_vlm(k)
!* PURPOSE
!*   Exchange external dual volumes between adjacent processes
!* INPUTS
!*   Name                    Description
!*   k
!* OUTPUTS
!*   Name                    Description
!*   k
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/22: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/22
!> Exchange external dual volumes between adjacent processes
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER,INTENT(IN)     :: k                !> simplicial order

    !-- local variables --
    INTEGER               :: kp                 !> simplicial order plus one
    INTEGER               :: cnt                !> counter
    INTEGER               :: i                  !> loop index

    INTEGER               :: junk               !> junk comm variable
    INTEGER               :: buffer_size        !> size of comm buffer
    REAL(KIND=iwp), ALLOCATABLE  :: sbuffer(:)  !> send buffer
    REAL(KIND=iwp), ALLOCATABLE  :: rbuffer(:)  !> receive buffer
    INTEGER, ALLOCATABLE  :: req(:)             !> request variable for non-blocking comms
    INTEGER, ALLOCATABLE  :: status(:,:)        !> size of MPI comm buffer

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !-- allocate and pack send buffer --
    kp = k+1
    ALLOCATE(sbuffer(lcl_complex(kp)%num_send))
    DO i = 1,lcl_complex(kp)%num_send
      sbuffer(i) = lcl_complex(k)%dual_volume(lcl_complex(kp)%send_indx(i,2))
    END DO

    !-- send data to adjacent processes --
    cnt = 1
    DO i = 1,num_adj_proc
      IF (num_send(k,i)==0) CYCLE
      buffer_size = num_send(k,i)
      CALL MPI_ISEND(sbuffer(cnt:cnt+buffer_size-1),buffer_size,&
        MPI_DOUBLE_PRECISION,adj_proc(i),0,MPI_COMM_WORLD,junk,ier)
      CALL MPI_REQUEST_FREE(junk,ier)
      cnt = cnt + buffer_size
    END DO

    !-- allocate recieve buffer and receive data from adjacent processes --
    ALLOCATE(rbuffer(lcl_complex(kp)%num_recv),&
      req(num_adj_proc),status(MPI_STATUS_SIZE,num_adj_proc))
    cnt = 1
    DO i = 1,num_adj_proc
      IF (num_recv(k,i)==0) THEN
        req(i) = MPI_REQUEST_NULL
        CYCLE
      END IF
      buffer_size = num_recv(k,i)
      CALL MPI_IRECV(rbuffer(cnt:cnt+buffer_size-1),buffer_size,&
        MPI_DOUBLE_PRECISION,adj_proc(i),0,MPI_COMM_WORLD,req(i),ier)
      cnt = cnt + buffer_size
    END DO

    !-- wait for communication to finish, then unpack receive buffer --
    CALL MPI_WAITALL(num_adj_proc,req,status,ier)
    DO i = 1,lcl_complex(kp)%num_recv
      lcl_complex(k)%dual_volume(lcl_complex(kp)%recv_indx(i,2)) = rbuffer(i)
    END DO

    !-- clean up --
    DEALLOCATE(req,status)

    !-- make sure all comms have completed --
    CALL MPI_BARRIER(MPI_COMM_WORLD,ier)

    RETURN

  END SUBROUTINE
! io_mod|exchange_dual_vlm
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/exchange_dual_dir
!* SYNOPSIS
  SUBROUTINE exchange_dual_dir(k)
!* PURPOSE
!*   Exchange external dual edge directions between adjacent processes
!* INPUTS
!*   Name                    Description
!*   k
!* OUTPUTS
!*   Name                    Description
!*   k
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/22: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/22
!> Exchange external dual edge directions between adjacent processes
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER,INTENT(IN)    :: k                  !> simplicial order

    !-- local variables --
    INTEGER               :: kp                 !> simplicial order
    INTEGER               :: cnt                !> counter
    INTEGER               :: i                  !> loop index

    INTEGER               :: junk               !> junk comm variable
    INTEGER               :: buffer_size        !> size of comm buffer
    REAL(KIND=iwp), ALLOCATABLE  :: sbuffer(:)  !> send buffer
    REAL(KIND=iwp), ALLOCATABLE  :: rbuffer(:)  !> receive buffer
    INTEGER, ALLOCATABLE  :: req(:)             !> request variable for non-blocking comms
    INTEGER, ALLOCATABLE  :: status(:,:)        !> size of MPI comm buffer

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    !-- allocate and pack send buffer --
    kp = k+1
    ALLOCATE(sbuffer(dim_embbd*lcl_complex(kp)%num_send))
    DO i = 1,lcl_complex(kp)%num_send
      sbuffer((i-1)*dim_embbd+1:i*dim_embbd) = &
        lcl_complex(k)%dual_dir(lcl_complex(kp)%send_indx(i,2),:)
    END DO

    !-- send data to adjacent processes --
    cnt = 1
    DO i = 1,num_adj_proc
      IF (num_send(k,i)==0) CYCLE
      buffer_size = dim_embbd*num_send(k,i)
      CALL MPI_ISEND(sbuffer(cnt:cnt+buffer_size-1),buffer_size,&
        MPI_DOUBLE_PRECISION,adj_proc(i),0,MPI_COMM_WORLD,junk,ier)
      CALL MPI_REQUEST_FREE(junk,ier)
      cnt = cnt + buffer_size
    END DO

    !-- allocate recieve buffer and receive data from adjacent processes --
    ALLOCATE(&
      req(num_adj_proc),&
      status(MPI_STATUS_SIZE,num_adj_proc),&
      rbuffer(dim_embbd*lcl_complex(kp)%num_recv))
    cnt = 1
    DO i = 1,num_adj_proc
      IF (num_recv(k,i)==0) THEN
        req(i) = MPI_REQUEST_NULL
        CYCLE
      END IF
      buffer_size = dim_embbd*num_recv(k,i)
      CALL MPI_IRECV(rbuffer(cnt:cnt+buffer_size-1),buffer_size,&
        MPI_DOUBLE_PRECISION,adj_proc(i),0,MPI_COMM_WORLD,req(i),ier)
      cnt = cnt + buffer_size
    END DO

    !-- wait for communication to finish, then unpack receive buffer --
    CALL MPI_WAITALL(num_adj_proc,req,status,ier)
    DO i = 1,lcl_complex(kp)%num_recv
      lcl_complex(k)%dual_dir(lcl_complex(kp)%recv_indx(i,2),:) = &
        rbuffer((i-1)*dim_embbd+1:i*dim_embbd)
    END DO

    !-- clean up --
    DEALLOCATE(req,status)

    !-- make sure all comms have completed --
    CALL MPI_BARRIER(MPI_COMM_WORLD,ier)

    RETURN

  END SUBROUTINE
! io_mod|exchange_dual_dir
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_hodge_star
!* SYNOPSIS
  SUBROUTINE calc_hodge_star(k)
!* PURPOSE
!*   Compute hodge star and it's inverse from primal and dual volumes
!* INPUTS
!*   Name                    Description
!*   k
!* OUTPUTS
!*   Name                    Description
!*   k
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Compute hodge star and it's inverse from primal and dual volumes
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    INTEGER, INTENT(IN)           :: k        !> geometric order

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- allocate and compute hodge stars and it's invers --
    IF (.NOT. ALLOCATED(lcl_complex(k)%hdg_star)) ALLOCATE(lcl_complex(k)%hdg_star(num_elm(k)))
    IF (.NOT. ALLOCATED(lcl_complex(k)%inv_hdg_star)) ALLOCATE(lcl_complex(k)%inv_hdg_star(num_elm(k)))
    lcl_complex(k)%hdg_star = lcl_complex(k)%dual_volume / lcl_complex(k)%prml_volume
    lcl_complex(k)%inv_hdg_star = lcl_complex(k)%prml_volume / lcl_complex(k)%dual_volume

    RETURN

  END SUBROUTINE
! dec_mod/calc_hodge_star
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_prml_dir
!* SYNOPSIS
  SUBROUTINE calc_prml_dir()
!* PURPOSE
!*   Compute the unit direction of primal edges
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Compute the unit direction of primal edges
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- local variables --
    INTEGER           :: i        !> loop counter

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- allocate direction variables --
    IF (.NOT. ALLOCATED(lcl_complex(2)%prml_dir)) &
      ALLOCATE(lcl_complex(2)%prml_dir(num_elm(2),dim_embbd))

    !-- compute edge direction --
    DO i = 1,num_elm(2)
      !-- add contribution from end-points (primal vertices) --
      lcl_complex(2)%prml_dir(i,:) = &
        lcl_complex(1)%centers(lcl_complex(2)%lcl_node_indx(i,1),:) - &
        lcl_complex(1)%centers(lcl_complex(2)%lcl_node_indx(i,2),:)

      !-- normalise --
      lcl_complex(2)%prml_dir(i,:) = lcl_complex(2)%prml_dir(i,:) / &
        max(sqrt(dot_product(lcl_complex(2)%prml_dir(i,:),lcl_complex(2)%prml_dir(i,:))),small)
    END DO

    RETURN

  END SUBROUTINE
! dec_mod/calc_prml_dir
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_dual_dir
!* SYNOPSIS
  SUBROUTINE calc_dual_dir()
!* PURPOSE
!*   Compute the unit direction of dual edges
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Compute the unit direction of dual edges
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- local variables --
    INTEGER           :: i,j        !> loop counters

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- allocate direction variables and zero --
    IF (.NOT. ALLOCATED(lcl_complex(dim_cmplx)%dual_dir)) &
      ALLOCATE(lcl_complex(dim_cmplx)%dual_dir(num_elm(dim_cmplx),dim_embbd))
    lcl_complex(dim_cmplx)%dual_dir = 0.d0

    !-- compute edge direction for each local dual edge --
    DO i = 1,num_elm(dim_cmplx)
      !-- add contribution from internal end-points (dual vertices) --
      DO j = 1,lcl_complex(dim_cmplx)%num_cobndry(i)
        lcl_complex(dim_cmplx)%dual_dir(i,:) = lcl_complex(dim_cmplx)%dual_dir(i,:) + &
          lcl_complex(dim_cmplx)%cobndry(i)%sgn(j)*&
          lcl_complex(dim_cmplx+1)%centers(lcl_complex(dim_cmplx)%cobndry(i)%indx(j),:)
      END DO
    END DO

    !-- add contribution from surface end-points --
    DO i = 1,lcl_complex(dim_cmplx+1)%num_surf
      lcl_complex(dim_cmplx)%dual_dir(lcl_complex(dim_cmplx+1)%surf_indx(i,2),:) = &
        lcl_complex(dim_cmplx)%dual_dir(lcl_complex(dim_cmplx+1)%surf_indx(i,2),:) + &
        lcl_complex(dim_cmplx+1)%surf_indx(i,1)*&
        lcl_complex(dim_cmplx)%centers(lcl_complex(dim_cmplx+1)%surf_indx(i,2),:)
    END DO

    !-- exchange external dual edge directions to adjacent processes --
    CALL exchange_dual_dir(dim_cmplx)

    !-- normalise direction vectors --
    DO i = 1,num_elm(dim_cmplx)
      lcl_complex(dim_cmplx)%dual_dir(i,:) = lcl_complex(dim_cmplx)%dual_dir(i,:) / &
        max(sqrt(dot_product(lcl_complex(dim_cmplx)%dual_dir(i,:),lcl_complex(dim_cmplx)%dual_dir(i,:))),small)
    END DO

    RETURN

  END SUBROUTINE
! dec_mod/calc_dual_dir
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_whitney_C2_BC
!* SYNOPSIS
  SUBROUTINE calc_whitney_C2_BC()
!* PURPOSE
!*   Compute the Whitney interpolation of primal faces to primal volume barycentric centers
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Compute the Whitney interpolation of primal faces to primal volume barycentric centers
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- local variables --
    INTEGER           :: i,j,k      !> loop indices
    INTEGER           :: vrts(4)    !> volume vertex indices
    INTEGER           :: f_vrts(3)  !> face vertex indices
    INTEGER           :: indx       !> face index
    LOGICAL           :: not_found  !> is boundary face index found
    REAL(KIND=iwp)    :: grads(4,3) !> barycentric gradients

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- zero solution array --
    lcl_complex(dim_cmplx+1)% whtny_sol = 0.d0

    !-- loop through volumes computing whitney interpolation --
    DO i=1,num_elm(dim_cmplx+1)
      !-- get local vertex indices of volume --
      vrts = lcl_complex(dim_cmplx+1)% lcl_node_indx(i,:)
      !-- compute barycentric gradients of volume --
      grads = lcl_complex(1)%centers(vrts,:)
      CALL calc_barycentric_grad(grads,4)

      !-- compute contribution from each face of volume --
      DO j = 1,4
        !-- get face vertices --
        f_vrts = (/vrts(1:4-j), vrts(4-j+2:4)/)
        !-- find face local index of face --
        not_found = .TRUE.
        !-- check local faces --
        DO k = 1,lcl_complex(dim_cmplx+1)% num_bndry(i)
          indx = lcl_complex(dim_cmplx+1)% bndry(i)% indx(k)
          IF (ALL(f_vrts == lcl_complex(dim_cmplx)% lcl_node_indx(indx,:))) THEN
            !-- match found; exit search --
            not_found = .FALSE.;   EXIT
          END IF
        END DO
        IF (not_found) THEN
          !-- check non-local internal faces --
          DO k = 1,lcl_complex(dim_cmplx+1)% num_ext
            indx = lcl_complex(dim_cmplx+1)% ext_indx(k,2)
            IF (ALL(f_vrts == lcl_complex(dim_cmplx)% lcl_node_indx(indx,:))) THEN
              !-- match found; exit search --
              not_found = .FALSE.;   EXIT
            END IF
          END DO
          IF (not_found) THEN
            !-- check surface faces --
            DO k = 1,lcl_complex(dim_cmplx+1)% num_surf
              indx = lcl_complex(dim_cmplx+1)% surf_indx(k,2)
              IF (ALL(f_vrts == lcl_complex(dim_cmplx)% lcl_node_indx(indx,:))) THEN
                !-- match found; exit search --
                not_found = .FALSE.;   EXIT
              END IF
            END DO
          END IF
        END IF
        !-- compute contribution from face at barycenter using Whitney interpolation --
        !-- build index array for computation
        f_vrts = (/(k,k=1,4-j), (k,k=4-j+2,4)/)
        ! write(*,*) '  -',i,j,indx,lcl_complex(dim_cmplx+1)% whtny_sol(i,:),&
        !   0.5d0*lcl_complex(dim_cmplx)% prml_sol(indx,1)*(&
        !   cross_product(grads(f_vrts(1),:),grads(f_vrts(3),:)) + &
        !   cross_product(grads(f_vrts(2),:),grads(f_vrts(1),:)) + &
        !   cross_product(grads(f_vrts(3),:),grads(f_vrts(2),:)) )
        !-- add contribution --
        lcl_complex(dim_cmplx+1)% whtny_sol(i,:) = lcl_complex(dim_cmplx+1)% whtny_sol(i,:) + &
            0.5d0*lcl_complex(dim_cmplx)% prml_sol(indx,1)*(&
            cross_product(grads(f_vrts(1),:),grads(f_vrts(3),:)) + &
            cross_product(grads(f_vrts(2),:),grads(f_vrts(1),:)) + &
            cross_product(grads(f_vrts(3),:),grads(f_vrts(2),:)) )
      END DO
      !write(*,*) '  -',i,lcl_complex(dim_cmplx+1)% whtny_sol(i,:)
    END DO

    RETURN

  END SUBROUTINE
! dec_mod/calc_whitney_C2_BC
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!/****/s* dec_mod/calc_barycentric_grad
!* SYNOPSIS
  SUBROUTINE calc_barycentric_grad(pts,n)
!* PURPOSE
!*   Compute barycentric gradients
!* INPUTS
!*   Name                    Description
!*
!* OUTPUTS
!*   Name                    Description
!*
!* SIDE EFFECTS
!*   -
!* AUTHOR
!*   Pieter Boom
!* MODIFICATION HISTORY
!*   2019/08/23: Created (PB)
!* COPYRIGHT
!*   (c) University of Manchester
!******/
!> author: Pieter Boom
!> date: 2019/08/23
!> Compute barycentric gradients
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    IMPLICIT NONE

    !-- arguments --
    REAL(KIND=iwp), INTENT(INOUT) :: pts(:,:) !> vertices of simplex
    INTEGER, INTENT(IN)           :: n        !> number of vertices

    !-- local variables --
    INTEGER                       :: i,j      !> loop counters

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! MAIN EXECUTION
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    !-- compute n-1 edge gradients --
    DO i =1, n-1;   pts(i,:) = pts(i,:) - pts(n,:);   END DO
    SELECT CASE (n)
    CASE(2)
      !-- do nothing: already finished --
    CASE(3)
      pts(1:n-1,:) = MATMUL(matinv2(MATMUL(pts(1:n-1,:),TRANSPOSE(pts(1:n-1,:)))),pts(1:n-1,:))
    CASE(4)
      pts(1:n-1,:) = MATMUL(matinv3(MATMUL(pts(1:n-1,:),TRANSPOSE(pts(1:n-1,:)))),pts(1:n-1,:))
    CASE DEFAULT
      !-- not setup for higher dimension simplices --
    END SELECT
    !-- compute last gradient using the fact that the sum of gradients must be zero --
    pts(n,:) = -SUM(pts(1:n-1,:),DIM=1)

    RETURN

  END SUBROUTINE
! dec_mod/calc_barycentric_grad
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!

END MODULE
! dec_mod
!===============================================================================
!


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module scalarOP

  implicit none
  private
  integer :: i,j,k
  real(kind=8) :: zero = 0d0, eps=1d-10, one=1.0d0
  real(kind=8),parameter :: kBm1=3.1577465d5

  complex(kind=8) :: dumc

  public trace,trace_d,normalize,normalize_d,bose,boltz

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  complex(kind=8) function trace(mat,Nb,Ns)

    implicit none
    integer,intent(in) :: Nb,Ns
    complex(kind=8),intent(in) :: mat(0:Nb,0:Ns)

    dumc = dcmplx(zero,zero)
    do i = 0,Ns-1
      dumc = dumc + mat(i,i)
    enddo
    do i = Ns,Nb
      dumc = dumc + mat(i,Ns)
    enddo
    trace = dumc

  end function trace

  complex(kind=8) function trace_d(mat,Nb)

      implicit none
      integer,intent(in) :: Nb
      complex(kind=8),intent(in) :: mat(0:Nb,0:Nb)

      dumc = dcmplx(zero,zero)
      do i=0,Nb
        dumc = dumc + mat(i,i)
      enddo
      trace_d = dumc

      end function trace_d

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine normalize(normc,mat,Nb,Ns)

    implicit none
    integer,intent(in) :: Nb,Ns
    complex(kind=8),intent(in) :: normc
    complex(kind=8),intent(inout) :: mat(0:Nb,0:Ns)

    dumc = 1d0/normc
    do j = 0,Ns-1
    do i = 0,Nb
      mat(i,j) = dumc*mat(i,j)
    enddo
    enddo
    do i = Ns,Nb
      mat(i,Ns) = dumc*mat(i,Ns)
    enddo

  end subroutine normalize

  subroutine normalize_d(normc,mat,Nb)

      implicit none
      integer,intent(in) :: Nb
      complex(kind=8),intent(in) :: normc
      complex(kind=8),intent(inout) :: mat(0:(Nb-1),0:(Nb-1))

      dumc = 1d0/normc
      do j = 0, Nb-1
        do i = 0, Nb-1
          mat(i,j) = dumc*mat(i,j)
        enddo
      enddo

    end subroutine normalize_d

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine bose(bosefkt, deltaE, T)
     implicit none
     real(kind=8), intent(in) :: deltaE, T
     real(kind=8), intent(out) :: bosefkt
     real(kind=8) :: dum

     dum = Kbm1 / T
     if(T < eps .and. deltaE >= zero) then
         bosefkt = zero
     elseif(T < eps .and. deltaE < zero) then
         bosefkt = -one
     else
         bosefkt = one/(exp(dum*deltaE)-one)
     endif

  end subroutine bose

  subroutine boltz(bosefkt, deltaE, T)
     implicit none
     real(kind=8), intent(in) :: deltaE, T
     real(kind=8), intent(out) :: bosefkt

     if(T < eps) then
         bosefkt = zero
     else
         bosefkt = exp(-deltaE*kBm1/T)
     endif

  end subroutine boltz

end module scalarOP
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


      Program Ex0204

      Implicit None

*   Initial, Final Point
      Double Precision  xMin
      Parameter         (xMin = 0.0D0)
      Double Precision  xMax
      Parameter         (xMax = 3.0D0)
      Double Precision  yMin
      Parameter         (yMin = 1.0D0)
*   Data Dimension
      Integer           DNum
      Parameter         (DNum = 9)
*   Data Storage
      Integer           GridN(DNum)
      Double Precision  Gap(DNum), y1RK1(DNum), y3RK1(DNum),yrRK1(DNum),
     $                  y1RK2(DNum), y3RK2(DNum), yrRK2(DNum),
     $                  y1RK3(DNum), y3RK3(DNum), yrRK3(DNum)
*   Dummy
      Integer           I
*   Function
      Double Precision  Func, Ext
      External          Func, Ext

      Open(11, File = '02-04.txt')
 1000 Format(F6.3,9F14.7)
 1010 Format(A6,9A14)
 1020 Format(A6,3A42)

*   Data Declaration
      Data GridN /6,15,30,60,150,300,600,1500,3000/
      Do 10 I = 1, DNum
        Gap(I) = (xMax - xMin) / DBLE(GridN(I))
  10  Continue

      Do 110 I = 1, DNum
        Call RK1(y1RK1(I), y3RK1(I), yrRK1(I), xMin,xMax,yMin, GridN(I),
     $          Gap(I))
        Call RK2(y1RK2(I), y3RK2(I), yrRK2(I), xMin,xMax,yMin, GridN(I),
     $          Gap(I))
        Call RK3(y1RK3(I), y3RK3(I), yrRK3(I), xMin,xMax,yMin, GridN(I),
     $          Gap(I))
  110 Continue

      Write(11,1020) '------',
     $               '------------------------------------------',
     $               '------------------------------------------',
     $               '------------------------------------------'
      Write(11,1020) ' |',
     $               'Runge-Kutta 2-order       |',
     $               'Runge-Kutta 3-order       |',
     $               'Runge-Kutta 4-order       |'
      Write(11,1020) ' |',
     $               'Eq.(2.22)            |',
     $               'Eq.(2.24)            |',
     $               'Eq.(2.25)            |'
      Write(11,1010) 'h |',
     $               'y(1)  ', 'y(3)  ', 'Retrun |',
     $               'y(1)  ', 'y(3)  ', 'Return |',
     $               'y(1)  ', 'y(3)  ', 'Retrun |'
      Write(11,1020) '------',
     $               '------------------------------------------',
     $               '------------------------------------------',
     $               '------------------------------------------'
      Do 20 I = 1, DNum
        Write(11,1000) Gap(I), y1RK1(I), y3RK1(I), yrRK1(I), y1RK2(I),
     $                 y3RK2(I), yrRK2(I), y1RK3(I), y3RK3(I), yrRK3(I)
  20  Continue
      Write(11,1020) '------',
     $               '------------------------------------------',
     $               '------------------------------------------',
     $               '------------------------------------------'

      End Program Ex0204

*-----------------------------------------------------------------------
*
      Subroutine RK1(y1, y3, yr, xMin, xMax, yMin, GridN, Gap)

      Implicit None

      Double Precision  y1, y3, yr, xMin, xMax, yMin, Gap
      Integer           GridN
*   Dummy
      Integer           I
*   Value for n+1, n+0
      Double Precision  xn1, yn1, xn0, yn0
*   Function
      Double Precision  Func, Ext
      External          Func, Ext
*   Internal Variable
      Double Precision  k1, k2

      xn0 = xMin
      yn0 = yMin
      Do 10 I = 1, GridN
        xn1 = DBLE(I) / DBLE(GridN) * xMax +
     $        (1.0D0 - DBLE(I) / DBLE(GridN)) * xMin
        k1 = Gap * Func(xn0, yn0)
        k2 = Gap * Func(xn0 + 0.5D0*Gap, yn0 + 0.5D0*k1)
        yn1 = yn0 + k2
        If(DAbs(xn1-1.0D0).LT.1.0D-10) y1 = yn1 - Ext(xn1)
        If(DAbs(xn1-3.0D0).LT.1.0D-10) y3 = yn1 - Ext(xn1)
        xn0 = xn1
        yn0 = yn1
  10  Continue

      Do 20 I = 1, GridN
        xn1 = DBLE(I) / DBLE(GridN) * xMin +
     $        (1.0D0 - DBLE(I) / DBLE(GridN)) * xMax
        k1 = -Gap * Func(xn0, yn0)
        k2 = -Gap * Func(xn0 - 0.5D0*Gap, yn0 + 0.5D0*k1)
        yn1 = yn0 + k2
        xn0 = xn1
        yn0 = yn1
  20  Continue
      yr = Ext(xn1) - yn1

      End Subroutine RK1

*-----------------------------------------------------------------------
*
      Subroutine RK2(y1, y3, yr, xMin, xMax, yMin, GridN, Gap)

      Implicit None

      Double Precision  y1, y3, yr, xMin, xMax, yMin, Gap
      Integer           GridN
*   Dummy
      Integer           I
*   Value for n+1, n+0
      Double Precision  xn1, yn1, xn0, yn0
*   Function
      Double Precision  Func, Ext
      External          Func, Ext
*   Internal Variable
      Double Precision  k1, k2, k3

      xn0 = xMin
      yn0 = yMin
      Do 10 I = 1, GridN
        xn1 = DBLE(I) / DBLE(GridN) * xMax +
     $        (1.0D0 - DBLE(I) / DBLE(GridN)) * xMin
        k1 = Gap * Func(xn0, yn0)
        k2 = Gap * Func(xn0 + 0.5D0*Gap, yn0 + 0.5D0*k1)
        k3 = Gap * Func(xn0 + Gap, yn0 - k1 + 2.0D0*k2)
        yn1 = yn0 + 1.0D0/6.0D0 * (k1 + 4.0D0*k2 + k3)
        If(DAbs(xn1-1.0D0).LT.1.0D-10) y1 = yn1 - Ext(xn1)
        If(DAbs(xn1-3.0D0).LT.1.0D-10) y3 = yn1 - Ext(xn1)
        xn0 = xn1
        yn0 = yn1
  10  Continue

      Do 20 I = 1, GridN
        xn1 = DBLE(I) / DBLE(GridN) * xMin +
     $        (1.0D0 - DBLE(I) / DBLE(GridN)) * xMax
        k1 = -Gap * Func(xn0, yn0)
        k2 = -Gap * Func(xn0 - 0.5D0*Gap, yn0 + 0.5D0*k1)
        k3 = -Gap * Func(xn0 - Gap, yn0 - k1 + 2.0D0*k2)
        yn1 = yn0 + 1.0D0/6.0D0 * (k1 + 4.0D0*k2 + k3)
        xn0 = xn1
        yn0 = yn1
  20  Continue
      yr = Ext(xn1) - yn1

      End Subroutine RK2

*-----------------------------------------------------------------------
*
      Subroutine RK3(y1, y3, yr, xMin, xMax, yMin, GridN, Gap)

      Implicit None

      Double Precision  y1, y3, yr, xMin, xMax, yMin, Gap
      Integer           GridN
*   Dummy
      Integer           I
*   Value for n+1, n+0
      Double Precision  xn1, yn1, xn0, yn0
*   Function
      Double Precision  Func, Ext
      External          Func, Ext
*   Internal Variable
      Double Precision  k1, k2, k3, k4

      xn0 = xMin
      yn0 = yMin
      Do 10 I = 1, GridN
        xn1 = DBLE(I) / DBLE(GridN) * xMax +
     $        (1.0D0 - DBLE(I) / DBLE(GridN)) * xMin
        k1 = Gap * Func(xn0, yn0)
        k2 = Gap * Func(xn0 + 0.5D0*Gap, yn0 + 0.5D0*k1)
        k3 = Gap * Func(xn0 + 0.5D0*Gap, yn0 + 0.5D0*k2)
        k4 = Gap * Func(xn0 + Gap, yn0 + k3)
        yn1 = yn0 + 1.0D0/6.0D0 * (k1 + 2.0D0*k2 + 2.0D0*k3 + k4)
        If(DAbs(xn1-1.0D0).LT.1.0D-10) y1 = yn1 - Ext(xn1)
        If(DAbs(xn1-3.0D0).LT.1.0D-10) y3 = yn1 - Ext(xn1)
        xn0 = xn1
        yn0 = yn1
  10  Continue

      Do 20 I = 1, GridN
        xn1 = DBLE(I) / DBLE(GridN) * xMin +
     $        (1.0D0 - DBLE(I) / DBLE(GridN)) * xMax
        k1 = -Gap * Func(xn0, yn0)
        k2 = -Gap * Func(xn0 - 0.5D0*Gap, yn0 + 0.5D0*k1)
        k3 = -Gap * Func(xn0 - 0.5D0*Gap, yn0 + 0.5D0*k2)
        k4 = -Gap * Func(xn0 - Gap, yn0 + k3)
        yn1 = yn0 + 1.0D0/6.0D0 * (k1 + 2.0D0*k2 + 2.0D0*k3 + k4)
        xn0 = xn1
        yn0 = yn1
  20  Continue
      yr = Ext(xn1) - yn1

      End Subroutine RK3

*-----------------------------------------------------------------------
*
      Function Func(x,y)

      Implicit None
      Double Precision  Func, x, y

      Func = - x * y

      End Function Func

*-----------------------------------------------------------------------
*
      Function FuncDx(x,y)

      Implicit None
      Double Precision  FuncDx, x, y

      FuncDx = - y

      End Function FuncDx

*-----------------------------------------------------------------------
*
      Function FuncDy(x,y)

      Implicit None
      Double Precision  FuncDy, x, y

      FuncDy = - x

      End Function FuncDy

*-----------------------------------------------------------------------
*
      Function FuncG(x)

      Implicit None
      Double Precision  FuncG, x

      FuncG = - x

      End Function FuncG

*-----------------------------------------------------------------------
*
      Function Ext(x)

      Implicit None
      Double Precision  Ext, x

      Ext = DExp(-x*x/2.0D0)

      End Function Ext


! 5. Write a function that computes the running total of a list.

    program Exercises
    implicit none
    integer :: list(4)
    integer :: total

    list = (/1, 3, 4, 2 /)
    total = getTotal(list)

    contains

    function getTotal(list) result(r)
        integer, dimension(1:), intent(in) :: list
        integer :: r
        integer :: i
        r = 0

        do i=1,size(list)
            r = r + list(i)
        end do

    end function

    end program Exercises


module PHYS_CONST
! Description:
!    Physical and numerical parameters used in Thalassa.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!     180608: rename F107 -> F107Const. Add F107DAILY.
!     180609: add radius of the Sun.
!     180610: add flattening.
!     180730: move Earth data initialization to routine INITIALIZE_NSGRAV.
!     190110: read lunar radius.
!
! ==============================================================================

use KINDS, only: dk
implicit none

! Kind parameter for quad (needed for NORMFACT)
integer,parameter   ::  qk = selected_real_kind(33)
integer,parameter   ::  id_phys = 22
! Numerical constants
real(dk),parameter  ::  pi    = acos(-1._dk)
real(dk),parameter  ::  twopi = 2._dk*acos(-1._dk)
real(dk),parameter  ::  d2r   = pi/180._dk
real(dk),parameter  ::  r2d   = 180._dk/pi
real(dk),parameter  ::  mzero = epsilon(0._dk)

! --- PHYSICAL PARAMETERS ---
! Astronomical unit (km)
real(dk)  ::  au
! Sun, Earth, Moon grav. parameters (km^3/s^2)
real(dk)  ::  GS,GE,GM
! Earth equatorial and polar radii (km), flattening, eccentricity, and angular velocity (rad/s)
real(dk)  ::  RE
real(dk)  ::  flatt
real(dk)  ::  omegaE
! Sun and moon radii (km)
real(dk)  ::  RS,ReqM
! Seconds per day (tropical)
real(dk),parameter  ::  secsPerDay = 86400._dk
! Seconds per day (sidereal)
real(dk)  ::  secsPerSidDay
! Re-entry height and radius. Latter is dimensionless (km,-)
real(dk)  ::  reentry_height,reentry_radius_nd
! Difference (JD - MJD)
real(dk),parameter  ::  delta_JD_MJD = 2400000.5_dk
! MJD of epochs J2000.0, J1950.0
real(dk),parameter  ::  JD_J2000     = 2451545
real(dk),parameter  ::  MJD_J2000    = 51544.5_dk
real(dk),parameter  ::  MJD_J1950    = 33282.0_dk
! More conversions
real(dk),parameter  ::  hoursToSeconds = 3600._dk
real(dk),parameter  ::  secondsToDegrees = 1._dk/240._dk
! Earth Rotation Rate in tropical days, without secular terms.
! ! Reference: Vallado et al., 2013.
! real(dk),parameter  ::  ERR_constant  = 1.002737909350795_dk
real(dk)            ::  ERR_constant
real(dk)            ::  ERR_constant_nd

! Physical parameters (dimensionless)
real(dk)  ::  RE_nd,GE_nd       ! Earth

! Mass (kg)
real(dk)  ::  SCMass

! Drag: CD, drag area (m^2), drag area-to-mass ratio (m^2/kg)
real(dk)  ::  CD,ADrag,A2M_Drag

! Drag: observed solar flux @ 10.7cm (SFU), geomagnetic planetary index Kp, planetary amplitude Ap
real(dk)  ::  F107Const,Kp,Ap

! Cutoff height for drag [km]
real(dk)  ::  cutoff_height

! SRP: CR, reflective area (m^2), SRP @ 1 au (N/m^2), SRP area-to-mass ratio (m^2/kg)
real(dk)  ::  CR,ASRP,pSRP_1au,A2M_SRP

contains

subroutine READ_PHYS(physFile)
! Description:
!    Read values for the physical parameters from text file.
!
! Author:
!    Davide Amato
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!     180608: rename F107 -> F107Const.
!     180610: compute flattening.
!     180730: move Earth data initialization to routine INITIALIZE_NSGRAV.
!     180731: remove unused variables.
!     190110: read lunar radius.
!
! ==============================================================================

! VARIABLES
implicit none
! Arguments
character(len=*),intent(in)     ::  physFile
! Locals
character(len=4096)  ::  dummy
integer,parameter    ::  hlines = 8
integer              ::  i

! ==============================================================================
! 01. PHYSICAL CONSTANTS
! ==============================================================================

open(unit=id_phys,file=trim(physFile),status='old',action='read')
read(id_phys,'(a)') (dummy, i=1,hlines)

read(id_phys,'(e20.13,/)') au
read(id_phys,'(e20.13)') GS
read(id_phys,'(e20.13,/)') GM
read(id_phys,'(e20.13)') RS
read(id_phys,'(e20.13,/)') ReqM
read(id_phys,'(e20.13,/)') pSRP_1au
read(id_phys,'(e20.13,/)') F107Const
read(id_phys,'(e20.13,/)') Kp
read(id_phys,'(e20.13,/)') Ap
read(id_phys,'(e20.13,/)') reentry_height
read(id_phys,'(e20.13)') cutoff_height

close(id_phys)

end subroutine READ_PHYS

function GMST_UNIFORM(MJD_UT1)
! Description:
!    Compute the Greenwich Mean Sidereal Time in radians from the Mean Julian
!    Day (UT1). Considers the Earth rotation rate to be constant and does not
!    take into account long-term tidal effects.
!
! Reference:
!    Vallado D.A. et al, Fundamentals of Astrodynamics (4th Ed.), pp. 187-188,
!    Microcosm Press, Hawthorne, CA, USA, 2013.
!
! ==============================================================================

! MODULES
implicit none
! Arguments IN
real(dk),intent(in)  ::  MJD_UT1
! Function definition
real(dk)  ::  GMST_UNIFORM
! Locals
real(dk)  ::  T_UT1_num   ! Time from epoch J2000.0 (centuries using JD number)
real(dk)  ::  T_UT1
real(dk)  ::  MJD_UT1_num,MJD_UT1_frac
real(dk)  ::  GMST_const
real(dk)  ::  GMST_deg_zeroh ! GMST (degrees) at midnight (UT1) of current day
real(dk)  ::  GMST_deg       ! GMST (deg) at current UT1.
real(dk)  ::  GMST_seconds

! ==============================================================================

MJD_UT1_num  = int(MJD_UT1)
MJD_UT1_frac = MJD_UT1 - MJD_UT1_num
T_UT1 = (MJD_UT1 - MJD_J2000)/(36525._dk)
T_UT1_num = (MJD_UT1_num - MJD_J2000)/(36525._dk)

! STELA
! Note: the numerical result of the GMST should be identical to the
! SWIFT-SAT model, except for round-off and the "dirty fixes". However
! we use slightly different formulas (see Ref. [1]) to ensure maximum
! compatibility. Perform the computation in quad to avoid roundoff problems.
GMST_seconds = real(67310.54841_dk,16) + &
& (real(876600.0_dk*hoursToSeconds,16) + real(8640184.812866_dk,16))*T_UT1
GMST_seconds = mod(GMST_seconds,secsPerDay)
GMST_deg = GMST_seconds*secondsToDegrees

! ============
! SWIFT-SAT
! Note (19 Feb 2018): This block of code has been deprecated. However, I'm
! keeping it commented for a few commits for retrocompatibility.
! ============
! ! Value of GMST at J2000 epoch.
! GMST_const = 100.4606184_dk
! ! "Dirty fix" to make the initial GMST coincide with those used for
! ! SWIFT-SAT, which are derived from SPICE.
! if (model==2) then
!   if (abs((MJD_UT1 - 5.84747433E+04)/MJD_UT1) <= 1.E-3_dk) then
!     ! Correction for epoch: 22.74/12/2018 (CHECK THIS)
!     GMST_const = GMST_const - 0.23254054917021_dk

!   else if (abs((MJD_UT1 - 5.902128E+04)/MJD_UT1) <= 1.E-3_dk) then
!     ! Correction for epoch: 21.28/06/2020 (CHECK THIS)
!     GMST_const = GMST_const - 0.24982607944896884_dk
!   end if

! end if

! ! GMST at midnight UTC excluding secular terms. Wrap to [0,360] deg.
! GMST_deg_zeroh = GMST_const + 36000.77005361_dk*T_UT1_num
! GMST_deg_zeroh = mod(GMST_deg_zeroh,360._dk)

! ! Current GMST and wrap to [0,360] deg. The Earth rotation rate is
! ! considered to be constant.
! GMST_deg = GMST_deg_zeroh + ERR_constant*MJD_UT1_frac*360._dk
! GMST_deg = mod(GMST_deg,360._dk)

! ============
! End of deprecated code.
! ============

! To radians
GMST_UNIFORM = GMST_deg*d2r

end function GMST_UNIFORM

function GRHOAN(JD)
! Compute the Greenwich hour angle (rad).
! References:
!    Wertz, Newcomb (1898).

! VARIABLES
implicit none
! Arguments
real(dk),intent(in)  ::  JD        ! Julian Date
real(dk)             ::  GRHOAN
! Locals
real(dk),parameter   ::  JD1900 = 2415020.0_dk  ! JD of Jan 0.5, 1900.
real(dk)             ::  T1900
real(dk)             ::  JDfrac
real(dk)             ::  UT                     ! UT (hours)
real(dk)             ::  GSTsW					! GST (seconds)
real(dk)             ::  GHAdegW,GHAdeg

! ==============================================================================

T1900 = (JD - JD1900)/36525._dk

! Compute UT
JDfrac = JD - int(JD)
if (JDfrac <= 0.5_dk) then
	UT = 12._dk + JDfrac*24._dk
else
	UT = JDfrac*24._dk - 12._dk
end if

! GST in seconds from 18h38m45s.836 of Dec 31st, 1899.
GSTsW = 6._dk*60._dk*60._dk + 38._dk*60._dk + 45.836_dk + &
	   8640184.542_dk*T1900 + 0.0929_dk*T1900**2 + UT*60._dk*60._dk

! Convert seconds to degrees to get Greenwich hour angle
GHAdegW = GSTsW*(15._dk/3600._dk)
! Remove 360ยบ ambiguity
GHAdeg = GHAdegW - 360._dk*int(GHAdegW/360._dk)

! Convert to radians
GRHOAN = GHAdeg*pi/180._dk

end function GRHOAN

!!! DEPRECATED
function ERA_IERS10(MJD_UT1)
! Description:
!    Computes the Earth Rotation Angle (ERA) according to the IERS 2010
!    conventions. The angle is given in radians.
!
! Reference:
!    TODO TODO TODO
!
! ==============================================================================

! VARIABLES
implicit none
! Arguments IN
real(dk),intent(in)  ::  MJD_UT1
! Function def
real(dk)  ::  ERA_IERS10

! Day from J2000
real(dk)  ::  DAY_J2K_UT1
real(dk)  ::  DAY_J2K_UT1_frac,DAY_J2K_UT1_num
real(dk)  ::  ERA_IERS10_const = 0.7790572732640_dk

! ==============================================================================

! Julian day from J20000
DAY_J2K_UT1 = MJD_UT1 - MJD_J2000
DAY_J2K_UT1_num  = int(DAY_J2K_UT1)
DAY_J2K_UT1_frac = DAY_J2K_UT1 - DAY_J2K_UT1_num

! Compute ERA and wrap in [0, 2pi]
ERA_IERS10 = twopi*(DAY_J2K_UT1_frac + ERA_IERS10_const + &
& (ERR_constant - 1._dk)*DAY_J2K_UT1_num )
ERA_IERS10 = mod(ERA_IERS10,twopi)

!!! DEBUG
write(*,*) ERA_IERS10*r2d
!!! DEBUG
end function ERA_IERS10
!!! DEPRECATED

subroutine JD2CAL(JD,year,month,dayOfMonth,dayOfYear)
! Description:
!    Converts from Julian Day to year-month-day, the latter real. Only valid
!    for JD > 0. Also gives the day number of the year as an additional output.
!
! Reference:
!    [1] Ch. 7 of J. Meeus, "Astronomical Algorithms", Willmann-Bell, 1998.
!
! ==============================================================================

! VARIABLES
implicit none
! Inputs
real(dk),intent(in)   ::  JD
! Outputs
integer,intent(out)   ::  year,month
real(dk),intent(out)  ::  dayOfMonth,dayOfYear

! Locals
integer   ::  Z,A,alpha,C,D,E
real(dk)  ::  F,B
integer   ::  K

! ==============================================================================

! Integer and fractional parts
Z = int(JD + 0.5_dk)
F = JD + 0.5_dk - Z

if (Z < 2299161) then
  ! Earlier than 1582-Oct-15 00:00:00
  A = Z

else
  alpha = int((Z - 1867216.25_dk)/36524.25_dk)
  A     = Z + 1 + alpha - int(real(alpha,dk)/4._dk)

end if

! Day of the month
B = A + 1524._dk
C = int((B - 122.1_dk)/365.25_dk)
D = int(365.25_dk*real(C,dk))
E = int((B - D)/30.6001_dk)
dayOfMonth = B - D - int(30.6001_dk*real(E,dk)) + F

! Month
if (E < 14) then
  month = E - 1

else
  month = E - 13

end if

! Year
if (month > 2) then
  year = C - 4716

else
  year = C - 4715

end if

! Detect leap year (K = 1) vs. common year (K = 2)
if (mod(year,4) /= 0) then
  K = 2

else if (mod(year,100) /= 0) then
  K = 1

else if (mod(year,400) /= 0) then
  K = 2

else
  K = 1

end if

! Day of year
dayOfYear = int((275._dk*real(month,dk)) / 9._dk) - &
&           K * int((real(month,dk) + 9._dk)/12._dk ) + dayofMonth - 30._dk

end subroutine JD2CAL

function F107DAILY(iF107,MJD)
! Description:
!    If iF107 = 1, computes the time-varying daily F10.7 flux using Eq. (8-32) of
!    [1]. If iF107 == 0, returns the constant value assigned
!    in ./data/physical_constants.txt.
!    Units are SFU.
!
! Author:
!    Davide Amato
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revisions:
!     180608: procedure created.
!
! References:
!     [1] Vallado D. A. and McClain, W. D., 'Fundamentals of Astrodynamics',
!         Microcosm Press, 2013.
!
! ==============================================================================

implicit none
! Arguments
integer,intent(in)   ::  iF107    ! Variable solar flux flag
real(dk),intent(in)  ::  MJD      ! Constant value of F10.7 and current MJD
! Returns
real(dk)  ::  F107DAILY

! Variables
real(dk),parameter  ::  MJD0 = 44605.0  ! January 1, 1981, 00:00.000
real(dk)            ::  t

! ==============================================================================

select case (iF107)
  case (0)
    F107DAILY = F107Const

  case (1)
    t = int(MJD - MJD0)
    F107DAILY = 145._dk + 75._dk * &
    &cos(0.001696_dk * t + 0.35_dk * sin(0.00001695_dk * t))

end select

end function F107DAILY

function ERR_IAU06(MJDA_TT, MJDB_TT)
! Description:
!    Earth Rotation Rate (time derivative of the Greenwich Mean Sidereal Time),
!    according to the IAU 2006 Conventions. Input is the modified Julian Day in
!    TT.
!
! Author:
!    Davide Amato
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! References:
!    [1] Capitaine, N., Wallace, P.T. & Chapront, J., 2005,
!       Astron. Astrophys. 432, 355
!    [2] Capitaine N., Guinot B. and McCarthy D.D, 2000, Astron.
!       Astrophys., 355, 398-405.
!
! ==============================================================================

! Arguments
real(dk), intent(in)  ::  MJDA_TT, MJDB_TT
! Function definition
real(dk)  ::  ERR_IAU06

! Coefficients for the rate of change of GMST
real(dk), parameter  ::  c0 =   4612.156534_dk, &
                       & c1 =      2.7831634_dk  , &
                       & c2 = -    0.00000132_dk , &
                       & c3 = -    0.000119824_dk, &
                       & c4 = -    0.000000184_dk
! Arcseconds to radians
real(dk), parameter  :: as2rad = 4.848136811095359935899141E-6_dk
real(dk), parameter  :: sec2cy = 3155760000._dk

! Locals
real(dk)  ::  dotERA   ! Derivative of Earth Rotation Angle
real(dk)  ::  dotDelta ! Derivative of GMST - ERA
real(dk)  ::  T        ! Centuries past J2000 (TT)

! ==============================================================================

! According to [2], GMST = ERA + delta(GMST-ERA). Thus we compute the time
! derivative of GMST as the sum of the derivatives of ERA and delta.

! The Earth Rotation Angle (ERA) is a linear function of UT1, thus its derivative
! is constant.
dotERA = 7.292115146706980494985261831431E-5_dk ! [rad/s]

! Following SOFA, we compute the TT Julian centuries since J2000 as
T = ( ( MJDA_TT - MJD_J2000 ) + MJDB_TT ) / 36525._dk

dotDelta = c0 + T * ( c1 + T * ( c2 + T * ( c3 + T * c4 ))) ! [as/cy]
dotDelta = dotDelta * as2rad / sec2cy                       ! [rad/s]

ERR_IAU06 = dotERA + dotDelta

end function ERR_IAU06

function UTC2TT(MJD_UTC)
! Description:
!    Convert MJD in UTC (Universal Coordinated Time) to TT (Terrestrial, or
!    Ephemeris Time). This is a wrapper for the SOFA routines.
!
! Author:
!    Davide Amato
!    The University of Arizona
!    davideamato@email.arizona.edu
!
! Revision:
!    181204: Routine created.
!
!
! ==============================================================================

! Arguments
real(dk), intent(in)  ::  MJD_UTC
! Function definition
real(dk)  ::  UTC2TT

! SOFA procedures
external :: iau_JD2CAL, iau_DAT

! Locals
integer   ::  IY, IM, ID
real(dk)  ::  FD
real(dk)  ::  DAT

! Diagnostics
integer   ::  JDcode, DATcode

! ==============================================================================

call iau_JD2CAL ( delta_JD_MJD, MJD_UTC, IY, IM, ID, FD, JDcode )
call iau_DAT ( IY, IM, ID, FD, DAT, DATcode )
UTC2TT = MJD_UTC + (DAT + 32.184_dk)/secsPerDay

end function UTC2TT

end module PHYS_CONST


c  subroutine to fit a gaussian to some data
c    uses MRQMIN from Numerical Recipes
c  x, y, yerr are the data and errors
c  n is number of data points
c  pars are the parameters of the gaussian - cont, inty, mean, sigma
c  errpars are the errors on fitted params
c  npars is the number of params
c  ifit is an array that specifies whether to fit a param or not
c  iguess tells if we should make our own initial guesses.
c  if iguess=0, the initial guesses are passed in.
c  if iguess=-1, make our own initial guesses but fit an absorption line.

c      subroutine fitgaus(x,y,yerr,np,pars,errpars,npars,ifit,iguess)
      subroutine fitgaus(x,y,yerr,n,pars,errpars,ifit,iguess,chisq)

      parameter (NPARAMS=4)
      real x(n),y(n),yerr(n)
c      real pars(npars)
c      integer ifit(npars)
      real pars(NPARAMS),errpars(NPARAMS)
      integer ifit(NPARAMS)
      real covar(NPARAMS,NPARAMS),alpha(NPARAMS,NPARAMS)
      logical badfit

      external gausfunc

      npars = NPARAMS
      ifitabs = 0

c  generate our own initial guesses?
      if (iguess .ne. 0) then
         xmin = 1.e10
         xmax = -1.e10
         ymin = 1.e10
         ymax = -1.e10
         do i=1,n
            xmin=min(x(i),xmin)
            xmax=max(x(i),xmax)
            if (y(i).gt.ymax) imax = i
            if (y(i).lt.ymin) imin = i
            ymin=min(y(i),ymin)
            ymax=max(y(i),ymax)
         end do
         if (iguess .eq. -1) then
c  we are fitting an absorption line
            pars(1) = ymax
            pars(3) = x(imin)
c  this is completely bogus
            pars(4) = (xmax-xmin)/20.
c  2.5 is about sqrt(2pi)
            pars(2) = (ymin-ymax)*2.5*pars(4)
         else
c  we are fitting an emission line
            pars(1) = ymin
            pars(3) = x(imax)
            pars(4) = (xmax-xmin)/20.
            pars(2) = (ymax-ymin)*2.5*pars(4)
         end if
      end if

      nfit=0
      do i=1,npars
         if (ifit(i) .ne. 0) nfit = nfit+1
      end do

      alamda = -1.
      itmax = 200
      conv = 1.e-3
      ochisq = 1000.

      do iter = 1,itmax
         oldalam = alamda

         call mrqmin(x,y,yerr,n,pars,ifit,npars,
     $        covar,alpha,npars,chisq,gausfunc,alamda)

         dchisq = (ochisq - chisq) / chisq
         ochisq = chisq
         if((dchisq .lt. conv) .and. (oldalam .gt. alamda)) go to 300
      end do

      badfit = .true.
c      write (*,'("failed to converge -  "$)')

c  jump here if we converged
 300  continue

      alamda = 0.
      call mrqmin(x,y,yerr,n,pars,ifit,npars,
     $     covar,alpha,npars,chisq,gausfunc,alamda)
c  reduce chisq
      chisq = chisq / real(n-nfit)
      do i=1,nfit
         errpars(i) = sqrt(covar(i,i))
      end do

      return
      end

      subroutine gausfunc(x,pars,y,dydpar,npar)

      real pars(npar)
      real dydpar(npar)
      real y0,atot,x0,sig

      root2pi = sqrt(2.0*3.1415927)

      y0 = pars(1)
      atot = pars(2)
      x0 = pars(3)
      sig = pars(4)

      u = (x-x0)**2/2.0/sig**2
      expu = exp(-u)
      r2pisig = root2pi*sig

      y = y0 + atot / r2pisig * expu

      dydpar(1) = 1.0
      dydpar(2) = 1.0 / r2pisig * expu
      dydpar(3) = atot / r2pisig * expu * (x-x0) / sig**2
      dydpar(4) = atot / r2pisig * expu / sig * (2.0*u - 1.0)

      return
      end


c-------------------------------------------------------------
c PROGRAM 	: ROOT FINDING
c-------------------------------------------------------------

     program main
c		call false_position(10, 1.0d0, 0.001d0)
            call new_false_position(0.33d0, 0.0d0, 0.00000001d0)
     end

c-------------------------------------------------------------
c FUNCTION	: g
c PURPOSE	: returns t**2
c-------------------------------------------------------------

     double precision function g(t)
     implicit none
     real*8 t
     g = t**2
     return
     end

c-------------------------------------------------------------
c SUBROUTINE	: simpson
c-------------------------------------------------------------

      double precision function simpson(n, a, b)
      implicit none
      integer*4 n, i, factor
      real*8 a, b, answer
      real*8 h, sum, x, g

      i = 0
      factor = 4
      sum = 0.0d0
      x = 0.0d0
      h = (b-a)/dfloat(n)

      do 300 i = 1, (n-1), +1
            x = a+i*h
            if (factor .eq. 2) then
                  sum = sum + 2.0d0*g(x)
                  factor = 4
            else
                  sum = sum + 4.0d0*g(x)
                  factor = 2
            endif
300   continue
      sum = sum + g(a) + g(b)
      sum = (h*sum)/3.0d0

      simpson = sum
      return

      end

c-------------------------------------------------------------
c FUNCTION  : f
c-------------------------------------------------------------

      double precision function f(n,a,b)
      implicit none
      integer*4 n
      real*8 a, b, simpson, g
      f = simpson(n,a,b) - g(b)
      return
      end

c-------------------------------------------------------------
c FUNCTION  : false_position
c-------------------------------------------------------------

      subroutine false_position(n,start,tolerance)
      implicit none
      integer*4 n
      real*8 start, tolerance
      real*8 f
      real*8 h, a, b, x1, x2, x3, f1, f2, f3

      a = 0.0d0
      b = start
      h = (b-a)/dfloat(n)
      x1 = start
      x2 = x1 + h
      f1 = f(n,a, x1)
      f2 = f(n,a, x2)

      write(*,*) 'f1 = ', f1
      write(*,*) 'f2 = ', f2

      do while (f1*f2 .ge. 0.0d0)
        x2 = x1 + h
        f1 = f(n,a,x1)
        f1 = f(n,a,x2)
        write(*,*) 'f1 = ', f1
c		write(*,*) 'f2 = ', f2
      end do

      end

c-------------------------------------------------------------
c FUNCTION  : new_false_position
c-------------------------------------------------------------

      double precision function func(x)
      implicit none
      real*8 x
      func = x**2 - 4
      return
      end

      subroutine new_false_position(n, x1, tolx)
      implicit none
      real*8 n, x1, tolx
      real*8 func
      real*8 x2, f1, f2, x3, f3

      x2 = x1 + n
      f1 = func(x1)
      f2 = func(x2)

      do while (f1*f2 .ge. 0.0d0)
            x2 = x2 + n
            f2 = func(x2)
      end do

      x3 = x2 - f2*(x2-x1)/(f2-f1)
      f3 = func(x3)

      do while (dabs(f3) > tolx)
            if (f1*f3 .lt. 0.0d0) then
                  x2 = x3
            else
                  x1 = x3
            endif
            f1 = func(x1)
            f2 = func(x2)
            x3 = x2 - f2*(x2-x1)/(f2-f1)
            f3 = func(x3)
      end do

      write(*,*) 'x3 = ',x3

      end


! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module pressure_gradient

  ! This module manages the handling of the explicit component of the pressure gradient.

  use gradient_operators, only: grad
  use run_nml,            only: nlins,ncols
  use definitions,        only: t_state,t_diag,t_grid
  use multiplications,    only: scalar_times_vector_for_gradient

  implicit none

  private

  public :: manage_pressure_gradient

  contains

  subroutine manage_pressure_gradient(state,diag,grid,lfirst)

    type(t_state), intent(in)    :: state ! state to work with
    type(t_diag),  intent(inout) :: diag  ! diagnostic quantities
    type(t_grid),  intent(in)    :: grid  ! model grid
    logical,       intent(in)    :: lfirst ! true for the lfirst model step

    ! saving the old pressure gradient acceleration before it is overwritten with the new one
    if (.not. lfirst) then
      diag%p_grad_acc_old_u(:,:,:) = -diag%p_grad_acc_neg_nl_u(:,:,:) - diag%p_grad_acc_neg_l_u(:,:,:)
      diag%p_grad_acc_old_v(:,:,:) = -diag%p_grad_acc_neg_nl_v(:,:,:) - diag%p_grad_acc_neg_l_v(:,:,:)
      diag%p_grad_acc_old_w(:,:,:) = -diag%p_grad_acc_neg_nl_w(:,:,:) - diag%p_grad_acc_neg_l_w(:,:,:)
    endif

    ! the nonlinear pressure gradient term
    ! calculating the gradient of the perturbed Exner pressure
    call grad(state%exner_pert(2:nlins+1,2:ncols+1,:), &
    diag%p_grad_acc_neg_nl_u,diag%p_grad_acc_neg_nl_v,diag%p_grad_acc_neg_nl_w,grid)
    ! calculating the full potential temperature
    diag%scalar_placeholder(:,:,:) = grid%theta_bg(:,:,:) + state%theta_pert(:,:,:)
    ! multiplying the perturbed Exner pressure gradient by the full potential temperature
    call scalar_times_vector_for_gradient(diag%scalar_placeholder,diag%p_grad_acc_neg_nl_u,diag%p_grad_acc_neg_nl_v, &
    diag%p_grad_acc_neg_nl_w,diag%p_grad_acc_neg_nl_u,diag%p_grad_acc_neg_nl_v,diag%p_grad_acc_neg_nl_w,grid)

    ! the linear pressure gradient term
    ! multiplying the background Exner pressure gradient by the perturbed potential temperature
    call scalar_times_vector_for_gradient(state%theta_pert,grid%exner_bg_grad_u,grid%exner_bg_grad_v, &
    grid%exner_bg_grad_w,diag%p_grad_acc_neg_l_u,diag%p_grad_acc_neg_l_v,diag%p_grad_acc_neg_l_w,grid)

    ! At the first step, the "old" pressure gradient acceleration is saved for the first time.
    if (lfirst) then
      diag%p_grad_acc_old_u(:,:,:) = -diag%p_grad_acc_neg_nl_u(:,:,:) - diag%p_grad_acc_neg_l_u(:,:,:)
      diag%p_grad_acc_old_v(:,:,:) = -diag%p_grad_acc_neg_nl_v(:,:,:) - diag%p_grad_acc_neg_l_v(:,:,:)
      diag%p_grad_acc_old_w(:,:,:) = -diag%p_grad_acc_neg_nl_w(:,:,:) - diag%p_grad_acc_neg_l_w(:,:,:)
    endif

  end subroutine manage_pressure_gradient

end module pressure_gradient