!##############################################################################
!# ****************************************************************************
!# <name> burgers1d_method5 </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module is a demonstation program how to solve a 1D Burgers equation
!# simultaneously in space/time.
!#
!# The 1D burgers equation in space/time is defined by:
!#
!#    $$  u_t  +  u*u_x  -  \nu u_xx  =  0,   u(x,0) = sin(Pi*x)  $$
!#
!# We solve this equation in the space/time domain
!# $(x,t) \in \Omega=[0,1]x[0,1]$. In this example, we use a direct space-time
!# discretisation, i.e. we do not use a separate time-discretisation.
!# Instead, we replace the $t$ variable by $y$-variable of a usual
!# 2D space discretisation, thus resulting in the formula
!#
!#    $$  u_y  +  u*u_x  -  \nu u_xx  =  0,   u(x,0) = sin(Pi*x)  $$
!#
!# For Solving this in the domain $\Omega$, we follow the usual way:
!# The tasks of reading the domain, creating triangulations, discretisation,
!# solving, postprocessing and creanup into different subroutines.
!# The communication between these subroutines is done using an
!# application-specific structure saving problem data.
!#
!# As this problem is nonlinear, we need to invoke a nonlinear solver,
!# which uses a couple of application-spcific callback routines.
!# To provide these routines with necessary data, we build up a collection
!# structure. This is passed through the solver to the callback routines.
!#
!# The preconditioning in this example is done by a UMFPACK4 Gauss
!# elimination.
!#
!# </purpose>
!##############################################################################

module burgers1d_method5

  use fsystem
  use storage
  use genoutput
  use linearsolver
  use boundary
  use cubature
  use matrixfilters
  use vectorfilters
  use discretebc
  use bcassembly
  use triangulation
  use spatialdiscretisation
  use scalarpde
  use element
  use bilinearformevaluation
  use linearformevaluation
  use nonlinearsolver
  use ucd

  use collection

  use burgers1d_callback

  implicit none

!<types>

!<typeblock description="Type block defining all information about one level">

  type t_problem_lvl

    ! An object for saving the triangulation on the domain
    type(t_triangulation) :: rtriangulation

    ! An object specifying the discretisation (structure of the
    ! solution, trial/test functions,...)
    type(t_blockDiscretisation) :: rdiscretisation

    ! Cubature info structure which encapsules the cubature formula
    type(t_scalarCubatureInfo) :: rcubatureInfo

    ! A system matrix for that specific level. The matrix will receive the
    ! discrete Laplace operator.
    type(t_matrixBlock) :: rmatrix

    ! A variable describing the discrete boundary conditions.
    type(t_discreteBC) :: rdiscreteBC

  end type

!</typeblock>

!<typeblock description="Application-specific type block for burgers1d problem">

  type t_problem

    ! Maximum refinement level = level where the system is solved
    integer :: ilvmax

    ! An object for saving the domain:
    type(t_boundary) :: rboundary

    ! A solution vector and a RHS vector on the finest level.
    type(t_vectorBlock) :: rvector,rrhs

    ! A solver node that accepts parameters for the linear solver
    type(t_linsolNode), pointer :: p_rsolverNode

    ! An array of t_problem_lvl structures, each corresponding
    ! to one level of the discretisation. There is currently
    ! only one level supported, identified by LV!
    type(t_problem_lvl) :: rlevelInfo

    ! A collection structure with problem-dependent data
    type(t_collection) :: rcollection

  end type

!</typeblock>

!</types>

contains

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_initParamTriang (ilvmax,rproblem)

!<description>
  ! This routine initialises the parametrisation and triangulation of the
  ! domain. The corresponding .prm/.tri files are read from disc and
  ! the triangulation is refined as described by the parameter ilv.
!</description>

!<input>
  ! Maximum refinement level
  integer, intent(in) :: ilvmax
!</input>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout) :: rproblem
!</inputoutput>

!</subroutine>

    ! Path to the mesh
    character(len=SYS_STRLEN) :: spredir

    ! Initialise the level in the problem structure
    rproblem%ilvmax = ilvmax

    ! Store the min/max level in the collection to be used in
    ! callback routines
    call collct_setvalue_int(rproblem%rcollection,"NLMAX",ilvmax,.true.)

    ! Get the path $PREDIR from the environment, where to read .prm/.tri files
    ! from. If that does not exist, write to the directory "./pre".
    if (.not. sys_getenv_string("PREDIR", spredir)) spredir = "./pre"

    ! At first, read in the parametrisation of the boundary and save
    ! it to rboundary.
    call boundary_read_prm(rproblem%rboundary, trim(spredir)//"/QUAD.prm")

    ! Now read in the basic triangulation.
    call tria_readTriFile2D (rproblem%rlevelInfo%rtriangulation, &
        trim(spredir)//"/QUAD.tri", rproblem%rboundary)

    ! Refine the mesh up to the maximum level
    call tria_quickRefine2LevelOrdering(rproblem%ilvmax-1,&
        rproblem%rlevelInfo%rtriangulation,rproblem%rboundary)

    ! Create information about adjacencies and everything one needs from
    ! a triangulation. Afterwards, we have the coarse mesh.
    call tria_initStandardMeshFromRaw (&
        rproblem%rlevelInfo%rtriangulation,rproblem%rboundary)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_initDiscretisation (rproblem)

!<description>
  ! This routine initialises the discretisation structure of the underlying
  ! problem and saves it to the problem structure.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

    ! An object for saving the domain:
    type(t_boundary), pointer :: p_rboundary

    ! An object for saving the triangulation on the domain
    type(t_triangulation), pointer :: p_rtriangulation

    ! An object for the spatial discretisation
    type(t_blockDiscretisation), pointer :: p_rdiscretisation

    ! Ask the problem structure to give us the boundary and triangulation.
    ! We need it for the discretisation.
    p_rboundary => rproblem%rboundary
    p_rtriangulation => rproblem%rlevelInfo%rtriangulation

    ! Now we can start to initialise the discretisation. At first, set up
    ! a block discretisation structure that specifies the blocks in the
    ! solution vector. In this simple problem, we only have one block.
    allocate(p_rdiscretisation)
    call spdiscr_initBlockDiscr (rproblem%rlevelInfo%rdiscretisation,1,&
                                 p_rtriangulation, p_rboundary)

    ! Get the discretisation
    p_rdiscretisation => rproblem%rlevelInfo%rdiscretisation

    ! p_rdiscretisation%Rdiscretisations is a list of scalar
    ! discretisation structures for every component of the solution vector.
    ! Initialise the first element of the list to specify the element
    ! for this solution component:
    call spdiscr_initDiscr_simple ( &
                 p_rdiscretisation%RspatialDiscr(1), &
                 EL_Q1,p_rtriangulation, p_rboundary)

    ! Set up an cubature info structure to tell the code which cubature
    ! formula to use
    ! Create an assembly information structure which tells the code
    ! the cubature formula to use. Standard: Gauss 3x3.
    call spdiscr_createDefCubStructure(&
        p_rdiscretisation%RspatialDiscr(1),rproblem%rlevelInfo%rcubatureInfo,&
        CUB_GEN_AUTO_G3)

    call collct_setvalue_cubinfo(rproblem%rcollection,"CUBINFO",&
        rproblem%rlevelInfo%rcubatureInfo,.true.,rproblem%ilvmax)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_initMatVec (rproblem)

!<description>
  ! Calculates the RHS-ector, set up the solution vetor.
  ! Set up the structure of the system matrix/matrices of the linear
  ! system.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

    ! A bilinear and linear form describing the analytic problem to solve
    type(t_linearForm) :: rlinform

    ! A pointer to the system matrix and the RHS/solution vectors.
    type(t_matrixBlock), pointer :: p_rmatrix
    type(t_vectorBlock), pointer :: p_rrhs,p_rvector

    ! A pointer to the discretisation structure with the data.
    type(t_blockDiscretisation), pointer :: p_rdiscretisation

    ! A cubature information structure
    type(t_scalarCubatureInfo), pointer :: p_rcubatureInfo

    ! Ask the problem structure to give us the discretisation structure
    p_rdiscretisation => rproblem%rlevelInfo%rdiscretisation

    p_rmatrix => rproblem%rlevelInfo%rmatrix

    ! Get the cubature information structure
    p_rcubatureInfo => rproblem%rlevelInfo%rcubatureInfo

    ! Initialise the block matrix with default values based on
    ! the discretisation.
    call lsysbl_createMatBlockByDiscr (p_rdiscretisation,p_rmatrix)

    ! Save matrix to the collection.
    ! They maybe used later, expecially in nonlinear problems.
    call collct_setvalue_mat(rproblem%rcollection,"SYSTEMMAT",&
        p_rmatrix,.true.,rproblem%ilvmax)

    ! Now using the discretisation, we can start to generate
    ! the structure of the system matrix which is to solve.
    ! We create that directly in the block (1,1) of the block matrix
    ! using the discretisation structure of the first block.
    call bilf_createMatrixStructure (&
              p_rdiscretisation%RspatialDiscr(1),LSYSSC_MATRIX9,&
              p_rmatrix%RmatrixBlock(1,1))

    ! Allocate memory for the matrix, do not calculate the entries.
    ! Remember hat we have a nonlinear matrix, which entries must be build
    ! in every step of the nonlinear iteration!
    ! We fill the matrix with 1. This is necessary, as the UMFPACK solver
    ! needs nonzero matrix entries for the symbolic factorisation!
    call lsyssc_allocEmptyMatrix(p_rmatrix%RmatrixBlock(1,1),LSYSSC_SETM_ONE)

    ! (Only) on the finest level, we need to calculate a RHS vector
    ! and to allocate a solution vector.
    p_rrhs    => rproblem%rrhs
    p_rvector => rproblem%rvector

    ! Next step: Create a RHS vector and a solution vector and a temporary
    ! vector. All are filled with zero.
    call lsysbl_createVectorBlock (p_rdiscretisation,p_rrhs,.true.)
    call lsysbl_createVectorBlock (p_rdiscretisation,p_rvector,.true.)

    ! Save the solution/RHS vector to the collection. Might be used
    ! later (e.g. in nonlinear problems)
    call collct_setvalue_vec(rproblem%rcollection,"RHS",p_rrhs,.true.)
    call collct_setvalue_vec(rproblem%rcollection,"SOLUTION",p_rvector,.true.)

    ! The vector structure is ready but the entries are missing.
    ! So the next thing is to calculate the content of that vector.
    !
    ! At first set up the corresponding linear form (f,Phi_j):
    rlinform%itermCount = 1
    rlinform%Idescriptors(1) = DER_FUNC

    ! ... and then discretise the RHS to the first subvector of
    ! the block vector using the discretisation structure of the
    ! first block.
    !
    ! We pass our collection structure as well to this routine,
    ! so the callback routine has access to everything what is
    ! in the collection.
    call linf_buildVectorScalar (&
        rlinform,.true.,p_rrhs%RvectorBlock(1),p_rcubatureInfo,&
        coeff_RHS,rproblem%rcollection)

    ! Clear the solution vector on the finest level.
    call lsysbl_clearVector(rproblem%rvector)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_initDiscreteBC (rproblem)

!<description>
  ! This calculates the discrete version of the boundary conditions.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

    ! local variables
    integer :: ilvmax
    type(t_boundaryRegion) :: rboundaryRegion

    ! A pointer to the system matrix and the RHS vector as well as
    ! the discretisation
    type(t_blockDiscretisation), pointer :: p_rdiscretisation

    ! A pointer to the domain
    type(t_boundary), pointer :: p_rboundary

    ilvmax=rproblem%ilvmax

    ! From the matrix or the RHS we have access to the discretisation and the
    ! analytic boundary conditions.
    p_rdiscretisation => rproblem%rlevelInfo%rdiscretisation

    ! Get the domain from the problem structure
    p_rboundary => rproblem%rboundary

    ! Now we have the raw problem. What is missing is the definition of the boundary
    ! conditions.
    ! For implementing boundary conditions, we use a `filter technique with
    ! discretised boundary conditions`. This means, we first have to calculate
    ! a discrete version of the analytic BC, which we can implement into the
    ! solution/RHS vectors using the corresponding filter.
    !
    ! Create a t_discreteBC structure where we store all discretised boundary
    ! conditions.
    call bcasm_initDiscreteBC(rproblem%rlevelInfo%rdiscreteBC)
    !
    ! We "know" already (from the problem definition) that we have four boundary
    ! segments in the domain. Each of these, we want to use for enforcing
    ! some kind of boundary condition.
    !
    ! We ask the boundary routines to create a "boundary region" - which is
    ! simply a part of the boundary corresponding to a boundary segment.
    ! A boundary region roughly contains the type, the min/max parameter value
    ! and whether the endpoints are inside the region or not.
    call boundary_createRegion(p_rboundary,1,1,rboundaryRegion)

    ! We use this boundary region and specify that we want to have Dirichlet
    ! boundary there. The following call does the following:
    ! - Create Dirichlet boundary conditions on the region rboundaryRegion.
    !   We specify icomponent="1" to indicate that we set up the
    !   Dirichlet BC`s for the first (here: one and only) component in the
    !   solution vector.
    ! - Discretise the boundary condition so that the BC`s can be applied
    !   to matrices and vectors
    ! - Add the calculated discrete BC`s to rdiscreteBC for later use.
    call bcasm_newDirichletBConRealBD (p_rdiscretisation,1,&
       rboundaryRegion,rproblem%rlevelInfo%rdiscreteBC,&
       getBoundaryValues,rproblem%rcollection)

    ! Now to the edge 2 of boundary component 1 the domain.
    call boundary_createRegion(p_rboundary,1,2,rboundaryRegion)
    rboundaryRegion%iproperties = BDR_PROP_WITHSTART + BDR_PROP_WITHEND
    call bcasm_newDirichletBConRealBD (p_rdiscretisation,1,&
       rboundaryRegion,rproblem%rlevelInfo%rdiscreteBC,&
       getBoundaryValues,rproblem%rcollection)

    ! Edge 3 of boundary component 1.
    ! Edge 3 must be set up as Neumann boundary, which is realised as
    ! simple "do-$nothing"-boundary conditions. So we do not do anything with edge 3!
    ! CALL boundary_createRegion(p_rboundary,1,3,rboundaryRegion)
    ! CALL bcasm_newDirichletBConRealBD (p_rdiscretisation,1,&
    !    rboundaryRegion,rproblem%rlevelInfo%rdiscreteBC,&
    !    getBoundaryValues,rproblem%rcollection)

    ! Edge 4 of boundary component 1. That is it.
    call boundary_createRegion(p_rboundary,1,4,rboundaryRegion)
    call bcasm_newDirichletBConRealBD (p_rdiscretisation,1,&
       rboundaryRegion,rproblem%rlevelInfo%rdiscreteBC,&
       getBoundaryValues,rproblem%rcollection)

    ! Save to the collection
    call collct_setvalue_discbc(rproblem%rcollection,"DISCRETEBC",&
        rproblem%rlevelinfo%rdiscreteBC,.true.,ilvmax)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_implementBC (rproblem)

!<description>
  ! Implements boundary conditions into the RHS and into a given solution vector.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: ilvmax

    ! A pointer to the RHS/solution vector
    type(t_vectorBlock), pointer :: p_rrhs,p_rvector

    ! Pointer to structure for saving discrete BC`s:
    type(t_discreteBC), pointer :: p_rdiscreteBC

    ! Get our the right hand side and solution from the problem structure
    ! on the finest level
    ilvmax = rproblem%ilvmax
    p_rrhs    => rproblem%rrhs
    p_rvector => rproblem%rvector

    ! Next step is to implement boundary conditions into the RHS and
    ! solution. This is done using a vector filter for discrete boundary
    ! conditions.
    ! The discrete boundary conditions are already attached to the
    ! vectors. Call the appropriate vector filter that modifies the vectors
    ! according to the boundary conditions.

    p_rdiscreteBC => rproblem%rlevelinfo%rdiscreteBC

    call vecfil_discreteBCrhs (p_rrhs,p_rdiscreteBC)
    call vecfil_discreteBCsol (p_rvector,p_rdiscreteBC)

  end subroutine

  ! ***************************************************************************
    subroutine b1d5_getDefect (ite,rx,rb,rd,p_rcollection)

    use linearsystemblock
    use collection

  !<description>
    ! FOR NONLINEAR ITERATION:
    ! Defect vector calculation callback routine. Based on the current iteration
    ! vector rx and the right hand side vector rb, this routine has to compute the
    ! defect vector rd. The routine accepts a pointer to a collection structure
    ! p_rcollection, which allows the routine to access information from the
    ! main application (e.g. system matrices).
  !</description>

  !<input>
    ! Number of current iteration. 0=build initial defect
    integer, intent(in)                           :: ite

    ! Current iteration vector
    type(t_vectorBlock), intent(in),target        :: rx

    ! Right hand side vector of the equation.
    type(t_vectorBlock), intent(in), target       :: rb
  !</input>

  !<inputoutput>
    ! Pointer to collection structure of the application. Points to NULL()
    ! if there is none.
    type(t_collection), pointer                   :: p_rcollection

    ! Defect vector b-A(x)x. This must be filled by the callback routine
    ! with data.
    type(t_vectorBlock), intent(inout), target    :: rd
  !</inputoutput>

      ! local variables
      type(t_bilinearForm) :: rform
      integer :: ilvmax
      type(t_matrixBlock), pointer :: p_rmatrix
      type(t_discreteBC), pointer :: p_rdiscreteBC

      ! A cubature information structure
      type(t_scalarCubatureInfo), pointer :: p_rcubatureInfo

      ! Get maximum level from the collection
      ilvmax = collct_getvalue_int (p_rcollection,"NLMAX")

      ! Get the system matrix on the maximum level
      p_rmatrix => collct_getvalue_mat (p_rcollection,"SYSTEMMAT",ilvmax)

      ! Get the cubature information structure
      p_rcubatureInfo => collct_getvalue_cubinfo (p_rcollection,"CUBINFO",ilvmax)

      ! Put a reference to rx into the collection. This way, we inform the callback
      ! routine of the matrix assembly about the solution vector to use
      ! fot the nonlinear term.
      call collct_setvalue_vec(p_rcollection,"RX",rx,.true.)

      ! Build the entries with the discretisation routine.

      ! For assembling of the entries,
      ! we need a bilinear form, which first has to be set up manually.
      ! We specify the bilinear form (grad Psi_j, grad Phi_i) for the
      ! scalar system matrix in 2D.

      rform%itermCount = 4
      rform%Idescriptors(1,1) = DER_DERIV_Y   ! u_t
      rform%Idescriptors(2,1) = DER_FUNC

      rform%Idescriptors(1,2) = DER_DERIV_X   ! u_x
      rform%Idescriptors(2,2) = DER_FUNC

      rform%Idescriptors(1,3) = DER_DERIV_X   ! -u_xx  -> u_x phi_x
      rform%Idescriptors(2,3) = DER_DERIV_X

      ! The 4th last term u_yy is actually not needed. By setting the coefficient
      ! in front of thisterm to 0 (see matrix assembly callback routine), the term
      ! can be switched off. Nevertheless, we add it here for having the
      ! possibility to use it (by setting the cofficient to a value not equal
      ! to 0), which serves as stabilisation for the problem!

      rform%Idescriptors(1,4) = DER_DERIV_Y   ! -u_xx  -> u_x phi_x
      rform%Idescriptors(2,4) = DER_DERIV_Y

      ! We have nonconstant coefficients here.
      rform%ballCoeffConstant = .false.

      ! Now we can build the matrix entries.
      ! We specify the callback function coeff_burgers for the coefficients.
      ! As long as we use constant coefficients, this routine is not used.
      ! By specifying ballCoeffConstant = .FALSE. above,
      ! the framework will call the callback routine to get analytical data.
      !
      ! We pass our collection structure as well to this routine,
      ! so the callback routine has access to everything what is
      ! in the collection.
      call bilf_buildMatrixScalar (rform,.true.,p_rmatrix%RmatrixBlock(1,1),&
          p_rcubatureInfo,coeff_burgers,p_rcollection)

      ! Remove the vector from the collection - not necessary anymore.
      call collct_deletevalue (p_rcollection,"RX")

      ! Get the boundary conditions
      p_rdiscreteBC => collct_getvalue_discbc (p_rcollection,"DISCRETEBC",ilvmax)

      ! Implement discrete boundary conditions into the matrix.
      ! Call the appropriate matrix filter to modify the system matrix
      ! according to the attached discrete boundary conditions.
      call matfil_discreteBC (p_rmatrix,p_rdiscreteBC)

      ! Build the defect: d=b-Ax
      call lsysbl_copyVector (rb,rd)
      call lsysbl_matVec (p_rmatrix, rx, rd, -1.0_DP, 1.0_DP)

      ! Apply the defect-vector filter for discrete boundary conditions
      ! to modify the defect vector according to the (discrete) boundary
      ! conditions.
      call vecfil_discreteBCdef (rd,p_rdiscreteBC)

      ! That is it

    end subroutine

  ! ***************************************************************************

    subroutine b1d5_precondDefect (ite,rd,rx,rb,domega,bsuccess,p_rcollection)

    use linearsystemblock
    use collection

  !<description>
    ! FOR NONLINEAR ITERATION:
    ! Defect vector calculation callback routine. Based on the current iteration
    ! vector rx and the right hand side vector rb, this routine has to compute the
    ! defect vector rd. The routine accepts a pointer to a collection structure
    ! p_rcollection, which allows the routine to access information from the
    ! main application (e.g. system matrices).
  !</description>

  !<inputoutput>
    ! Number of current iteration.
    integer, intent(in)                           :: ite

    ! Defect vector b-A(x)x. This must be replaced by J^{-1} rd by a preconditioner.
    type(t_vectorBlock), intent(inout), target    :: rd

    ! Pointer to collection structure of the application. Points to NULL()
    ! if there is none.
    type(t_collection), pointer                   :: p_rcollection

    ! Damping parameter. Is set to rsolverNode%domega (usually = 1.0_DP)
    ! on the first call to the callback routine.
    ! The callback routine can modify this parameter according to any suitable
    ! algorithm to calculate an "optimal damping" parameter. The nonlinear loop
    ! will then use this for adding rd to the solution vector:
    ! $$ x_{n+1} = x_n + domega*rd $$
    ! domega will stay at this value until it is changed again.
    real(DP), intent(inout)                       :: domega

    ! If the preconditioning was a success. Is normally automatically set to
    ! TRUE. If there is an error in the preconditioner, this flag can be
    ! set to FALSE. In this case, the nonlinear solver breaks down with
    ! the error flag set to "preconditioner broke down".
    logical, intent(inout)                        :: bsuccess
  !</inputoutput>

  !<input>
    ! Current iteration vector
    type(t_vectorBlock), intent(in), target       :: rx

    ! Current right hand side of the nonlinear system
    type(t_vectorBlock), intent(in), target       :: rb
  !</input>

      ! An array for the system matrix(matrices) during the initialisation of
      ! the linear solver.
      integer :: ierror
      type(t_linsolNode), pointer :: p_rsolverNode

      ! Our "parent" (the caller of the nonlinear solver) has prepared
      ! a preconditioner node for us (a linear solver with symbolically
      ! factorised matrices). Get this from the collection.

      p_rsolverNode => collct_getvalue_linsol(p_rcollection,"LINSOLVER")

      ! Initialise data of the solver. This in fact performs a numeric
      ! factorisation of the matrices in UMFPACK-like solvers.
      call linsol_initData (p_rsolverNode, ierror)

      if (ierror .ne. LINSOL_ERR_NOERROR) then
        call output_line("Matrix singular!",OU_CLASS_ERROR)
        call sys_halt()
      end if

      ! Finally solve the system. As we want to solve Ax=b with
      ! b being the real RHS and x being the real solution vector,
      ! we use linsol_solveAdaptively. If b is a defect
      ! RHS and x a defect update to be added to a solution vector,
      ! we would have to use linsol_precondDefect instead.
      call linsol_precondDefect (p_rsolverNode,rd)

      ! Release the numeric factorisation of the matrix.
      ! We do not release the symbolic factorisation, as we can use them
      ! for the next iteration.
      call linsol_doneData (p_rsolverNode)

    end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_solve (rproblem)

!<description>
  ! Solves the given problem by applying a nonlinear solver.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

    ! local variables
    type(t_vectorBlock), target :: rtempBlock

    type(t_nlsolNode) :: rnlSol
    integer :: ierror
    type(t_linsolNode), pointer :: p_rsolverNode

    ! For solving the problem, we need to invoke a nonlinear solver.
    ! This nonlinear solver
    !  - builds in every step a linearisation of the system matrix
    !  - calls a linear solver for preconditioning
    ! We can save some time in this situation, if we prepare the
    ! linear solver in-advance. This means:
    !  - allocate memory in advance and
    !  - perform a symbolic factorisation of the matrix in advance.
    ! The point is that the entries of the matrix change in every
    ! iteration - but not the matrix structure! So this is something
    ! we can prepare once and use it through the whole solution process!
    !
    ! At first, set up the linear solver as usual:
    call linsol_initUMFPACK4 (p_rsolverNode)

    ! And associate it to the solver
    call linsol_setMatrix(p_rsolverNode,rproblem%rlevelInfo%rmatrix)

    ! Initialise structure of the solver. This allows the
    ! solver to allocate memory / perform some precalculation
    ! to the problem.
    ! In fact, solvers like UMFPACK use this for a symbolic factorisation
    ! of the matrix.
    call linsol_initStructure (p_rsolverNode, ierror)
    if (ierror .ne. LINSOL_ERR_NOERROR) stop

    ! Put the prepared solver node to the collection for later use.
    call collct_setvalue_linsol(rproblem%rcollection,"LINSOLVER",p_rsolverNode,.true.)

    ! Create a temporary vector we need for the nonlinera iteration.
    call lsysbl_createVecBlockIndirect (rproblem%rrhs, rtempBlock, .false.)

    ! The nonlinear solver structure rnlSol is initialised by the default
    ! initialisation with all necessary information to solve the problem.
    ! We call the nonlinear solver directly. For preconditioning
    ! and defect calculation, we use our own callback routine.
    !rnlSol%domega = 0.25_DP
    rnlSol%ioutputLevel = 2
    call nlsol_performSolve(rnlSol,rproblem%rvector,rproblem%rrhs,rtempBlock,&
                            b1d5_getDefect,b1d5_precondDefect,&
                            rcollection=rproblem%rcollection)

    ! Release the temporary vector
    call lsysbl_releaseVector (rtempBlock)

    ! Remove the solver node from the collection - not needed anymore there
    call collct_deletevalue(rproblem%rcollection,"LINSOLVER")

    ! Clean up the linear solver, release all memory, remove the solver node
    ! from memory.
    call linsol_releaseSolver (p_rsolverNode)

    call output_lbrk()
    call output_line ("Nonlinear solver statistics")
    call output_line ("---------------------------")
    call output_line ("Initial defect: "//trim(sys_sdEL(rnlSol%DinitialDefect(1),15)))
    call output_line ("Final defect:  "//trim(sys_sdEL(rnlSol%DfinalDefect(1),15)))
    call output_line ("#Iterations:   "//trim(sys_siL(rnlSol%iiterations,10)))

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_postprocessing (rproblem)

!<description>
  ! Writes the solution into a GMV file.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables

    ! We need some more variables for postprocessing
    real(DP), dimension(:), pointer :: p_Ddata

    ! Output block for UCD output to VTK file
    type(t_ucdExport) :: rexport
    character(len=SYS_STRLEN) :: sucddir

    ! A pointer to the solution vector and to the triangulation.
    type(t_vectorBlock), pointer :: p_rvector
    type(t_triangulation), pointer :: p_rtriangulation

    ! Cubature information structure
    type(t_scalarCubatureInfo), pointer :: p_rcubatureInfo

    ! Get the solution vector from the problem structure.
    p_rvector => rproblem%rvector

    ! From the attached discretisation, get the underlying triangulation
    p_rtriangulation => &
      p_rvector%RvectorBlock(1)%p_rspatialDiscr%p_rtriangulation

    ! Get the cubature information structure
    p_rcubatureInfo => rproblem%rlevelInfo%rcubatureInfo

    ! p_rvector now contains our solution. We can now
    ! start the postprocessing.
    !
    ! Get the path for writing postprocessing files from the environment variable
    ! $UCDDIR. If that does not exist, write to the directory "./gmv".
    if (.not. sys_getenv_string("UCDDIR", sucddir)) sucddir = "./gmv"

    ! Start UCD export to VTK file:
    call ucd_startVTK (rexport,UCD_FLAG_STANDARD,p_rtriangulation,trim(sucddir)//"/u5.vtk")

    call lsyssc_getbase_double (p_rvector%RvectorBlock(1),p_Ddata)
    call ucd_addVariableVertexBased (rexport,"sol",UCD_VAR_STANDARD, p_Ddata)

    ! Write the file to disc, that is it.
    call ucd_write (rexport)
    call ucd_release (rexport)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_doneMatVec (rproblem)

!<description>
  ! Releases system matrix and vectors.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

    integer :: ilvmax

    ! Release matrix and vectors on all levels
    ilvmax=rproblem%ilvmax

    ! Delete the matrix
    call lsysbl_releaseMatrix (rproblem%rlevelInfo%rmatrix)

    ! Delete the variables from the collection.
    call collct_deletevalue (rproblem%rcollection,"SYSTEMMAT",ilvmax)

    ! Delete solution/RHS vector
    call lsysbl_releaseVector (rproblem%rvector)
    call lsysbl_releaseVector (rproblem%rrhs)

    ! Delete the variables from the collection.
    call collct_deletevalue (rproblem%rcollection,"RHS")
    call collct_deletevalue (rproblem%rcollection,"SOLUTION")

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_doneBC (rproblem)

!<description>
  ! Releases discrete boundary conditions from the heap.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: ilvmax

    ilvmax=rproblem%ilvmax

    ! Delete from the collection
    call collct_deletevalue (rproblem%rcollection,"DISCRETEBC",ilvmax)

    ! Release our discrete version of the boundary conditions
    call bcasm_releaseDiscreteBC (rproblem%rlevelInfo%rdiscreteBC)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_doneDiscretisation (rproblem)

!<description>
  ! Releases the discretisation from the heap.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: ilvmax

    ilvmax=rproblem%ilvmax

    ! Release the cubature info structure.
    call spdiscr_releaseCubStructure(rproblem%rlevelInfo%rcubatureInfo)
    call collct_deletevalue (rproblem%rcollection,"CUBINFO",ilvmax)

    ! Delete the block discretisation together with the associated
    ! scalar spatial discretisations....
    call spdiscr_releaseBlockDiscr(rproblem%rlevelInfo%rdiscretisation)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine b1d5_doneParamTriang (rproblem)

!<description>
  ! Releases the triangulation and parametrisation from the heap.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

    ! Release the triangulation
    call tria_done (rproblem%rlevelInfo%rtriangulation)

    ! Finally release the domain.
    call boundary_release (rproblem%rboundary)

    call collct_deleteValue(rproblem%rcollection,"NLMAX")

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine burgers1d5

!<description>
  ! This is a "separated" burgers1d solver for solving a Burgers-1D
  ! problem. The different tasks of the problem are separated into
  ! subroutines. The problem uses a problem-specific structure for the
  ! communication: All subroutines add their generated information to the
  ! structure, so that the other subroutines can work with them.
  ! For the communication to callback routines of black-box subroutines
  ! (matrix-assembly, preconditioning), a collection is used.
  !
  ! The following tasks are performed by the subroutines:
  !
  ! 1.) Read in parametrisation
  ! 2.) Read in triangulation
  ! 3.) Set up RHS
  ! 4.) Set up matrix
  ! 5.) Create solver structure
  ! 6.) Solve the problem
  ! 7.) Write solution to GMV file
  ! 8.) Release all variables, finish
!</description>

!</subroutine>

    ! NLMAX receives the level where we want to solve
    integer :: NLMAX

    ! A problem structure for our problem
    type(t_problem), pointer :: p_rproblem

    integer :: i

    ! Ok, let us start.
    !
    ! We want to solve our Laplace problem on level...
    NLMAX = 7

    ! Allocate the problem structure -- it is rather large
    allocate(p_rproblem)

    ! Initialise the collection
    call collct_init (p_rproblem%rcollection)
    do i=1,NLMAX
      call collct_addlevel (p_rproblem%rcollection)
    end do

    ! So now the different steps - one after the other.

    ! Initialisation.
    call b1d5_initParamTriang (NLMAX,p_rproblem)
    call b1d5_initDiscretisation (p_rproblem)
    call b1d5_initMatVec (p_rproblem)
    call b1d5_initDiscreteBC (p_rproblem)

    ! Implementation of boundary conditions
    call b1d5_implementBC (p_rproblem)

    ! Solve the problem
    call b1d5_solve (p_rproblem)

    ! Postprocessing
    call b1d5_postprocessing (p_rproblem)

    ! Cleanup
    call b1d5_doneMatVec (p_rproblem)
    call b1d5_doneBC (p_rproblem)
    call b1d5_doneDiscretisation (p_rproblem)
    call b1d5_doneParamTriang (p_rproblem)

    ! Print some statistical data about the collection - anything forgotten?
    print *
    print *,"Remaining collection statistics:"
    print *,"--------------------------------"
    print *
    call collct_printStatistics (p_rproblem%rcollection)

    ! Finally release the collection and the problem structure.
    call collct_done (p_rproblem%rcollection)

    deallocate(p_rproblem)

  end subroutine

end module


MODULE FEAST
  integer     fpm(128)
  real*8      Emin,Emax
  real*8      epsout
  integer     loop
  integer     M0 ! initial guess
  integer     M1 ! total number of eigenvalues found
  integer     info_FEAST
  real*8,     DIMENSION(:),   ALLOCATABLE :: E, RES ! vector of eigenvalues
  complex*16, DIMENSION(:,:), ALLOCATABLE :: X      ! matrix with eigenvectore
END MODULE FEAST

MODULE TYPES

  TYPE :: MODE
     DOUBLE PRECISION :: OMEGA
     COMPLEX*16       :: X,Y,Z
     DOUBLE PRECISION :: phi_x,phi_y,phi_z
     INTEGER          :: N_Floquet
     COMPLEX*16, DIMENSION(:,:), ALLOCATABLE :: V
     COMPLEX*16, DIMENSION(:),   ALLOCATABLE :: VALUES
     INTEGER,    DIMENSION(:),   ALLOCATABLE :: ROW,COLUMN
  END TYPE MODE

  TYPE :: ATOM
     INTEGER          :: id_system
     INTEGER          :: D_BARE
     DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: E_BARE
  END TYPE ATOM

  TYPE :: HARMONIC_FACTORS
     COMPLEX*16,DIMENSION(:,:), ALLOCATABLE :: U,U_r,U_AVG
     INTEGER,   DIMENSION(:),   ALLOCATABLE :: n
  END type HARMONIC_FACTORS

END MODULE TYPES


      SUBROUTINE SQDM11
C
C     PHASE I OF STRESS DATA RECOVERY FOR THE  QUADRILATERAL MEMBRANE
C     ELEMENT
C
C     CALLS FROM THIS ROUTINE ARE MADE TO
C
C            MAT    - MATERIAL DATA ROUTINE
C            MESAGE - ERROR MESSAGE WRITER
C            GMMATS - SINGLE MATRIX MULTIPLY AND TRANSPOSE
C            TRANSS - SINGLE PRECISION TRANSFORMATION SUPPLIER
C
C
      REAL            LA,LB,LC,LD,LDD2,LBD1,LCD1,LCD2,MAGI,MAGJ,MAGK
      DIMENSION       ECPT(26),EE(144)
      COMMON /SYSTEM/ DUMMY(39),NBPW
      COMMON /CONDAS/ CONSTS(5)
      COMMON /SDR2X5/ NECPT(1),NGRID(4),ANGLE,MATID1,T,FMU,
     2                DUMMY1,X1,Y1,Z1,DUMMY2,X2,Y2,Z2,
     4                DUMMY3,X3,Y3,Z3,DUMMY4,X4,Y4,Z4,DUMB(75),
     6                PH1OUT(100),FORVEC(25)
      COMMON /SDR2X6/ E(9),TI(9),THETA,TEMPAR(150),A(24),G(9),B(96)
      COMMON /MATIN / MATID,INFLAG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/ G11,G12,G13,G22,G23,G33,RHO,ALPHAS(3),TSUB0,GSUBE,
     1                SIGTEN,SIGCOM,SIGSHE,G2X211,G2X212,G2X222
      EQUIVALENCE     (CONSTS(4),DEGRA),(ECPT(1),NECPT(1))
C
C
C      ECPT LIST
C                                                      IN
C                                                      THIS
C        ECPT       DESCRIPTION                        ROUTINE    TYPE
C     *******    *********************************     ********  ******
C     ECPT( 1) = ELEMENT ID                            NECPT(1)  INTEGER
C     ECPT( 2)   GRID POINT A                          NGRID(1)  INTEGER
C     ECPT( 3)   GRID POINT B                          NGRID(2)  INTEGER
C     ECPT( 4)   GRID POINT C                          NGRID(3)  INTEGER
C     ECPT( 5)   GRID POINT D                          NGRID(4)  INTEGER
C     ECPT( 6) = THETA = ANGLE OF MATERIAL             ANGLE      REAL
C     ECPT( 7)   MATERIAL ID                           MATID     INTEGER
C     ECPT( 8) = THICKNESS                             T          REAL
C     ECPT( 9) = NON-STRUCTURAL MASS                   FMU        REAL
C     ECPT(10)   COORD. SYSTEM ID 1                    NECPT(10) INTEGER
C     ECPT(11) = X1                                     X1        REAL
C     ECPT(12) = Y1                                     Y1        REAL
C     ECPT(13) = Z1                                     Z1        REAL
C     ECPT(14)   COORD. SYSTEM ID 2                    NECPT(14) INTEGER
C     ECPT(15) = X2                                     X2        REAL
C     ECPT(16) = Y2                                     Y2        REAL
C     ECPT(17) = Z2                                     Z2        REAL
C     ECPT(18)   COORD. SYSTEM ID 3                    NECPT(18) INTEGER
C     ECPT(19) = X3                                     X3        REAL
C     ECPT(20) = Y3                                     Y3        REAL
C     ECPT(21) = Z3                                     Z3        REAL
C     ECPT(22)   COORD. SYSTEM ID 4                    NECPT(22) INTEGER
C     ECPT(23) = X4                                     X4        REAL
C     ECPT(24) = Y4                                     Y4        REAL
C     ECPT(25)   Z4                                     Z4        REAL
C     ECPT(26) = ELEMENT TEMPERATURE                    ECPT(26)  REAL
C
C
C     SET UP THE E MATRIX WHICH IS (12X12) FOR THE QUAD-MEMBRANE PROJECT
C                         ONTO THE MEAN PLANE
C
      DO 2 I = 1,144
      EE(I) = 0.
    2 CONTINUE
C
C     E(1), E(4), E(7) WILL BE THE I-VECTOR
C     E(2), E(5), E(8) WILL BE THE J-VECTOR
C     E(3), E(6), E(9) WILL BE THE K-VECTOR
C
C     COMPUTE DIFFERENCES OF COORDINATES OF ACTUAL GRID POINTS
C
      X21 = X2 - X1
      Y21 = Y2 - Y1
      Z21 = Z2 - Z1
      X31 = X3 - X1
      Y31 = Y3 - Y1
      Z31 = Z3 - Z1
      X41 = X4 - X1
      Y41 = Y4 - Y1
      Z41 = Z4 - Z1
      X42 = X4 - X2
      Y42 = Y4 - Y2
      Z42 = Z4 - Z2
C
C     COMPUTE ELEMENTS OF THE E MATRIX (3X3)
C
      PK1 = Y31*Z42 - Z31*Y42
      PK2 = Z31*X42 - X31*Z42
      PK3 = X31*Y42 - Y31*X42
      MAGK= SQRT(PK1**2 + PK2**2 + PK3**2)
      IF (MAGK .GT. 1.0E-06) GO TO 40
      CALL MESAGE (-30,32,ECPT(1))
   40 PK1 = PK1/MAGK
      PK2 = PK2/MAGK
      PK3 = PK3/MAGK
C
C     HH IS THE MEASURE OF NON-PLANARITY OF THE ELEMENT
C
      HH  = X21*PK1 + Y21*PK2 + Z21*PK3
      PI1 = X21 - HH*PK1
      PI2 = Y21 - HH*PK2
      PI3 = Z21 - HH*PK3
      MAGI= SQRT(PI1**2 + PI2**2 + PI3**2)
      IF (MAGI .GT. 1.0E-06) GO TO 41
      CALL MESAGE (-30,31,ECPT(1))
   41 PI1 = PI1/MAGI
      PI2 = PI2/MAGI
      PI3 = PI3/MAGI
      HH  =-HH/2.
C
C     THIS SIGN CHANGE MADE BECAUSE SIGN OF H AS DEFINED ON
C     PAGE 4.87-105 OF PROGRAMMERS MANUAL IS WRONG
C
      PJ1 = PK2*PI3 - PK3*PI2
      PJ2 = PK3*PI1 - PK1*PI3
      PJ3 = PK1*PI2 - PK2*PI1
      MAGJ= SQRT(PJ1**2 + PJ2**2 + PJ3**2)
      PJ1 = PJ1/MAGJ
      PJ2 = PJ2/MAGJ
      PJ3 = PJ3/MAGJ
      E(1)= PI1
      E(2)= PJ1
      E(3)= PK1
      E(4)= PI2
      E(5)= PJ2
      E(6)= PK2
      E(7)= PI3
      E(8)= PJ3
      E(9)= PK3
C
C     STORE FOUR (3X3) E MATRICES INTO (12X12) E MATRIX
C
      LLCT = -39
      DO 5 IICT = 1,12,3
      LLCT = LLCT + 39
      NNCT = 0
      MMCT =-12
      DO 4 JJCT = 1,3
      MMCT = MMCT + 12
      DO 3 KKCT = 1,3
      NNCT = NNCT + 1
      KTOT = KKCT + LLCT + MMCT
      EE(KTOT) = E(NNCT)
    3 CONTINUE
    4 CONTINUE
    5 CONTINUE
C
C     COMPUTE DIFFERENCES OF COORDINATES OF GRID POINTS IN THE MEAN PLAN
C
      X12 =-(X21*E(1) + Y21*E(4) + Z21*E(7))
      X13 =-(X31*E(1) + Y31*E(4) + Z31*E(7))
      X14 =-(X41*E(1) + Y41*E(4) + Z41*E(7))
      Y3A = (X31*E(2) + Y31*E(5) + Z31*E(8))
      Y4A = (X42*E(2) + Y42*E(5) + Z42*E(8))
      X24 = X14 - X12
      X23 = X13 - X12
      X34 = X14 - X13
      Y34 = Y3A - Y4A
C
C
C     COMPUTE LENGTHS OF SIDES OF ELEMENT IN THE MEAN PLANE
C
      LA = ABS(X12)
      LB = SQRT(X23**2 + Y3A**2)
      LC = SQRT(X34**2 + Y34**2)
      LD = SQRT(X14**2 + Y4A**2)
C
C     COMPUTE THE CHARACTERISTIC ANGLES OF ELEMENT IN THE MEAN PLANE
C
      CTH1  =-X14/LD
      STH1  = Y4A/LD
      CTH2  = X23/LB
      STH2  = Y3A/LB
      CTH31 = X34/LC
      STH31 =-Y34/LC
      CTH41 = CTH1
      STH41 = STH1
      CTH32 = STH2
      STH32 = CTH2
      CTH42 = STH31
      STH42 = CTH31
C
      DLT1  = CTH31*CTH32 - STH31*STH32
      DLT2  = CTH42*CTH41 + STH41*STH42
      LDD2  = LD*DLT2
      LBD1  = LB*DLT1
      LCD1  = LC*DLT1
      LCD2  = LC*DLT2
C
C                                                  *       *
C     COMPUTE THE INTERSECTION OF THE DIAGONALS(ETA  AND XI ) OF
C     THE ELEMENTS IN THE MEAN PLANE
C
      TOL  = 1.0E-3*(-X12)
      IF (NBPW .GE. 60) TOL  = 1.0E-5*(-X12)
      TOL2 = 1.0E-3*X12*X12
      IF (NBPW .GE. 60) TOL2 = 1.0E-5*X12*X12
      IF (ABS(X34+X12).GT.TOL .OR. ABS(Y34).GT.TOL) GO TO 6
      ETAS =.5
      XIS  =.5
      GO TO 16
    6 IF (ABS(X24).LT.TOL .OR. ABS(X13).LT.TOL) GO TO 7
      XSTAR = (Y4A*X13*X12)/((Y3A*X24)-(Y4A*X13))
      YSTAR = (-Y4A/X24)*(XSTAR+X12)
      GO TO 9
    7 IF (ABS(X13) .GT. TOL) GO TO 8
      XSTAR = -X13
      YSTAR = (-Y4A/X24)*X12
      GO TO 9
    8 XSTAR = -X12
      YSTAR = (Y3A/X13)*X12
    9 IF (ABS(X34+X12) .LT. TOL) GO TO 13
      C1 = Y34*XSTAR - YSTAR*(X34+X12)
      A2 =-Y4A*X23 + Y3A*X14
      B2 =-Y4A*X12 + C1
      IF (ABS(A2) .LE. TOL2) GO TO 10
      TEMP2 = SQRT(B2**2-(4.*A2*X12*YSTAR))/(2.*A2)
      TEMP1 =-B2/(2.*A2)
      ETAS  = TEMP1 - TEMP2
      IF (ETAS.LE.0. .OR. ETAS.GE.1.) ETAS = TEMP1 + TEMP2
      GO TO 11
   10 ETAS = (-X12*YSTAR)/B2
   11 IF (ABS(Y34) .LT. TOL) GO TO 12
      XIS = (-C1 + ((Y4A*X23) - (Y3A*X14))*ETAS)/(Y34*X12)
      GO TO 16
   12 XIS = (XSTAR + (X14*ETAS))/((ETAS*(X34+X12)) - X12)
      GO TO 16
   13 A3 = -X14*Y34
      B3 =  X12*Y4A - Y34*XSTAR
      IF (ABS(A3) .LE. TOL2) GO TO 14
      TEMP2 = SQRT(B3**2 + (4.*A3*X12*YSTAR))/(2.*A3)
      TEMP1 = -B3/(2.*A3)
      ETAS  = TEMP1 - TEMP2
      IF (ETAS.LE.0. .OR. ETAS.GE.1.) ETAS = TEMP1 + TEMP2
      GO TO 15
   14 ETAS = (X12*YSTAR)/B3
   15 XIS  = (YSTAR - (Y4A*ETAS))/(Y34*ETAS)
C
C     SET UP THE (12X12) TRANSFORMATION MATRIX B BETWEEN THE MEAN PLANE
C                        AND ACTUAL GRID POINTS
C
   16 DO 17 I = 2,92
      B(I)  = 0.
   17 CONTINUE
      B(1)  = 1.
      B(10) = 1.
      B(17) =-HH/LA
      B(18) =-HH/(LD*STH1) + ((HH*CTH1)/(LA*STH1))
      B(19) = HH/LA
      B(20) = (HH*CTH2)/(LA*STH2)
      B(23) = (HH*CTH42)/LDD2
      B(24) = (HH*STH42)/LDD2
      B(27) = 1.
      B(36) = 1.
      B(41) =-B(17)
      B(42) = (-HH*CTH1)/(LA*STH1)
      B(43) = B(17)
      B(44) = ((-HH*CTH2)/(LA*STH2)) + (HH/(LB*STH2))
      B(45) = (-HH*STH31)/LBD1
      B(46) = (-HH*CTH31)/LBD1
      B(53) = 1.
      B(62) = 1.
      B(68) =-HH/(LB*STH2)
      B(69) = HH*((STH31/LBD1) + (CTH32/LCD1))
      B(70) = HH*((CTH31/LBD1) + (STH32/LCD1))
      B(71) = (-HH*STH41)/LCD2
      B(72) = (HH*CTH41)/LCD2
      B(79) = 1.
      B(88) = 1.
      B(90) = HH/(LD*STH1)
      B(93) = (-HH*CTH32)/LCD1
      B(94) = (-HH*STH32)/LCD1
      B(95) = HH*((-CTH42/LDD2) + (STH41/LCD2))
      B(96) = HH*((-STH42/LDD2) - (CTH41/LCD2))
      DO 18 I = 1,24
      A(I)  = 0.
   18 CONTINUE
C                                                     T
C     COMPUTE TRANSFORMED MATRIX OF STIFFNESSES  G = P  * G * P
C
      THETA  = ANGLE*DEGRA
      SINTH  = SIN(THETA)
      COSTH  = COS(THETA)
      IF (ABS(SINTH) .LT. 1.0E-06) SINTH = 0.0E0
      MATID  = MATID1
      INFLAG = 2
      ELTEMP = ECPT(26)
      CALL MAT (ECPT(1))
C
C     STORE INTO G MATRIX
C
      G(1) = G11
      G(2) = G12
      G(3) = G13
      G(4) = G12
      G(5) = G22
      G(6) = G23
      G(7) = G13
      G(8) = G23
      G(9) = G33
C
C     COMPUTE MATRIX A TO RELATE DISPLACEMENTS TO STRAINS
C
      AJ    = (-Y4A*X12) + (-Y34*X12*XIS) + ETAS*((-Y4A*X23)+(Y3A*X14))
      A(1)  = (-Y4A + (Y3A*ETAS) - (Y34*XIS))/AJ
      A(3)  = ( Y4A - (Y4A*ETAS) + (Y34*XIS))/AJ
      A(5)  = ( Y4A*ETAS)/AJ
      A(7)  = (-Y3A*ETAS)/AJ
      A(10) = (-X24 + (X23*ETAS) + (X34*XIS))/AJ
      A(12) = ( X14 - (X14*ETAS) - (X34*XIS))/AJ
      A(14) = ((X14*ETAS) - (X12*XIS))/AJ
      A(16) = (-X12 - (X23*ETAS) + (X12*XIS))/AJ
      A(17) = (-X24 + (X23*ETAS) + (X34*XIS))/AJ
      A(18) = (-Y4A + (Y3A*ETAS) - (Y34*XIS))/AJ
      A(19) = ( X14 - (X14*ETAS) - (X34*XIS))/AJ
      A(20) = ( Y4A - (Y4A*ETAS) + (Y34*XIS))/AJ
      A(21) = ((X14*ETAS) - (X12*XIS))/AJ
      A(22) = (Y4A*ETAS)/AJ
      A(23) = (-X12 - (X23*ETAS) + (X12*XIS))/AJ
      A(24) = (-Y3A*ETAS)/AJ
C
C                          T    T
C     COMPUTE S = G * A * B  * E
C
      CALL GMMATS (B(1),12,8,1,EE(1),12,12,1,TEMPAR(1))
      CALL GMMATS (A(1),3,8,0,TEMPAR(1),8,12,0,TEMPAR(100))
      CALL GMMATS (G(1),3,3,0,TEMPAR(100),3,12,0,TEMPAR(1))
      DO 27 L = 1,4
      DO 19 N = 2,5
      IF (NECPT(N) .NE. NGRID(L)) GO TO 19
      KA = 4*N + 2
      GO TO 20
   19 CONTINUE
      CALL MESAGE (-30,34,ECPT(1))
   20 IF (NECPT(KA) .EQ. 0) GO TO 21
      CALL TRANSS (NECPT(KA),TI)
      GO TO 23
   21 DO 22 II = 1,9
      TI(II) = 0.
   22 CONTINUE
      TI(1) = 1.
      TI(5) = 1.
      TI(9) = 1.
   23 LCNT  = 3*(L-1)
      IROWCT= -12
      NN    = 0
      DO 25 JJ = 1,3
      IROWCT= IROWCT + 12
      DO 24 KK = 1,3
      NN   = NN + 1
      KTOT = KK + IROWCT + LCNT
      NN49 = NN + 49
      TEMPAR(NN49) = TEMPAR(KTOT)
   24 CONTINUE
   25 CONTINUE
      CALL GMMATS (TEMPAR(50),3,3,0,TI,3,3,0,TEMPAR(60))
C
C                                                          TH
C     MATRICES S  RELATE DISPLACEMENTS TO STRESSES AT THE I   GRIDPOINT
C               I
C
      DO 26 IL = 1,9
      KTOT = IL + 9*L
      IL59 = IL + 59
      PH1OUT(KTOT) = TEMPAR(IL59)
   26 CONTINUE
   27 CONTINUE
      CALL GMMATS (G(1),3,3,0,ALPHAS(1),3,1,0,PH1OUT(7))
      PH1OUT(1) = ECPT(1)
      PH1OUT(2) = ECPT(2)
      PH1OUT(3) = ECPT(3)
      PH1OUT(4) = ECPT(4)
      PH1OUT(5) = ECPT(5)
      PH1OUT(6) = TSUB0
      RETURN
      END


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine getstruc(mynod,vbrar,omegbra,eta,
     >                    iprslat_mad,ipknlat_mad,
     >                    rslat_x,rslat_y,rslat_z,rslatsq,nrslat,
     >                    knlat_x,knlat_y,knlat_z,knlatsq,nknlat,
     >                    iprint,istop)
c     ================================================================
c
      implicit   none
c
      character  sname*32
      character  istop*32
c
      integer    mynod
      integer    iprslat_mad
      integer    ipknlat_mad
      integer    nrslat
      integer    nknlat
      integer    n1
      integer    nm1
      integer    nm2
      integer    nm3
      integer    iprint
c
      real*8     eta
      real*8     rslat_x(iprslat_mad)
      real*8     rslat_y(iprslat_mad)
      real*8     rslat_z(iprslat_mad)
      real*8     rslatsq(iprslat_mad)
      real*8     vbrar(3,3)
      real*8     knlat_x(ipknlat_mad)
      real*8     knlat_y(ipknlat_mad)
      real*8     knlat_z(ipknlat_mad)
      real*8     knlatsq(ipknlat_mad)
      real*8     vbrak(3,3)
      real*8     rscut
      real*8     kncut
      real*8     omegbra
      real*8     two
      real*8     fnpi
      real*8     factor
c
      parameter (two=2.0d0)
      parameter (sname='getstruc')
c
c     ****************************************************************
c     Sets up real space and receprocal space Bravais lattice vectors
c     ****************************************************************
c
c     ================================================================
c     calculate rscut, the radius of real space truncation sphere.....
c     ----------------------------------------------------------------
      call getrscut(eta,vbrar(1,1),vbrar(1,2),vbrar(1,3),
     >              rscut,nm1,nm2,nm3)
ctest
c     nm1=6
c     nm2=6
c     nm3=6
c     rscut=44.d0*8.d0/6.2831853d0
ctest
c     ----------------------------------------------------------------
c
c     ================================================================
c     generate the real space lattice vectors.........................
c     ----------------------------------------------------------------
      call lattice(vbrar,rscut,nm1,nm2,nm3,
     >             rslat_x,rslat_y,rslat_z,rslatsq,nrslat,iprslat_mad,
     >             iprint,istop)
c     ----------------------------------------------------------------
      if(iprint.ge.1) then
         write(6,'(/,'' GETSTRUC:: nm1,nm2,nm3   = '',3i5)')nm1,nm2,nm3
         write(6,'(  ''            Rs cut radius = '',1f10.5)') rscut
         write(6,'(  ''            Number of Rs  = '',i5)') nrslat
      endif
c     ================================================================
c     calculate the bravais lattice cell volume......................
      omegbra=(vbrar(2,1)*vbrar(3,2)-vbrar(3,1)*vbrar(2,2))*vbrar(1,3)+
     >        (vbrar(3,1)*vbrar(1,2)-vbrar(1,1)*vbrar(3,2))*vbrar(2,3)+
     >        (vbrar(1,1)*vbrar(2,2)-vbrar(2,1)*vbrar(1,2))*vbrar(3,3)
      omegbra=abs(omegbra)
c
c     ================================================================
c     generate basis vectors for reciprocal space....................
      factor=two*fnpi()/omegbra
      vbrak(1,1)=factor*(vbrar(2,2)*vbrar(3,3)-vbrar(3,2)*vbrar(2,3))
      vbrak(2,1)=factor*(vbrar(3,2)*vbrar(1,3)-vbrar(1,2)*vbrar(3,3))
      vbrak(3,1)=factor*(vbrar(1,2)*vbrar(2,3)-vbrar(2,2)*vbrar(1,3))
      vbrak(1,2)=factor*(vbrar(2,3)*vbrar(3,1)-vbrar(3,3)*vbrar(2,1))
      vbrak(2,2)=factor*(vbrar(3,3)*vbrar(1,1)-vbrar(1,3)*vbrar(3,1))
      vbrak(3,2)=factor*(vbrar(1,3)*vbrar(2,1)-vbrar(2,3)*vbrar(1,1))
      vbrak(1,3)=factor*(vbrar(2,1)*vbrar(3,2)-vbrar(3,1)*vbrar(2,2))
      vbrak(2,3)=factor*(vbrar(3,1)*vbrar(1,2)-vbrar(1,1)*vbrar(3,2))
      vbrak(3,3)=factor*(vbrar(1,1)*vbrar(2,2)-vbrar(2,1)*vbrar(1,2))
      if(iprint.ge.1) then
         write(6,'(/)')
         write(6,'(12x,
     >         ''    n                    rslat                  '',
     >         ''rslatsq'')')
         write(6,'(12x,56(''=''))')
         write(6,'(12x,1i5,2x,4f12.5)')
     >        (n1,rslat_x(n1),rslat_y(n1),rslat_z(n1),rslatsq(n1),
     >         n1=1,nrslat)
         write(6,'(/)')
      endif
c
c     ================================================================
c     calculate kncut, the radius of k-space truncation sphere........
c     ----------------------------------------------------------------
      call getkncut(eta,vbrak(1,1),vbrak(1,2),vbrak(1,3),
     >              kncut,nm1,nm2,nm3)
c     ----------------------------------------------------------------
c
c     ================================================================
ctest
c     nm1=6
c     nm2=6
c     nm3=6
c     kncut=.98d0
c     kncut=.98d0/8.d0*6.2831853d0
ctest
c     generate the reciprocal space lattice vectors...................
c     ----------------------------------------------------------------
      call lattice(vbrak,kncut,nm1,nm2,nm3,
     >             knlat_x,knlat_y,knlat_z,knlatsq,nknlat,ipknlat_mad,
     >             iprint,istop)
c     ----------------------------------------------------------------
      if(iprint.ge.1) then
         write(6,'(  ''            nm1,nm2,nm3   = '',3i5)')nm1,nm2,nm3
         write(6,'(  ''            Kn cut radius = '',1f10.5)') kncut
         write(6,'(  ''            Number of Kn  = '',i5)') nknlat
         write(6,'(/)')
         write(6,'(12x,
     >         ''    n                    knlat                  '',
     >         ''knlatsq'')')
         write(6,'(12x,56(''=''))')
         write(6,'(12x,1i5,2x,4f12.5)')
     >        (n1,knlat_x(n1),knlat_y(n1),knlat_z(n1),knlatsq(n1),
     >         n1=1,nknlat)
      endif
c
c     ================================================================
      if(sname.eq.istop) then
         call fstop(sname)
      else
         return
      endif
c
      end


program emulator
    use libnpcf

    type, bind(C) :: float3
        real(kind = 4) :: x, y, z
    end type

    type(npcf) :: corr
    type(float3), dimension(:), allocatable :: pos, triangles
    integer :: s1, i, timesRans, numShells, numTriangles, dummy
    double precision :: r_max, r_min, V_box
    double precision, dimension (:), allocatable :: threePoint, twoPoint, shells

    ! Information for setting up the correlation function object
    timesRans = 10
    numShells = 32
    V_box = 1024.0**3
    r_max = 32.0
    r_min = 0.0

    ! Initialize the library object
    corr = npcf(timesRans, numShells, V_box, r_min, r_max)

    ! This function determines the number of unique triangles such that r1 <= r2 <= r3. This will remain
    ! the same for all realizations
    numTriangles = corr%getNumTriangles()

    ! Set up storage for the correlation functions
    allocate(shells(numShells))
    allocate(twoPoint(numShells))
    allocate(triangles(numTriangles))
    allocate(threePoint(numTriangles))

    ! These two functions return the central radii for the spherical shells for the 2-point function
    ! and the central side lengths for the triangles of the 3-point function
    dummy = corr%getShells(shells)
    dummy = corr%getTriangles(triangles)

    ! This part of the code emulates what you will need to do in the looping structure of the MCMC chain

        ! Instead of reading from a file, your code will generate the list of galaxies
        open(1, file = 'LNKNLogsVelFortran_01.dat', status = 'old')
        read (1,*) s1
        allocate(pos(s1))

        do i = 1,s1
            read(1,*)pos(i)
        end do
        close(1)

        ! You need to tell the npcf library how many galaxies there are in a particular realization
        dummy = corr%setNumParticles(s1)

        ! Next we tell the library to compute the correlations given the list of galaxies
        dummy = corr%calculateCorrelations(pos)

        ! We can also tell the library to only compute the 2pt function
        dummy = corr%calculate2pt(pos)

        ! Then we can copy the results back to the Fortran side
        dummy = corr%get2pt(twoPoint)
        dummy = corr%get3pt(threePoint)

        ! Your code would then compute the likelihood and move to the next parameter vector guess

    ! Output the 2 and 3 point functions for testing purposes
    open(2, file = 'twoPoint.dat', action = 'write', status = 'replace')
    do i = 1,numshells
        write (2,*) shells(i), twoPoint(i)
    end do
    close(2)

    open(3, file = 'threePoint.dat', action = 'write', status = 'replace')
    do i = 1,numTriangles
        write (3,*) triangles(i), threePoint(i)
    end do
    close(3)

    ! Free the memory of dynamically allocated arrays
    deallocate(shells)
    deallocate(triangles)
    deallocate(twoPoint)
    deallocate(threePoint)
    deallocate(pos)

#ifdef __GNUC__
    call corr%delete
#endif

end program emulator


!========================================================
! Simplify this function to speed up the calculation 2016/9/5
!FUNCTION WAPR (X, NB, L) RESULT (WAP)
! NB = 0, L = 0
FUNCTION WAPR (X) RESULT (WAP)
!
!     WAPR - output
!     X - argument of W(X)
!     NB is the branch of the W function needed:
!        NB = 0 - upper branch
!        NB <> 0 - lower branch
!
!     NERROR is the output error flag:
!        NERROR = 0 -> routine completed successfully
!        NERROR = 1 -> X is out of range
!
!     Range: -exp(-1) <= X for the upper branch of the W function
!            -exp(-1) < X < 0 for the lower branch of the W function
!
!     L - determines how WAPR is to treat the argument X
!        L = 1 -> X is the offset from -exp(-1), so compute
!                 W(X-exp(-1))
!        L <> 1 -> X is the desired X, so compute W(X)
!
!     M - print messages from WAPR?
!         M = 1 -> Yes
!         M <> 1 -> No
!
!     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
!     NN is the output device number
!
!     NBITS is the number of bits (less 1) in the mantissa of the
!        floating point number number representation of your machine.
!        It is used to determine the level of accuracy to which the W
!        function should be calculated.
!
!        Most machines use a 24-bit matissa for single precision and
!        53-56 bits for double precision. The IEEE standard is 53
!        bits. The Fujitsu VP2200 uses 56 bits. Long word length
!        machines vary, e.g., the Cray X/MP has a 48-bit mantissa for
!        single precision.
!
IMPLICIT NONE
real, INTENT(in)   :: X
INTEGER, PARAMETER :: NN=6, NBITS=23, NITER=1
real,    PARAMETER ::EM=-0.367879441171442,&           ! -EXP(-1)
                     EM9=-1.234098040866796E-4,&       ! -EXP(-9)
                     C13=1.E0/3.E0,&
                     C23=2.E0*C13,&
                     EM2=2.E0/EM,&
                     E12=-EM2,&
                     TB=.5E0**NBITS,&
                     TB2=.5E0**(NBITS/2),&       ! SQRT(TB)
                     X0=0.0350769390096679055,&  ! TB**(1/6)*0.5E0
                     X1=0.302120119432784731,&   !(1 - 17*TB**(2/7))*EM
                     AN22=3.6E2/83.E0,&
                     AN11=135./83.E0,&
                     AN3=8.E0/3.E0,&
                     AN4=135.E0/83.E0,&
                     AN5=166.E0/39.E0,&
                     AN6=3167.E0/3549.E0,&
                     S2=1.41421356237310,& ! SQRT(2.E0)
                     S21=2.E0*S2-3.E0,&
                     S22=4.E0-3.E0*S2,&
                     S23=S2-2.E0
real ::  WAP, AN2, DELX,  RETA, ZL, T, TS, ETA, TEMP, TEMP2, ZN
real ::  XX
!INTEGER, INTENT(in) :: NB, L

!        Various mathematical constants

!
!     The following COMMON statement is needed only when testing this
!     function using BISECT, otherwise it can be removed.
!
!    COMMON/WAPCOM/NBITS
!    DATA INIT,NITER/0,1/
!     DATA NBITS/23/
!
!     IF(INIT.EQ.0) THEN
!        INIT=1
!
!        Code to calculate NBITS for the host machine. NBITS is the
!        mantissa length less one. This value is chosen to allow for
!        rounding error in the final bit. This need only be run once on
!        any particular machine. It can then be included in the above
!        DATA statement.
!
!        DO I=1,2000
!           B=2.E0**(-I)
!           V=1.E0+B
!           IF(V.EQ.1.E0)THEN
!              NBITS=I-1
!              J=-ALOG10(B)
!              IF(M.EQ.1) WRITE(NN,40)NBITS,J
!              EXIT
!           ENDIF
!        END DO
!
!        Remove to here after NBITS has been calculated once
!
!        The case of large NBITS
!
!        IF(NBITS.GE.56) NITER=2
!
!        Various mathematical constants
!
!        EM=-EXP(-1.E0)
!        EM9=-EXP(-9.E0)
!        C13=1.E0/3.E0
!        C23=2.E0*C13
!        EM2=2.E0/EM
!        E12=-EM2
!        TB=.5E0**NBITS
!        TB2=SQRT(TB)
!        X0=TB**(1.E0/6.E0)*.5E0
!        X1=(1.E0-17.E0*TB**(2.E0/7.E0))*EM
!        AN22=3.6E2/83.E0
!        AN11=135./83.E0
!        AN3=8.E0/3.E0
!        AN4=135.E0/83.E0
!        AN5=166.E0/39.E0
!        AN6=3167.E0/3549.E0
!        S2=SQRT(2.E0)
!        S21=2.E0*S2-3.E0
!        S22=4.E0-3.E0*S2
!        S23=S2-2.E0
!     ENDIF

!    IF(L.EQ.1) THEN
!       DELX=X
!       IF(DELX.LT.0.E0) THEN
!          WAP = 1./0.
!          RETURN
!       END IF
!       XX=X+EM
!!        IF(E12*DELX.LT.TB**2.AND.M.EQ.1) WRITE(NN,60)DELX
!    ELSE
       IF(X.LT.EM) THEN
          WAP = 1./0.
          RETURN
       END IF
       IF(X.EQ.EM) THEN
          WAP=-1.E0
          RETURN
       ENDIF
       XX  =X
       DELX=XX-EM
!        IF(DELX.LT.TB2.AND.M.EQ.1) WRITE(NN,70)XX
!    ENDIF
!    IF(NB.EQ.0) THEN
!
!        Calculations for Wp
!
       IF(ABS(XX).LE.X0) THEN
          WAP=XX/(1.E0+XX/(1.E0+XX/(2.E0+XX/(.6E0+.34E0*XX))))
          RETURN
       ELSE IF(XX.LE.X1) THEN
          RETA=SQRT(E12*DELX)
          WAP=RETA/(1.E0+RETA/(3.E0+RETA/(RETA/(AN4+RETA/(RETA*&
               AN6+AN5))+AN3)))-1.E0
          RETURN
       ELSE IF(XX.LE.2.E1) THEN
          RETA=S2*SQRT(1.E0-XX/EM)
          AN2=4.612634277343749E0*SQRT(SQRT(RETA+&
               1.09556884765625E0))
          WAP=RETA/(1.E0+RETA/(3.E0+(S21*AN2+S22)*RETA/&
               (S23*(AN2+RETA))))-1.E0
       ELSE
          ZL =ALOG(XX)
          WAP=ALOG(XX/ALOG(XX/ZL**EXP(-1.124491989777808E0/&
               (.4225028202459761E0+ZL))))
       ENDIF
!    ELSE
!!
!!        Calculations for Wm
!!
!       IF(XX.GE.0.E0) THEN
!          WAP = -1./0.
!          RETURN
!       END IF
!       IF(XX.LE.X1) THEN
!          RETA=SQRT(E12*DELX)
!          WAP=RETA/(RETA/(3.E0+RETA/(RETA/(AN4+RETA/(RETA*&
!               AN6-AN5))-AN3))-1.E0)-1.E0
!          RETURN
!       ELSE IF(XX.LE.EM9) THEN
!          ZL=ALOG(-XX)
!          T=-1.E0-ZL
!          TS=SQRT(T)
!          WAP=ZL-(2.E0*TS)/(S2+(C13-T/(2.7E2+&
!               TS*127.0471381349219E0))*TS)
!       ELSE
!          ZL=ALOG(-XX)
!          ETA=2.E0-EM2*XX
!          WAP=ALOG(XX/ALOG(-XX/((1.E0-.5043921323068457E0*&
!               (ZL+1.E0))*(SQRT(ETA)+ETA/3.E0)+1.E0)))
!       ENDIF
!    ENDIF
!     DO I=1,NITER
       ZN   =ALOG(XX/WAP)-WAP
       TEMP =1D0+WAP
       TEMP2=TEMP+C23*ZN
       TEMP2=2D0*TEMP*TEMP2
       WAP  =WAP*(1D0+(ZN/TEMP)*(TEMP2-ZN)/(TEMP2-2.E0*ZN))
!     END DO
    RETURN
END FUNCTION WAPR


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE PLTINO(MIN,MAX,START,REND,INTER,EXP,NMIN)
      REAL MIN,MAX,INTER,NINTER
      INTEGER EXP
      REAL NI
      DATA SMALL/1.E-4/,DESINT/5./

      DELTA = MAX - MIN
      TMAX = MAX
      TMIN = MIN
      IF (DELTA.NE.0) THEN
         EXP = NINT(LOG10(ABS(DELTA))) - 1

      ELSE
         IF (MIN.NE.0) THEN
            EXP = NINT(LOG10(ABS(MIN))) - 1
            EPS = .01*ABS(MIN)

         ELSE
            EXP = 0
            EPS = .1
         END IF

         TMAX = MAX + EPS
         TMIN = TMIN - EPS
      END IF

      TENEXP = 10.**EXP
      RMIN = 1.E20
      J = 1
      DO 2470 I = 1,5
         NINTER = DELTA/ (DBLE(I)*TENEXP)
         TEMP = ABS(DESINT-NINTER)
         IF (TEMP.LT.RMIN) THEN
            J = I
            RMIN = TEMP
         END IF

 2470 CONTINUE
      INTER = DBLE(J)
      IF (DELTA.EQ.0.) THEN
         INTER = 1.
      END IF

      IF (INTER.EQ.1.) THEN
         NMIN = 5

      ELSE IF (INTER.EQ.2.) THEN
         NMIN = 4

      ELSE IF (INTER.EQ.3.) THEN
         NMIN = 6

      ELSE IF (INTER.EQ.4.) THEN
         NMIN = 4

      ELSE IF (INTER.EQ.5.) THEN
         NMIN = 5
      END IF

      TENI = INTER*TENEXP
      IF (TMIN.GE.0.) THEN
         ADD = 0.

      ELSE
         ADD = -1.
      END IF

      RNI = TMIN/TENI
      NI = INT(RNI)
      IF (ABS(RNI-NI).LT.SMALL) THEN
         ADD = 0.
      END IF

      START = (NI+ADD)*TENI
      IF (TMAX.GE.0.) THEN
         ADD = 1.

      ELSE
         ADD = 0.
      END IF

      RNI = TMAX/TENI
      NI = INT(RNI)
      IF (ABS(RNI-NI).LT.SMALL) THEN
         ADD = 0.
      END IF

      REND = (NI+ADD)*TENI
      START = START/TENEXP
      REND = REND/TENEXP
      IF (REND.NE.0.) THEN
 2490    IF (.NOT. (ABS(REND).GT.10.)) GO TO 2500
         REND = REND/10.
         START = START/10.
         INTER = INTER/10.
         EXP = EXP + 1
         GO TO 2490

 2500    CONTINUE
      END IF

      IF (START.NE.0.) THEN
 2510    IF (.NOT. (ABS(START).LT.1.)) GO TO 2520
         REND = REND*10.
         START = START*10.
         INTER = INTER*10.
         EXP = EXP - 1
         GO TO 2510

 2520    CONTINUE
      END IF

      IF (START.EQ.0 .OR. TMIN.EQ.0) THEN
         RETURN

      END IF

      IF (START.EQ.REND) THEN
         REND = START + INTER
      END IF

      IF (ABS(START-REND).EQ.INTER) THEN
         NMIN = 10
      END IF

      RETURN

      END


    program dofft
! Fortran example.
! Compile line:
! ifort -mkl $MKLROOT/include/mkl_dfti.f90 -Wa -O3 segment.f90 -o segment
! 1D complex to complex, and real to conjugate-even
    Use MKL_DFTI
!    implicit none
    integer count0,count1,count2,count3, COUNT_RATE, COUNT_MAX
    integer :: ntotal,nbin,ndt,nb2
    integer :: is,ie,ifft
    integer :: ic,jline,outsize,i
    character (len=132) :: fname1,fname2
    logical,parameter :: doamp=.true.
    Real,allocatable :: Y(:),fullset(:),amp(:)
    real :: rp,cp
    type(DFTI_DESCRIPTOR), POINTER ::  My_Desc2_Handle
    Integer :: Status
    write(*,*)"Enter total # points, # points/bin, offset between bins"
    read(*,*)ntotal,nbin,ndt
    allocate(fullset(ntotal))
    nb2=nbin+2
    allocate(y(nb2))
    allocate(amp(nb2/2))
    if(doamp)then
      outsize=size(amp)
    else
      outsize=size(y)
    endif
    write(*,*)"Input file name:"
    read(*,*)fname1
    write(*,*)"Output file name:"
    read(*,*)fname2
    call SYSTEM_CLOCK(COUNT0, COUNT_RATE, COUNT_MAX)
    open(unit=17,file=fname1,access="stream",status="old")
    open(unit=18,file=fname2,access="stream",status="replace")
    read(17)fullset
    call SYSTEM_CLOCK(COUNT1)
    Status = DftiCreateDescriptor(My_Desc2_Handle, DFTI_SINGLE, DFTI_REAL, 1, nbin)
    Status = DftiCommitDescriptor(My_Desc2_Handle)
    is=1
    ie=(is-1)+nbin
    ifft=0
    call SYSTEM_CLOCK(COUNT2)
    do while(ie <= ntotal)
!...put input data into Y(1),...,Y(nbin)
!...we have two extra "spaces" for the midpoint of the fft
      y(1:nbin)=fullset(is:ie)
!...if we have a window it would be applied here
      Status = DftiComputeForward(My_Desc2_Handle, Y)
      ifft=ifft+1
      is=is+ndt
      ie=ie+ndt
      if(doamp)then
        ic=0
        jline=1
        do i=1,nb2
          if(ic == 0)then
    	    rp=y(i)
    	    ic=1
    	  else
            cp=y(i)
            amp(jline)=sqrt(rp*rp+cp*cp)
            ic=0
            jline=jline+1
    	  endif
        end do
        write(18)amp
      else
        write(18)Y
      endif
      write(*,*)ifft
    enddo
    call SYSTEM_CLOCK(COUNT3)
    Status = DftiFreeDescriptor(My_Desc2_Handle)
    write(*,*)
    write(*,*)"read time         ",real(count1-count0)/real(count_rate)
    write(*,*)"fft  & write time ",real(count3-count2)/real(count_rate)
    write(*,*)"output files is ",ifft," records with ",outsize," elements each"
    write(*,*)COUNT0, COUNT_RATE, COUNT_MAX
    end program


      SUBROUTINE GENHKL(XH,NSYM,RT,ICEN,NCV,CEN,JHK,HKL,IABSNT,MULP)

      INCLUDE       '../INCLDS/COPYRIGT.FOR'
!
! The HKL index generation S.R. - Generate equivs. even for spgp absent refl.

! Input data list

      REAL*4        XH(4)               ! Input Miller indices
      INTEGER*4     NSYM                ! Number of symmetry matrices
      INTEGER*4     RT(3,5,24)          ! The symmetry matrices
      INTEGER*4     ICEN                ! Flag indicating 1bar
      INTEGER*4     NCV                 ! The number of lattice centering vectors
      REAL*4        CEN(3,NCV)            ! The lattice centering vectors

!Output data list

      INTEGER*4     JHK                 ! Number of equivalent indices generated
      REAL*4        HKL(4,24)           ! The generated Miller indices
      INTEGER*4     IHKL(4,24)          ! The generated Miller indices
      INTEGER*4     IABSNT              ! Space group absence flag
      INTEGER*4     MULP                ! Multiplicity for powder line intensities

!CODE

      MULP = 0
      JHK = 1                                              ! Set generated reflection count to 1
      IABSNT = 0                                          ! Assume NOT Space Group Extinct

      IF ( ABS(NINT(XH(1))-XH(1))+
     1  ABS(NINT(XH(2))-XH(2))+
     1  ABS(NINT(XH(3))-XH(3)).GT.0.05 ) THEN                  !Check for non-integral indices, leave a bit of slop
        IABSNT = 1                                        !Non-integral indices are not allowed
      ELSE
        DO I=2,NCV                                          ! First check for lattice type extinctions
          K = 0
          DO J=1,3
            K = K+NINT(XH(J)*CEN(J,I)*12.0)
          END DO
          IF ( MOD(K,12).NE.0 ) IABSNT=1
        END DO
      END IF

      I = 1
      DO WHILE ( I.LE.NSYM )                                    ! Generate the equivalent index set
        DO J=1,4
          IHKL(J,JHK) = 0.0
          DO K=1,3
            IHKL(J,JHK) = IHKL(J,JHK)+IFIX(XH(K))*RT(K,J,I)
          END DO
        END DO

        NEW = 1
        NEWX = 1
        IF ( JHK.GT.1 ) THEN                                    ! Check for previous generation of this index
          J = 1
          DO WHILE ( J.LT.JHK .AND. NEW.EQ.1 )
            IF ( IHKL(1,J).EQ.IHKL(1,JHK) ) THEN
              IF ( IHKL(2,J).EQ.IHKL(2,JHK) ) THEN
                IF ( IHKL(3,J).EQ.IHKL(3,JHK) ) THEN
                  NEW = 0
                  NEWX = 0
                  IF ( MOD(IHKL(4,JHK)-IHKL(4,J)+960,12).NE.0 ) THEN
                    IABSNT = 1
                  END IF
                END IF
              END IF
            END IF
            IF ( NEW.EQ.1 ) THEN
              IF ( IHKL(1,J).EQ.-IHKL(1,JHK) ) THEN                  ! Check -h,k,l)
                IF ( IHKL(2,J).EQ.-IHKL(2,JHK) ) THEN
                  IF ( IHKL(3,J).EQ.-IHKL(3,JHK) ) THEN
                    NEWX = 0
                    IF ( ICEN.GT.0 ) THEN
                      NEW = 0
                      IF ( MOD(IHKL(4,JHK)-IHKL(4,J)+960,12).NE.0 ) THEN
                        IABSNT = 1
                      END IF
                    END IF
                  END IF
                END IF
              END IF
            END IF
            J = J+1
          END DO
        END IF
        MULP = MULP+NEWX
        IF ( NEW.EQ.1 ) THEN
!         IMAT(JHK) = I
          JHK = JHK+NEW
        END IF
        I = I+1
      END DO
      JHK = JHK-1

      DO I=1,JHK                                          ! All is OK. Convert to F.P.
        HKL(1,I) = IHKL(1,I)
        HKL(2,I) = IHKL(2,I)
        HKL(3,I) = IHKL(3,I)
        HKL(4,I) = MOD(FLOAT(IHKL(4,I))/12.0,1.0)
      END DO
      RETURN
      END


module PSEDirectSumModule

use NumberKindsModule
use LoggerModule
use ParticlesModule
use EdgesModule, only : MaxEdgeLength
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use SphereGeomModule, only : ChordDistance, SphereDistance, SphereProjection

implicit none

include 'mpif.h'

private
public PSE, New, Delete
public PSEPlaneInterpolateScalar
public PSEPlaneGradientAtParticles, PSEPlaneSecondPartialsAtParticles, PSEPlaneLaplacianAtParticles
public PSESphereInterpolateScalar, PSESphereGradientAtParticles, PSESphereDivergenceAtParticles, PSESphereLaplacianAtParticles
public bivariateFirstDerivativeKernel8, bivariateLaplacianKernel8
public PSEPlaneDoubleDotProductAtParticles

type PSE
	real(kreal) :: eps
	contains
		final :: deletePrivate
end type

interface New
	module procedure newPrivate
end interface

interface Delete
	module procedure deletePrivate
end interface

!
!----------------
! Logging
!----------------
!
logical(klog), save :: logInit = .FALSE.
type(Logger) :: log
character(len=28), save :: logKey = 'PSE'
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL

contains
!----------------
!
! Public functions
!
!----------------
subroutine newPrivate( self, aMesh, radiusMultiplier )
	type(PSE), intent(out) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	real(kreal), intent(in), optional :: radiusMultiplier
	!
	real(kreal) :: multiple
	integer(kint) :: nP

	if ( .NOT. logInit ) call InitLogger(log, procRank)

	if ( present(radiusMultiplier) ) then
		multiple = radiusMultiplier
	else
		multiple = 2.0_kreal
	endif

	self%eps = multiple * MaxEdgeLength( aMesh%edges, aMesh%particles)

end subroutine

subroutine deletePrivate(self)
	type(PSE), intent(inout) :: self
end subroutine

pure function PSEPlaneInterpolateScalar(self, aMesh, scalarField, interpLoc )
	real(kreal) :: PSEPlaneInterpolateScalar
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	real(kreal), intent(in) :: interpLoc(3)
	!
	integer(kint) :: j
	real(kreal) :: kIn, xj(3)

	PSEPlaneInterpolateScalar = 0.0_kreal
	do j = 1, aMesh%particles%N
		if ( aMesh%particles%isActive(j) ) then
			xj = PhysCoord(aMesh%particles,j)
			kIn = ChordDistance(interpLoc,xj)/self%eps
			PSEPlaneInterpolateScalar = PSEPlaneInterpolateScalar + scalarField%scalar(j) * aMesh%particles%area(j) * &
			 	bivariateDeltaKernel8( kIn ) / (self%eps**2)
		endif
	enddo
end function

subroutine PSEPlaneGradientAtParticles( self, aMesh, scalarField, scalarGrad, particlesMPI )
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	type(Field), intent(inout) :: scalarGrad
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), kOut

	call SetFieldToZero(scalarGrad)
	scalarGrad%N = aMesh%particles%N

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey), " entering PSEGradientAtParticles...")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = ChordDistance(xi,xj)/self%eps
				scalarGrad%xComp(i) = scalarGrad%xComp(i) + ( scalarField%scalar(j) + scalarField%scalar(i)) *&
					(xi(1)-xj(1)) * bivariateFirstDerivativeKernel8(kIn) / (self%eps**3) * aMesh%particles%area(j)
				scalarGrad%yComp(i) = scalarGrad%yComp(i) + ( scalarField%scalar(j) + scalarField%scalar(i)) *&
					(xi(2)-xj(2)) * bivariateFirstDerivativeKernel8(kIn) / (self%eps**3) * aMesh%particles%area(j)
			endif
		enddo
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST(scalarGrad%xComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
					   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST(scalarGrad%yComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
					   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo

	call MultiplyFieldByScalar(scalarGrad, 1.0_kreal/self%eps)
end subroutine

subroutine PSESphereGradientAtParticles( self, amesh, scalarField, scalarGrad, particlesMPI )
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	type(Field), intent(inout) :: scalarGrad
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), grad(3), proj(3,3), kOut

	call SetFieldToZero(scalarGrad)
	scalarGrad%N = aMesh%particles%N

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logkey), " entering PSESphereGradientAtParticles.")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		proj = SphereProjection(xi)
		grad = 0.0_kreal
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord( aMesh%particles, j)
				kIn = SphereDistance(xj, xi) / self%eps
				kOut = bivariateFirstDerivativeKernel8( kIn ) / self%eps**2
				grad(1) = grad(1) + ( scalarField%scalar(j) + scalarField%scalar(i)) * ( xi(1) - xj(1) ) * &
						  kOut * aMesh%particles%area(j)
				grad(2) = grad(2) + ( scalarField%scalar(j) + scalarField%scalar(i)) * ( xi(2) - xj(2) ) * &
						  kOut * aMesh%particles%area(j)
			    grad(3) = grad(3) + ( scalarField%scalar(j) + scalarField%scalar(i)) * ( xi(3) - xj(3) ) * &
			    		  kOut * aMesh%particles%area(j)
			endif
		enddo
		grad = MATMUL( proj, grad)
		scalarGrad%xComp(i) = grad(1)
		scalarGrad%yComp(i) = grad(2)
		scalarGrad%zComp(i) = grad(3)
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST( scalarGrad%xComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
			particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST( scalarGrad%yComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
			particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
		call MPI_BCAST( scalarGrad%zComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
			particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo
	call MultiplyFieldByScalar(scalarGrad, 1.0_kreal/(self%eps**2))
end subroutine

subroutine PSEPlaneSecondPartialsAtParticles( self, aMesh, scalarGrad, secondPartials, particlesMPI )
	type(PSE), intent(in) :: self
	class(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarGrad
	type(Field), intent(inout) :: secondPartials
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), dxx, dxy, dyx, dyy, kOut

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey), " entering PSESecondPartialsAtParticles...")

	call SetFieldToZero(secondPartials)
	secondPartials%N = aMesh%particles%N

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord( aMesh%particles, i)
		dxx = 0.0_kreal
		dxy = 0.0_kreal
		dyx = 0.0_kreal
		dyy = 0.0_kreal
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = ChordDistance(xi,xj)/self%eps
				kOUt = bivariateFirstDerivativeKernel8(kIn) / self%eps**2
				dxx = dxx + (scalarGrad%xComp(j) + scalarGrad%xComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				dxy = dxy + (scalarGrad%xComp(j) + scalarGrad%xComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
				dyx = dyx + (scalarGrad%yComp(j) + scalarGrad%yComp(i)) * ( xi(1) - xj(1)) /self%eps * &
					kOut * aMesh%particles%area(j)
				dyy = dyy + (scalarGrad%yComp(j) + scalarGrad%yComp(i)) * ( xi(2) - xj(2)) /self%eps * &
					kOut * aMesh%particles%area(j)
			endif
		enddo
		secondPartials%xComp(i) = dxx
		secondPartials%yComp(i) = 0.5_kreal * ( dxy + dyx )
		secondPartials%zComp(i) = dyy
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST(secondPartials%xComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
				   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCOde)
		call MPI_BCAST(secondPartials%yComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
				   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCOde)
		call MPI_BCAST(secondPartials%zComp(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
				   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCOde)
	enddo

	call MultiplyFieldByScalar( secondPartials, 1.0_kreal / self%eps )
end subroutine

subroutine PSEPlaneDoubleDotProductAtParticles( self, aMesh, vectorField, doubleDot, particlesMPI)
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: vectorField
	type(Field), intent(inout) :: doubleDot
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), ux, uy, vx, vy, kOut

	call SetFieldToZero(doubleDot)
	doubleDot%N = aMesh%particles%N

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey), " entering PSEDoubleDotProduct ...")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		ux = 0.0_kreal
		uy = 0.0_kreal
		vx = 0.0_kreal
		vy = 0.0_kreal
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = ChordDistance(xi,xj)/self%eps
				kOut = bivariateFirstDerivativeKernel8( kIn ) / self%eps**2
				ux = ux + (vectorField%xComp(j) + vectorField%xComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				uy = uy + (vectorField%xComp(j) + vectorField%xComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
				vx = vx + (vectorField%yComp(j) + vectorField%yComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				vy = vy + (vectorField%yComp(j) + vectorField%yComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
			endif
		enddo
		doubleDot%scalar(i) = (ux * ux + 2.0_kreal * uy * vx + vy * vy)/self%eps**2
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST( doubleDot%scalar(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
				particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode )
	enddo
end subroutine

subroutine PSESphereDoubleDotProductAtParticles( self, aMesh, vectorField, doubleDot, particlesMPI)
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: vectorField
	type(Field), intent(inout) :: doubleDot
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), ux, uy, uz, vx, vy, vz, wx, wy, wz, kOut

	call SetFieldToZero(doubleDot)
	doubleDot%N = aMesh%particles%N

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		ux = 0.0_kreal
		uy = 0.0_kreal
		uz = 0.0_kreal
		vx = 0.0_kreal
		vy = 0.0_kreal
		vz = 0.0_kreal
		wx = 0.0_kreal
		wy = 0.0_kreal
		wz = 0.0_kreal
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = SphereDistance(xi,xj) / self%eps
				kOut = bivariateFirstDerivativeKernel8( kIn ) / self%eps**2
				ux = ux + (vectorField%xComp(j) + vectorField%xComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				uy = uy + (vectorField%xComp(j) + vectorField%xComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
				uz = uz + (vectorField%xComp(j) + vectorField%xComp(i)) * ( xi(3) - xj(3) )/self%eps * &
					kOut * aMesh%particles%area(j)
				vx = vx + (vectorField%yComp(j) + vectorField%yComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				vy = vy + (vectorField%yComp(j) + vectorField%yComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
				vz = vz + (vectorField%yComp(j) + vectorField%yComp(i)) * ( xi(3) - xj(3) )/self%eps * &
					kOut * aMesh%particles%area(j)
				wx = wx + (vectorField%zComp(j) + vectorField%yComp(i)) * ( xi(1) - xj(1) )/self%eps * &
					kOut * aMesh%particles%area(j)
				wy = wy + (vectorField%zComp(j) + vectorField%yComp(i)) * ( xi(2) - xj(2) )/self%eps * &
					kOut * aMesh%particles%area(j)
				wz = wz + (vectorField%zComp(j) + vectorField%yComp(i)) * ( xi(3) - xj(3) )/self%eps * &
					kOut * aMesh%particles%area(j)
			endif
		enddo
		doubleDot%scalar(i) = (ux*ux + vy*vy + wz*wz + 2.0_kreal*( uy*vx + uz*wx + vz*wy))/self%eps**2
	enddo
end subroutine

subroutine PSEDoubleDotProductArrays( self, doubleDot, xIn, yIn, uIn, vIn, areaIn, activeMask, mpiParticles )
	type(PSE), intent(in) :: self
	real(kreal), intent(out) :: doubleDot(:)
	real(kreal), intent(in) :: xIn(:)
	real(kreal), intent(in) :: yIn(:)
	real(kreal), intent(in) :: uIn(:)
	real(kreal), intent(in) :: vIn(:)
	real(kreal), intent(in) :: areaIn(:)
	logical(klog), intent(in) :: activeMask(:)
	type(MPISetup), intent(in) :: mpiParticles
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, ux, uy, vx, vy, kernel

	doubleDot(mpiParticles%indexStart(procRank):mpiParticles%indexEnd(procRank)) = 0.0_kreal

	do i = mpiParticles%indexStart(procRank), mpiParticles%indexEnd(procRank)
		ux = 0.0_kreal
		uy = 0.0_kreal
		vx = 0.0_kreal
		vy = 0.0_kreal
		if ( activeMask(j) ) then
			kIn  = sqrt( (xIn(i) - xIn(j))**2 + (yIn(i) - yIn(j))**2 ) / self%eps
			kernel = bivariateFirstDerivativeKernel8( kIn ) / self%eps**2
			ux = ux + ( uIn(j) + uIn(i) ) * ( xIn(i) - xIn(j) ) / self%eps * kernel * areaIn(j)
			uy = uy + ( uIn(j) + uIn(i) ) * ( yIn(i) - yIn(j) ) / self%eps * kernel * areaIn(j)
			vx = vx + ( vIn(j) + vIn(i) ) * ( xIn(i) - xIn(j) ) / self%eps * kernel * areaIn(j)
			vy = vy + ( vIn(j) + vIn(i) ) * ( yIn(i) - yIn(j) ) / self%eps * kernel * areaIn(j)
		endif
		doubleDot(i) = ( ux * ux + 2.0_kreal * uy * vx + vy * vy ) / self%eps**2
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST( doubleDot(mpiParticles%indexStart(i):mpiParticles%indexEnd(i)), mpiParticles%messageLength(i), &
			MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo
end subroutine

subroutine PSEPlaneLaplacianAtParticles(self, aMesh, scalarField, scalarLap, particlesMPI )
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	type(Field), intent(inout) :: scalarLap
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3)

	call SetFieldToZero(scalarLap)
	scalarLap%N = aMesh%particles%N

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey), " entering PSELaplacianAtParticles...")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = ChordDistance(xi,xj)/self%eps
				scalarLap%scalar(i) = scalarLap%scalar(i) + (scalarField%scalar(j) - scalarField%scalar(i)) * &
					bivariateLaplacianKernel8(kIN)/(self%eps**2) * aMesh%particles%area(j)
			endif
		enddo
	enddo

	do i = 0, numProcs-1
		call MPI_BCAST(scalarLap%scalar(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
					   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo

	call MultiplyFieldByScalar(scalarLap, 1.0_kreal/(self%eps**2))
end subroutine

subroutine PSESphereLaplacianAtParticles( self, aMesh, scalarField, scalarLap, particlesMPI )
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	type(Field), intent(inout) :: scalarLap
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3)

	call SetFieldToZero(scalarLap)
	scalarLap%N = aMesh%particles%N

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logKey), " entering PSELaplacianAtParticles...")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = SphereDistance(xi,xj)/self%eps
				scalarLap%scalar(i) = scalarLap%scalar(i) + (scalarField%scalar(j) - scalarField%scalar(i)) * &
					bivariateLaplacianKernel8(kIN)/(self%eps**2) * aMesh%particles%area(j)
			endif
		enddo
	enddo

	do i = 0, numProcs-1
		call MPI_BCAST(scalarLap%scalar(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
					   particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	enddo

	call MultiplyFieldByScalar(scalarLap, 1.0_kreal/(self%eps**2))
end subroutine

pure function PSESphereInterpolateScalar( self, aMesh, scalarField, interpLoc)
	real(kreal) :: PSESphereInterpolateScalar
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: scalarField
	real(kreal), intent(in) :: interpLoc(3)
	!
	integer(kint) :: j
	real(kreal) :: kIn, xj(3)

	PSESphereInterpolateScalar = 0.0_kreal
	do j = 1, aMesh%particles%N
		if ( aMesh%particles%isActive(j) ) then
			xj = PhysCoord(aMesh%particles, j)
			kIn = SphereDistance(xj, interpLoc)/self%eps
			PSESphereInterpolateScalar = PSESphereInterpolateScalar + scalarField%scalar(j) * aMesh%particles%area(j) * &
				bivariateDeltaKernel8( kIn ) / (self%eps**2)
		endif
	enddo
end function

subroutine PSESphereDivergenceAtParticles( self, aMesh, vectorField, divergence, particlesMPI )
	type(PSE), intent(in) :: self
	type(PolyMesh2d), intent(in) :: aMesh
	type(Field), intent(in) :: vectorField
	type(Field), intent(inout) :: divergence
	type(MPISetup), intent(in) :: particlesMPI
	!
	integer(kint) :: i, j, mpiErrCode
	real(kreal) :: kIn, xi(3), xj(3), grad(3), proj(3,3), denom

	call SetFieldToZero(divergence)
	divergence%N = aMesh%particles%N

	denom = self%eps**3

	call LogMessage(log, DEBUG_LOGGING_LEVEL, trim(logkey), " entering PSESphereDivergenceAtParticles.")

	do i = particlesMPI%indexStart(procRank), particlesMPI%indexEnd(procRank)
		xi = PhysCoord(aMesh%particles, i)
		proj = SphereProjection(xi)
		grad = 0.0_kreal
		do j = 1, aMesh%particles%N
			if ( aMesh%particles%isActive(j) ) then
				xj = PhysCoord(aMesh%particles, j)
				kIn = SphereDistance(xj, xi)/self%eps
				grad(1) = (xi(1) - xj(1)) * bivariateFirstDerivativeKernel8( kIn ) / denom
				grad(2) = (xi(2) - xj(2)) * bivariateFirstDerivativeKernel8( kIn ) / denom
				grad(3) = (xi(3) - xj(3)) * bivariateFirstDerivativeKernel8( kIn ) / denom
				grad = MATMUL( proj, grad )
				divergence%scalar(i) = divergence%scalar(i) + ( grad(1) * (vectorField%xComp(j) + vectorField%xComp(i)) + &
						grad(2) * (vectorField%yComp(j) + vectorField%yComp(i) ) +&
						grad(3) * (vectorField%zComp(j) + vectorField%zComp(i) )) * aMesh%particles%area(j)
			endif
		enddo
	enddo

	do i = 0, numProcs - 1
		call MPI_BCAST( divergence%scalar(particlesMPI%indexStart(i):particlesMPI%indexEnd(i)), &
			particlesMPI%messageLength(i), MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode )
	enddo

	call MultiplyFieldByScalar(divergence, 1.0_kreal/self%eps)
end subroutine

!----------------
!
! Private functions
!
!----------------

pure function integralKernelInput( xi, xj, eps, geomKind )
	real(kreal) :: integralKernelInput
	real(kreal), intent(in) :: xi(3), xj(3), eps
	integer(kint), intent(in) :: geomKind
	if ( geomKind == PLANAR_GEOM ) then
		integralKernelInput = ChordDistance(xi,xj)/eps
	elseif ( geomKind == SPHERE_GEOM ) then
		integralKernelInput = SphereDistance(xi,xj)/eps
	else
		integralKernelInput = 0.0_kreal
	endif
end function

pure function bivariateDeltaKernel8( radialDist )
	real(kreal) :: bivariateDeltaKernel8
	real(kreal), intent(in) :: radialDist
	bivariateDeltaKernel8 = (4.0_kreal - 6.0_kreal * radialDist**2 + 2.0_kreal * radialDist**4 - &
			 radialDist**6 / 6.0_kreal) * exp(-radialDist * radialDist) / PI
end function

pure function bivariateLaplacianKernel8( radialDist )
	real(kreal) :: bivariateLaplacianKernel8
	real(kreal), intent(in) :: radialDist
	bivariateLaplacianKernel8 = (40.0_kreal - 40.0_kreal * radialDist**2 + 10.0_kreal * radialDist**4 - &
								 2.0_kreal * radialDist**6/3.0_kreal) * exp( -radialDist*radialDist) / PI
end function

pure function bivariateFirstDerivativeKernel8( radialDist)
	real(kreal) :: bivariateFirstDerivativeKernel8
	real(kreal), intent(in) :: radialDist
	bivariateFirstDerivativeKernel8 = (-20.0_kreal + 20.0_kreal * radialDist**2 - 5.0_kreal * radialDist**4 + &
									   radialDist**6/3.0_kreal) * exp( - radialDist*radialDist ) / PI
end function

pure function bivariateSecondDerivativeKernel8( radialDist )
	real(kreal) :: bivariateSecondDerivativeKernel8
	real(kreal), intent(in) :: radialDist
	bivariateSecondDerivativeKernel8 = (24.0_kreal -16.0_kreal * radialDist**2 + 2.0_kreal * radialDist**4) * &
				exp(- radialDist**2) / PI
end function

pure function bivariateMixedSecondDerivativeKernel8( radialDist, x, y )
	real(kreal) :: bivariateMixedSecondDerivativeKernel8
	real(kreal), intent(in) :: radialDist, x, y
	bivariateMixedSecondDerivativeKernel8 = x * y * (160.0_kreal - 120.0_kreal * radialDist**2  + &
		24.0_kreal * radialDist**4 - 4.0_kreal * radialDist**6/3.0_kreal )* exp(-radialDist**2)/PI
end function

pure function trivariateDeltaKernel8( radialDist )
	real(kreal) :: trivariateDeltaKernel8
	real(kreal), intent(in) :: radialDist
	trivariateDeltaKernel8 = (6.5625_kreal - 7.875 * radialDist**2 + 2.25_kreal * radialDist**4 - &
		radialDist**6/6.0_kreal) * exp( - radialDist**2 ) / 5.568327996831708_kreal
end function

pure function trivariateFirstDerivativeKernel8( radialDist, eps )
	real(kreal) :: trivariateFirstDerivativeKernel8
	real(kreal), intent(in) :: radialDist
	real(kreal), intent(in) :: eps
	trivariateFirstDerivativeKernel8 = (-7.875_kreal/eps**2 + 9.0_kreal * radialDist**2/eps**4 - radialDist**4/eps**4 - &
										13.125_kreal - 15.75_kreal * radialDist**2 + 4.5_kreal * radialDist**4 - &
										radialDist**6/3.0_kreal ) * exp(-radialDist**2)
end function

subroutine InitLogger(aLog,rank)
! Initialize a logger for this module and processor
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	if ( rank == 0 ) then
		call New(aLog,logLevel)
	else
		call New(aLog,ERROR_LOGGING_LEVEL)
	endif
	logInit = .TRUE.
end subroutine

end module